知道如何最快的构造出图形异型窗体吗,我来告诉你,不服你可以写个更高效的------纯粹活跃下群里的气氛。

laviewpbt 2008-08-22 09:48:34
加精
这个是我些图像处理软件的是时候的副产品,注释些了一半,后面的真的不想写了,呵呵,对于新手可能难以理解,管他呢,只要能痛就行。

我喜欢直接贴代码:


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


从优化上讲,代码中的一些变量可能还可以用中间变量来代替,以提高速度,不过我不喜欢该了。
欢迎大家挑战。



...全文
2455 100 打赏 收藏 转发到动态 举报
写回复
用AI写文章
100 条回复
切换为时间正序
请发表友善的回复…
发表回复
wpeng1123 2011-08-19
  • 打赏
  • 举报
回复
[Quote=引用 11 楼 laviewpbt 的回复:]

VB已经快咽气了。
[/Quote]

相信vb.net的将来是很好的
ygbh9999 2009-05-03
  • 打赏
  • 举报
回复
谢谢LZ

不过好象透明色中间多有几个1、2个象素的杂点时好象容易崩溃
cyh424 2008-12-25
  • 打赏
  • 举报
回复
学习
jwing 2008-12-05
  • 打赏
  • 举报
回复
[Quote=引用 19 楼 zzyong00 的回复:]
引用 3 楼 laviewpbt 的回复:
纯粹顶者无分,发表赞美意见过头者无分。

呵呵,适当地赞美是有分的地


楼主的代码还不错!
[/Quote]

樓主的代碼還可以!
jhone99 2008-09-10
  • 打赏
  • 举报
回复
收藏
xvyifu 2008-09-09
  • 打赏
  • 举报
回复
代码我兴趣不大,看了楼主的回复进来顶下。
嗷嗷叫的老马 2008-09-07
  • 打赏
  • 举报
回复
我K,这么热闹.........慢慢地爬过........
用户 昵称 2008-09-07
  • 打赏
  • 举报
回复
接分+膜拜
zzyong00 2008-09-01
  • 打赏
  • 举报
回复
楼主应该总结一下这段代码的亮点,如对SafeArray的操作等..
laviewpbt 2008-08-31
  • 打赏
  • 举报
回复
准备结贴了!不过好像能符合条件得到分的家伙不多啊
ked 2008-08-31
  • 打赏
  • 举报
回复

不错! 来接分
gencan 2008-08-30
  • 打赏
  • 举报
回复
还可以,不过我喜欢delphi
ZHENNIUBILE 2008-08-29
  • 打赏
  • 举报
回复
靠,我怎麼不會用呀,只是把代碼拷上,F5嗎?

能不能向菜鳥介紹一下下使用 方法。。。

樓主,文成武德,恩沐四海!

說說使用方法,有勞了。


願樓主仙福同享,壽與天齊!!!
clyingclying 2008-08-29
  • 打赏
  • 举报
回复
[Quote=引用 28 楼 devinlin 的回复:]
引用 15 楼 liuqian4243 的回复:
引用 1 楼 happy_sea 的回复:
先接分再说!
[/Quote]
QBPro 2008-08-29
  • 打赏
  • 举报
回复
高手呀!
flymoon99 2008-08-29
  • 打赏
  • 举报
回复
纯粹顶者无分,发表赞美意见过头者无分。
非常龌龊得顶一下,稍微赞美一下,你很牛!
yayayii 2008-08-28
  • 打赏
  • 举报
回复
莫怪莫怪!!!
yayayii 2008-08-28
  • 打赏
  • 举报
回复
可以抄袭吗?我要啦!!!
dajiuzi 2008-08-28
  • 打赏
  • 举报
回复




singiles 2008-08-27
  • 打赏
  • 举报
回复
走咯!BYE !
加载更多回复(78)

809

社区成员

发帖
与我相关
我的任务
社区描述
VB 多媒体
社区管理员
  • 多媒体
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