Private Type RECT Left As Long Top As Long Right As Long Bottom As Long End Type
Private Type BITMAP bmType As Long bmWidth As Long bmHeight As Long bmWidthBytes As Long bmPlanes As Integer bmBitsPixel As Integer bmBits As Long End Type
Private Type RGNDATAHEADER dwSize As Long iType As Long nCount As Long nRgnSize As Long rcBound As RECT End Type
Private Type RGNDATA rdh As RGNDATAHEADER Buffer As Byte End Type
Private Const RGN_OR = 2
Private Declare Function GetTickCount Lib "kernel32" () As Long Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef Ptr() As Any) As Long Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long Private Declare Function GetGDIObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal SrcHeightRgn1 As Long, ByVal SrcHeightRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function CreateRectRgn Lib "gdi32" (ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long) As Long Private Declare Function ExtCreateRegion Lib "gdi32" (lpXform As Long, ByVal nCount As Long, lpRgnData As Any) As Long Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (lpDst As Any, lpSrc As Any, ByVal ByteLength As Long) Private Declare Function SetWindowRgn Lib "user32" (ByVal Hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Function SetWindowRgnByPicture(Hwnd As Long, Pic As StdPicture, Optional MaskColor As Long = -1) As Long Dim i As Long, j As Long Dim DataArr(0 To 2) As Byte, pDataArr(0 To 0) As Long Dim OldArrPtr As Long, OldpArrPtr As Long Dim LineAddBytes As Long, PixelAddBytes As Long Dim Data(2000) As RECT, Count As Long '这里定义2000也是客观的，一般异型窗体的构成数据不会太多 Dim Rgn As Long, TempRgn As Long Dim MaskRed As Long, MaskGreen As Long Dim MaskBlue As Long, Bmp As BITMAP
If MaskColor = -1 Then '如果maskcolor=-1，则指定图像的左上角第一个点的颜色为过滤色 pDataArr(0) = Bmp.bmBits + Bmp.bmWidthBytes * (Bmp.bmHeight - 1) 'stdpicture在内存中和BMP一样，是逆序存储的，因此要用这个代码定位到左上角第一行 MaskRed = DataArr(2) MaskGreen = DataArr(1) MaskBlue = DataArr(0) Else GetRGB MaskColor, MaskRed, MaskGreen, MaskBlue '得到用户指定的颜色的三基色 End If
PixelAddBytes = Bmp.bmBitsPixel / 8 '可为3，可为4
For i = 1 To Bmp.bmHeight j = 0 '恢复数据 pDataArr(0) = Bmp.bmBits + Bmp.bmWidthBytes * (Bmp.bmHeight - i) Count = 2 '区域数据从第三个Rect开始 Do For j = j To Bmp.bmWidth - 1 If DataArr(2) <> MaskRed Or DataArr(1) <> MaskGreen Or DataArr(0) <> MaskBlue Then Exit For End If pDataArr(0) = pDataArr(0) + PixelAddBytes Next pDataArr(0) = pDataArr(0) + PixelAddBytes StartPos = j + 1
For j = j + 1 To Bmp.bmWidth - 1 If DataArr(2) = MaskRed And DataArr(1) = MaskGreen And DataArr(0) = MaskBlue Then Exit For End If pDataArr(0) = pDataArr(0) + PixelAddBytes Next pDataArr(0) = pDataArr(0) + PixelAddBytes EndPos = j j = j + 1
If StartPos <= EndPos Then Data(Count).Left = StartPos '填充结构 Data(Count).Top = i - 1 Data(Count).Right = EndPos Data(Count).Bottom = i Count = Count + 1 End If Loop Until j >= Bmp.bmWidth
TempRgn = ExtCreateRegion(ByVal 0, Count * 16, Data(0)) '大部分情况下一行数据不会出现大于2000个矩形的 CombineRgn Rgn, TempRgn, Rgn, RGN_OR DeleteObject TempRgn Next End If SetWindowRgn Hwnd, Rgn, True DeleteObject Rgn End Function
Private Sub Form_Load() Dim T As Long T = GetTickCount SetWindowRgnByPicture Me.Hwnd, Me.Picture Label1.Caption = "用时" & GetTickCount - T & "毫秒" End Sub
Private Sub MakePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByRef OldArrPtr As Long, ByRef OldpArrPtr As Long) Dim Temp As Long, TempPtr As Long CopyMemory Temp, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址 Temp = Temp + 12 '这个指针偏移12个字节后就是pvData指针 CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址 TempPtr = TempPtr + 12 '这个指针偏移12个字节后就是pvData指针 CopyMemory OldpArrPtr, ByVal TempPtr, 4 '保存旧地址 CopyMemory ByVal TempPtr, Temp, 4 '使pDataArrPtr指向DataArrPtr的SAFEARRAY结构的pvData指针 CopyMemory OldArrPtr, ByVal Temp, 4 '保存旧地址 End Sub
Private Sub FreePoint(ByVal DataArrPtr As Long, ByVal pDataArrPtr As Long, ByVal OldArrPtr As Long, ByVal OldpArrPtr As Long) Dim TempPtr As Long CopyMemory TempPtr, ByVal DataArrPtr, 4 '得到DataArrPtr的SAFEARRAY结构的地址 CopyMemory ByVal (TempPtr + 12), OldArrPtr, 4 '恢复旧地址 CopyMemory TempPtr, ByVal pDataArrPtr, 4 '得到pDataArrPtr的SAFEARRAY结构的地址 CopyMemory ByVal (TempPtr + 12), OldpArrPtr, 4 '恢复旧地址 End Sub
Private Sub GetRGB(Color As Long, Red As Long, Green As Long, Blue As Long) If Color <> 0 Then Red = Color And 255& Green = Color \ 256 And 255 Blue = Color \ 65536 End If End Sub
