如何在VB中作出图形窗口

Question

多谢，可是我希望窗体的背景是透明的，而且可以拖动，我用了以下的代码：Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Sub Form_Load()
Me.AutoRedraw = True
    hBitmap = CreateCompatibleBitmap(Me.hdc, 0, 0)
    SelectObject Me.hdc, hBitmap
    Me.Refresh
End Sub
但是一拖动就露馅了，窗体的周围是初始的那些背景，很难看。
如何解决？谢谢！

Answer 1

Private Declare Function TransparentBlt Lib "msimg32" (ByVal hdcdest As Long, ByVal nXOrigindest As Long, ByVal nYOrigindest As Long, ByVal nWidthdest As Long, ByVal nHeightdest As Long, ByVal HdcSrc As Long, ByVal nXOriginSrc As Long, ByVal nYOriginSrc As Long, ByVal nWidthSrc As Long, ByVal nHeightSrc As Long, ByVal CrTrans As Long) As Long

Answer 2

是把白色挖掉吗？用这个：
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As LongPrivate Sub Form_Load()
dim  rtn 
    rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
    rtn = rtn Or WS_EX_LAYERED
    SetWindowLong hwnd, GWL_EXSTYLE, rtn
    SetLayeredWindowAttributes hwnd, RGB(255, 255, 255), 0, LWA_COLORKEY  'rgb(,,)就是你要挖掉的颜色。
end sub不知是这样吗？

Answer 3

to:genius_top1(魔鬼天才) 最大限制：只能在win2k或以上使用SetLayeredWindowAttributes API

Answer 4

下面的例子就是你想要的：
Public Function GetBitmapRegion(cPicture As StdPicture, cTransparent As Long)
'Variable Declaration
    Dim hRgn As Long, tRgn As Long
    Dim X As Integer, Y As Integer, X0 As Integer
    Dim hDC As Long, BM As BITMAP
'Create a new memory DC, where we will scan the picture
    hDC = CreateCompatibleDC(0)
    If hDC Then
'Let the new DC select the Picture
        SelectObject hDC, cPicture
'Get the Picture dimensions and create a new rectangular
'region
        GetObject cPicture, Len(BM), BM
        hRgn = CreateRectRgn(0, 0, BM.bmWidth, BM.bmHeight)
'Start scanning the picture from top to bottom
        For Y = 0 To BM.bmHeight
            For X = 0 To BM.bmWidth
'Scan a line of non transparent pixels
                While X <= BM.bmWidth And GetPixel(hDC, X, Y) <> cTransparent
                    X = X + 1
                Wend
'Mark the start of a line of transparent pixels
                X0 = X
'Scan a line of transparent pixels
                While X <= BM.bmWidth And GetPixel(hDC, X, Y) = cTransparent
                    X = X + 1
                Wend
'Create a new Region that corresponds to the row of
'Transparent pixels and then remove it from the main
'Region
                If X0 < X Then
                    tRgn = CreateRectRgn(X0, Y, X, Y + 1)
                    CombineRgn hRgn, hRgn, tRgn, 4
'Free the memory used by the new temporary Region
                    DeleteObject tRgn
                End If
            Next X
        Next Y
'Return the memory address to the shaped region
        GetBitmapRegion = hRgn
'Free memory by deleting the Picture
        DeleteObject SelectObject(hDC, cPicture)
    End If
'Free memory by deleting the created DC
    DeleteDC hDC
End Function

Answer 5

Office助手有现成的API呀！
在MSDN中找Microsoft Agent，说明很详细的

Answer 6

楼上的老兄，能否给小生讲一下Office助手的API使用方法，我手头没有MSDN，现在北京买盗版光盘很困难了。不胜感激！！！在此先谢上！

Answer 7

MSAgent 控件：Microsoft Agent Control 2.0

Answer 8

给你一个例子：http://caotang.myetang.com/temp/msagent.zip

Answer 9

楼上的高手，你推荐的例子我看了，可是没有头绪。这方面的资料很少的。另外，Microsoft Agent Control 2.0我从没用过，属性也就那么几个，想不出来怎么回事。还是麻烦各位高手多费一番口舌给我讲讲了，大恩不言谢！

