transp.bas

来自「一个不错的电子相册建立程序工具」· BAS 代码 · 共 71 行

Attribute VB_Name = "mdlTransp"
'****************************************************************************
'人人为我，我为人人
'枕善居汉
'发布日期：05/06/13
'描  述：一个很酷的登录对话框---之透明窗口函数
'网  站：http://www.mndsoft.com/
'e-mail：[e-mail]
'OICQ  : 88382850
'****************************************************************************
Option Explicit
'窗体透明模块

Public Declare Sub ReleaseCapture Lib "user32" ()
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal x1 As Long, ByVal y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long



Public Sub DoTransparency(bg As Form, transColor)
Dim rgn     As Long
Dim rgn2    As Long
Dim rgn3    As Long
Dim rgn4    As Long
Dim x1      As Long
Dim y1      As Long
Dim i       As Long
Dim j       As Long
Dim tj      As Long

rgn = CreateRectRgn(0, 0, 0, 0)
rgn2 = CreateRectRgn(0, 0, 0, 0)
rgn3 = CreateRectRgn(0, 0, 0, 0)
i = 1
x1 = bg.Width / Screen.TwipsPerPixelX
y1 = bg.Height / Screen.TwipsPerPixelY
Do While i < x1
    j = 1
    Do While j < y1
        If GetPixel(bg.hdc, i, j) <> transColor Then
            tj = j
            Do While GetPixel(bg.hdc, i, j + 1) <> transColor
                j = j + 1
                If j = y1 Then Exit Do
            Loop
            rgn4 = CreateRectRgn(i, tj, i + 1, j + 1)
        
            CombineRgn rgn3, rgn2, rgn2, 5
            CombineRgn rgn2, rgn4, rgn3, 2
        
            DeleteObject rgn4
        End If
    j = j + 1
    Loop
    CombineRgn rgn3, rgn, rgn, 5
    CombineRgn rgn, rgn2, rgn3, 2
    i = i + 1
Loop
SetWindowRgn bg.hwnd, rgn, True
'清除
DeleteObject rgn
DeleteObject rgn2
DeleteObject rgn3

End Sub