?? transp.bas
字號:
Attribute VB_Name = "mdlTransp"
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
?? 快捷鍵說明
復制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -