主题:异型窗体通用函数
大家都知道,异型窗体的就是在窗体上贴一张图片,然后挖掉其中不需要的点。。。
现在写了一个通用函数,可是发现一小部分空白点没办法去掉,而一小部分要保留的点却被去除了。问题估计出现在最后的循环部分,不过纠结了一个晚上就是看不出有取错点的。
大家现出火眼金睛,帮我找找
下面是代码(都在一个窗体里),我也上传了测试工程
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
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 SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private 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
Private Const RGN_OR = 2
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const GWL_STYLE = (-16)
Private Sub Command1_Click()
End
End Sub
Private Sub Form_Load()
FormRGN Me, App.Path & "\MAIN.BMP"
'FormRGN Me, App.Path & "\Winter.JPG"
End Sub
Private Function FormRGN(f As Form, strPicPath As String) As Long
Dim picBox As PictureBox
Dim transparentColor As Long
Dim oldStyle As Long, ret As Long
Dim rgnTotal As Long, rgnTemp As Long
Dim firstRgn As Boolean, isPreDotTran As Boolean
Dim startX As Long, startY As Long, endX As Long, endY As Long
Dim length As Long, width As Long
Dim y As Long, x As Long
Dim bmp As BITMAP
f.BorderStyle = vbBSNone
Set picBox = f.Controls.Add("VB.PictureBox", "p")
picBox.width = f.width
picBox.Height = Height
picBox.Left = 0
picBox.Top = 0
picBox.Visible = True
picBox.AutoRedraw = True
picBox.ScaleMode = vbPixels
picBox.BorderStyle = vbBSNone
'移除窗体标题栏
oldStyle = GetWindowLong(f.hWnd, GWL_STYLE)
If oldStyle = 0 Then
FormRGN = 0
Exit Function
End If
SetWindowLong f.hWnd, GWL_STYLE, oldStyle And Not WS_SYSMENU And Not WS_CAPTION And Not WS_MAXIMIZE And Not WS_MINIMIZE
SetWindowPos f.hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE Or SWP_FRAMECHANGED
'对图片路径做处理
strPicPath = Replace(strPicPath, "\\", "\")
Set picBox.Picture = LoadPicture(strPicPath)
'获取图片实除宽高,并以此设置窗体
ret = GetObject(picBox.Picture.Handle, Len(bmp), bmp)
SetWindowPos f.hWnd, 0, 0, 0, bmp.bmWidth, bmp.bmHeight, SWP_NOZORDER Or SWP_NOMOVE Or SWP_FRAMECHANGED
SetWindowPos picBox.hWnd, 0, 0, 0, bmp.bmWidth, bmp.bmHeight, SWP_NOZORDER Or SWP_NOMOVE Or SWP_FRAMECHANGED
rgnTotal = CreateRectRgn(0, 0, 0, 0) '对总的区域句柄做个初始化
transparentColor = GetPixel(picBox.hdc, 0, 0) '取得透明点的值
isPreDotTran = True '标记前面的点是否透明
firstRgn = True '是否是第一块区域
'开始获取区域句柄并进行区域合并
For y = 0 To picBox.ScaleHeight - 1
For x = 0 To picBox.ScaleWidth - 1
If GetPixel(picBox.hdc, x, y) = transparentColor Or x = picBox.ScaleWidth - 1 Then '如果到达透明点 或 点扫描到达行末
If Not isPreDotTran Then
isPreDotTran = True
endX = x: endY = y + 1
rgnTemp = CreateRectRgn(startX, startY, endX, endY)
CombineRgn rgnTotal, rgnTotal, rgnTemp, RGN_OR
DeleteObject rgnTemp
End If
Else
If isPreDotTran Then
isPreDotTran = False
startX = x: startY = y
If startX = picBox.ScaleWidth - 1 Then '如是已经到行末
endX = startX + 1
endY = startY + 1
isPreDotTran = True
rgnTemp = CreateRectRgn(startX, startY, endX, endY)
CombineRgn rgnTotal, rgnTotal, rgnTemp, RGN_OR
DeleteObject rgnTemp
End If
End If
End If
Next
Next
SetWindowRgn f.hWnd, rgnTotal, True
DeleteObject rgnTotal
Set picBox = Nothing
End Function
现在写了一个通用函数,可是发现一小部分空白点没办法去掉,而一小部分要保留的点却被去除了。问题估计出现在最后的循环部分,不过纠结了一个晚上就是看不出有取错点的。
大家现出火眼金睛,帮我找找
下面是代码(都在一个窗体里),我也上传了测试工程
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long
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 SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private 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
Private Const RGN_OR = 2
Private Const WS_CAPTION = &HC00000 ' WS_BORDER Or WS_DLGFRAME
Private Const WS_SYSMENU = &H80000
Private Const WS_MINIMIZE = &H20000000
Private Const WS_MAXIMIZE = &H1000000
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_FRAMECHANGED = &H20 ' The frame changed: send WM_NCCALCSIZE
Private Const GWL_STYLE = (-16)
Private Sub Command1_Click()
End
End Sub
Private Sub Form_Load()
FormRGN Me, App.Path & "\MAIN.BMP"
'FormRGN Me, App.Path & "\Winter.JPG"
End Sub
Private Function FormRGN(f As Form, strPicPath As String) As Long
Dim picBox As PictureBox
Dim transparentColor As Long
Dim oldStyle As Long, ret As Long
Dim rgnTotal As Long, rgnTemp As Long
Dim firstRgn As Boolean, isPreDotTran As Boolean
Dim startX As Long, startY As Long, endX As Long, endY As Long
Dim length As Long, width As Long
Dim y As Long, x As Long
Dim bmp As BITMAP
f.BorderStyle = vbBSNone
Set picBox = f.Controls.Add("VB.PictureBox", "p")
picBox.width = f.width
picBox.Height = Height
picBox.Left = 0
picBox.Top = 0
picBox.Visible = True
picBox.AutoRedraw = True
picBox.ScaleMode = vbPixels
picBox.BorderStyle = vbBSNone
'移除窗体标题栏
oldStyle = GetWindowLong(f.hWnd, GWL_STYLE)
If oldStyle = 0 Then
FormRGN = 0
Exit Function
End If
SetWindowLong f.hWnd, GWL_STYLE, oldStyle And Not WS_SYSMENU And Not WS_CAPTION And Not WS_MAXIMIZE And Not WS_MINIMIZE
SetWindowPos f.hWnd, 0, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOZORDER Or SWP_NOSIZE Or SWP_FRAMECHANGED
'对图片路径做处理
strPicPath = Replace(strPicPath, "\\", "\")
Set picBox.Picture = LoadPicture(strPicPath)
'获取图片实除宽高,并以此设置窗体
ret = GetObject(picBox.Picture.Handle, Len(bmp), bmp)
SetWindowPos f.hWnd, 0, 0, 0, bmp.bmWidth, bmp.bmHeight, SWP_NOZORDER Or SWP_NOMOVE Or SWP_FRAMECHANGED
SetWindowPos picBox.hWnd, 0, 0, 0, bmp.bmWidth, bmp.bmHeight, SWP_NOZORDER Or SWP_NOMOVE Or SWP_FRAMECHANGED
rgnTotal = CreateRectRgn(0, 0, 0, 0) '对总的区域句柄做个初始化
transparentColor = GetPixel(picBox.hdc, 0, 0) '取得透明点的值
isPreDotTran = True '标记前面的点是否透明
firstRgn = True '是否是第一块区域
'开始获取区域句柄并进行区域合并
For y = 0 To picBox.ScaleHeight - 1
For x = 0 To picBox.ScaleWidth - 1
If GetPixel(picBox.hdc, x, y) = transparentColor Or x = picBox.ScaleWidth - 1 Then '如果到达透明点 或 点扫描到达行末
If Not isPreDotTran Then
isPreDotTran = True
endX = x: endY = y + 1
rgnTemp = CreateRectRgn(startX, startY, endX, endY)
CombineRgn rgnTotal, rgnTotal, rgnTemp, RGN_OR
DeleteObject rgnTemp
End If
Else
If isPreDotTran Then
isPreDotTran = False
startX = x: startY = y
If startX = picBox.ScaleWidth - 1 Then '如是已经到行末
endX = startX + 1
endY = startY + 1
isPreDotTran = True
rgnTemp = CreateRectRgn(startX, startY, endX, endY)
CombineRgn rgnTotal, rgnTotal, rgnTemp, RGN_OR
DeleteObject rgnTemp
End If
End If
End If
Next
Next
SetWindowRgn f.hWnd, rgnTotal, True
DeleteObject rgnTotal
Set picBox = Nothing
End Function