Answer 10

这是我常用的一个制作异形窗体的函数，
用法是：
SetFrmRgn 目标窗体，源图象[，透明色]
如果省略透明色的话，源图象左上角第一个象素的颜色将作为透明色。
希望对你能有帮助Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nwidth As Long, ByVal nheight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Type BITMAP '14 bytes
        bmType As Long
        bmWidth As Long
        bmHeight As Long
        bmWidthBytes As Long
        bmPlanes As Integer
        bmBitsPixel As Integer
        bmBits As Long
End Type
Public Const RGN_OR = 2Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const WM_NCLBUTTONDOWN = &HA1
Private Const HTCAPTION = 2Public Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Public Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
Const IMAGE_BITMAP = 0
Const IMAGE_ICON = 1
Const IMAGE_CURSOR = 2
Const LR_DEFAULTCOLOR = &H0
Const LR_MONOCHROME = &H1
Const LR_COLOR = &H2
Const LR_COPYRETURNORG = &H4
Const LR_COPYDELETEORG = &H8
Const LR_LOADFROMFILE = &H10
Const LR_LOADTRANSPARENT = &H20
Const LR_DEFAULTSIZE = &H40
Const LR_VGACOLOR = &H80
Const LR_LOADMAP3DCOLORS = &H1000
Const LR_CREATEDIBSECTION = &H2000
Const LR_COPYFROMRESOURCE = &H4000
Const LR_SHARED = &H8000
Public Function SetFrmRgn(Frm As Form, Pic As Long, Optional TransColor As Long = vbNull)
    '创建设备场景并把目标位图选入场景中
    Dim NewDC As Long, SPic As Long, cPic As Long, err As Long
    Dim Bm As BITMAP
    GetObject Pic, Len(Bm), Bm
    cPic = CopyImage(Pic, IMAGE_BITMAP, Bm.bmWidth, Bm.bmHeight, LR_CREATEDIBSECTION)
    NewDC = CreateCompatibleDC(Frm.hdc)
    SPic = SelectObject(NewDC, cPic)
    '----------------------------------
    
    Dim x As Long, y As Long
    Dim Rgn1 As Long, Rgn2 As Long
    Dim Pos1 As Long, Pos2 As Long
    Dim xOff As Long, yOff As Long
    
    If TransColor = vbNull Then TransColor = GetPixel(NewDC, 0, 0)
    Rgn1 = CreateRectRgn(0, 0, 0, 0)
    
    '改变窗体大小
    With Frm
        .ScaleMode = vbPixels
        xOff = (.ScaleX(.Width, vbTwips, vbPixels) - .ScaleWidth) / 2
        yOff = .ScaleY(.Height, vbTwips, vbPixels) - .ScaleHeight - xOff
        .Width = (Bm.bmWidth + xOff * 2) * Screen.TwipsPerPixelX
        .Height = (Bm.bmHeight + xOff + yOff) * Screen.TwipsPerPixelY
    End With
    
    '创建窗体区域
    For y = 0 To Bm.bmHeight - 1
        x = 0
        Do
            While GetPixel(NewDC, x, y) = TransColor And x < Bm.bmWidth
                x = x + 1
            Wend
            Pos1 = x
            
            While GetPixel(NewDC, x, y) <> TransColor And x < Bm.bmWidth
                x = x + 1
            Wend
            Pos2 = x - 1
            
            If Pos1 <= Pos2 Then
                Rgn2 = CreateRectRgn(Pos1 + xOff, y + yOff, Pos2 + 1 + xOff, y + 1 + yOff)
                CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
                DeleteObject Rgn2
            End If
        Loop Until x >= Bm.bmWidth
    Next y
    
    SetWindowRgn Frm.hwnd, Rgn1, True
    DeleteObject Rgn1
    
    '----------------------------------
    '释放资源
    err = SelectObject(NewDC, SPic)
    err = DeleteObject(cPic)
    err = DeleteObject(SPic)
    err = DeleteDC(NewDC)
End Function'把此段过程加入到窗体的MouseDown事件中，使窗体可以被拖动
Public Sub NewFormMove(hForm As Form)
    ReleaseCapture
    SendMessage hForm.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0
End Sub