知道如何最快的构造出图形异型窗体吗,我来告诉你,不服你可以写个更高效的------纯粹活跃下群里的气氛。
这个是我些图像处理软件的是时候的副产品,注释些了一半,后面的真的不想写了,呵呵,对于新手可能难以理解,管他呢,只要能痛就行。
我喜欢直接贴代码:
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
GetGDIObject Pic.Handle, Len(Bmp), Bmp
If Bmp.bmBits <> 0 Then '是个有效的图片
If Bmp.bmBits < 24 Then Exit Function '不处理费真彩色图像,实际上,VB的picture属性也支持8位索引色的Bmp,如果你为了节省内存,采用改格式的图片,可以自行修改代码。
Rgn = CreateRectRgn(0, 0, 0, 0) '先创建一个空的区域
Data(0).Left = 32 'dwSize,结构的大小 ,参考RGNDATAHEADER结构
Data(0).Top = 1 'iType,类型
Data(0).Right = 0 'nCount,数量
Data(0).Bottom = 0 'nRgnSize
Data(1).Left = 0 '边界
Data(1).Top = 0
Data(1).Right = 100000
Data(1).Bottom = 100000
'ExtCreateRegion这个函数的第三个参数就是一片连续的内存,其前8*4个字节记录了相关的整体数据,后面的都是构成这个区域矩形的数据
MakePoint VarPtrArray(DataArr), VarPtrArray(pDataArr), OldArrPtr, OldpArrPtr
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
Data(0).Right = Count - 2
Data(0).Bottom = Data(0).Right * 16
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
'*****************************************************************************************
'** 过 程 名 : FreePoint
'** 输 入 :
'** 功能描述 : 取消绑定模拟数组
'** 开发日期 : 2007-4-02
'** 作 者 : laviewpbt
'** 修改日期 :
'** 版 本 : Version 1.2.1
'****************************************************************************************
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
Private Sub Form_DblClick()
Unload Me
End Sub
从优化上讲,代码中的一些变量可能还可以用中间变量来代替,以提高速度,不过我不喜欢该了。
欢迎大家挑战。