可以实现的模块代码: Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPublic Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPublic Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As LongPublic Const RGN_OR = 2Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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 TypeDim bmByte() As BytePublic Declare Function ReleaseCapture Lib "user32" () As LongPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long'Public Const WM_SYSCOMMAND = &H112 'Public Const SC_MOVE = &HF012 Public Const HTCAPTION = 2 Public Const WM_NCLBUTTONDOWN = &HA1 Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull) Dim X As Long, Y As Long Dim Rgn1 As Long, Rgn2 As Long Dim SPos As Long, EPos As Long Dim bm As BITMAP Dim hbm As Long Dim Wid As Long, Hgt As Long Dim xoff As Long, yoff As Long'获取窗体背景图片尺寸hbm = hForm.Picture GetObjectAPI hbm, Len(bm), bm Wid = bm.bmWidth Hgt = bm.bmHeight ReDim bmByte(1 To Wid, 1 To Hgt) GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组 '如果没有传入transColor参数,则用第一个像素作为透明色If transColor = vbNull Then transColor = bmByte(1, 1)Rgn1 = CreateRectRgn(0, 0, 0, 0)For Y = 1 To Hgt '逐行扫描 X = 0 Do X = X + 1While (bmByte(X, Y) = transColor) And (X < Wid) X = X + 1 '跳过是透明色的点 Wend SPos = X While (bmByte(X, Y) <> transColor) And (X < Wid) X = X + 1 '跳过不是透明色的点 Wend EPos = X - 1'这一段是合并区域 If SPos <= EPos Then Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y) CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR DeleteObject Rgn2 End If Loop Until X >= Wid Next YSetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域 DeleteObject Rgn1End Subform窗体:Private Sub Form_Load() 'If Me.Picture <> 0 Then Call SetAutoRgn(Me) Me.Picture = LoadPicture(App.Path & "\m005.bmp") Call SetAutoRgn(Me) Me.Picture = LoadPicture(App.Path & "\005.jpg")End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) '移动窗体If Button = vbLeftButton Then ReleaseCapture SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0& End If If Button = vbRightButton Then PopupMenu Form2.main End If End Sub
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As LongPublic Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As LongPublic Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As LongPublic Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPublic Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As LongPublic Const RGN_OR = 2Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) 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 TypeDim bmByte() As BytePublic Declare Function ReleaseCapture Lib "user32" () As LongPublic Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long'Public Const WM_SYSCOMMAND = &H112
'Public Const SC_MOVE = &HF012
Public Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
Dim X As Long, Y As Long
Dim Rgn1 As Long, Rgn2 As Long
Dim SPos As Long, EPos As Long
Dim bm As BITMAP
Dim hbm As Long
Dim Wid As Long, Hgt As Long
Dim xoff As Long, yoff As Long'获取窗体背景图片尺寸hbm = hForm.Picture
GetObjectAPI hbm, Len(bm), bm
Wid = bm.bmWidth
Hgt = bm.bmHeight
ReDim bmByte(1 To Wid, 1 To Hgt)
GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组
'如果没有传入transColor参数,则用第一个像素作为透明色If transColor = vbNull Then transColor = bmByte(1, 1)Rgn1 = CreateRectRgn(0, 0, 0, 0)For Y = 1 To Hgt '逐行扫描
X = 0
Do
X = X + 1While (bmByte(X, Y) = transColor) And (X < Wid)
X = X + 1 '跳过是透明色的点
Wend
SPos = X
While (bmByte(X, Y) <> transColor) And (X < Wid)
X = X + 1 '跳过不是透明色的点
Wend
EPos = X - 1'这一段是合并区域
If SPos <= EPos Then
Rgn2 = CreateRectRgn(SPos - 1, Y - 1, EPos, Y)
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next YSetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
DeleteObject Rgn1End Subform窗体:Private Sub Form_Load()
'If Me.Picture <> 0 Then Call SetAutoRgn(Me)
Me.Picture = LoadPicture(App.Path & "\m005.bmp")
Call SetAutoRgn(Me)
Me.Picture = LoadPicture(App.Path & "\005.jpg")End SubPrivate Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'移动窗体If Button = vbLeftButton Then
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
If Button = vbRightButton Then
PopupMenu Form2.main
End If
End Sub
[email protected]