回 帖 发 新 帖 刷新版面

主题:异型窗体通用函数

大家都知道,异型窗体的就是在窗体上贴一张图片,然后挖掉其中不需要的点。。。

现在写了一个通用函数,可是发现一小部分空白点没办法去掉,而一小部分要保留的点却被去除了。问题估计出现在最后的循环部分,不过纠结了一个晚上就是看不出有取错点的。

大家现出火眼金睛,帮我找找

下面是代码(都在一个窗体里),我也上传了测试工程
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

回复列表 (共13个回复)

11 楼

有一个问题:
    程序启动后,“金鱼”出来,在“金鱼”游动的过程中在“金鱼”身上用鼠标点击拖动,会发现游动停止,而且“鱼头”会跟着鼠标走,然后就动不了了。这是FLASH的问题,还是程序的问题?

我试了一下,在FLASH文件中,的确有拖动这个功能,但是不会出现拖动后就动不了。动不了是不是就是shockwave控件的问题?[em18]

12 楼

因为窗体不见了,拖动后点击不到窗体所以不动了,再点它一下就好了,这些是小问题,这里只是演示代码,如果你想要把它做完美,还需要检测鼠标,或者检测焦点,或者干脆设置 Me.Enabled = False 等等。

13 楼

你有兴趣的话,可以试试看能不能把金鱼的边界柔化!!

我来回复

您尚未登录,请登录后再回复。点此登录或注册