由于使用了一些新的函数，本程序必须在Windows2000下运行。
Option Explicit
Public Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject 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 Const RGN_OR = 2
Public Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Public 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
Public Const BITMAP_SIZE = 24 '=Len(BITMAP)
Dim bmByte() As Byte
Public Declare Function ReleaseCapture Lib "user32" () 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 Const HTCAPTION = 2
Public Const WM_NCLBUTTONDOWN = &HA1;
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Public Const WS_EX_LAYERED = &H80000;
Public Const GWL_EXSTYLE = (-20)
Public Const LWA_ALPHA = &H2;
Public Const LWA_COLORKEY = &H1;
Public Sub SetAutoRgn(hForm As Form, Optional transColor As Byte = vbNull)
Dim X As Long, Y As Long
Dim Rgn1 As Long, Rgn2 As Long
Dim SPos As Long, EPos As Long
Dim bm As BITMAP
Dim hbm As Long
Dim Wid As Long, Hgt As Long
Dim xoff As Long, yoff As Long
'获取窗体背景图片尺寸
hbm = hForm.Picture
GetObjectAPI hbm, Len(bm), bm
Wid = bm.bmWidth
Hgt = bm.bmHeight
With hForm
.ScaleMode = vbPixels
xoff = (.ScaleX(.Width, vbTwips, vbPixels) - .ScaleWidth) / 2
yoff = .ScaleY(.Height, vbTwips, vbPixels) - .ScaleHeight - xoff
'改变窗体尺寸
.Width = (Wid + xoff * 2) * Screen.TwipsPerPixelX
.Height = (Hgt + xoff + yoff) * Screen.TwipsPerPixelY
End With
ReDim bmByte(1 To Wid, 1 To Hgt)
GetBitmapBits hbm, Wid * Hgt, bmByte(1, 1) '获取图像数组
'如果没有传入transColor参数，则用第一个像素作为透明色
If transColor = vbNull Then transColor = bmByte(1, 1)
Rgn1 = CreateRectRgn(0, 0, 0, 0)
For Y = 1 To Hgt '逐行扫描
X = 0
Do
X = X + 1
While (bmByte(X, Y) = transColor) And (X < Wid)
X = X + 1 '跳过是透明色的点
Wend
SPos = X
While (bmByte(X, Y) <> transColor) And (X < Wid)
X = X + 1 '跳过不是透明色的点
Wend
EPos = X - 1
'这一段是合并区域
If SPos <= EPos Then
Rgn2 = CreateRectRgn(SPos - 1 + xoff, Y - 1 + yoff, EPos + xoff, Y + yoff)
CombineRgn Rgn1, Rgn1, Rgn2, RGN_OR
DeleteObject Rgn2
End If
Loop Until X >= Wid
Next Y
SetWindowRgn hForm.hwnd, Rgn1, True '设定窗体形状区域
DeleteObject Rgn1
End Sub
Option Explicit
Private Sub Form_DblClick()
Unload Me
End Sub
Private Sub Form_Load()
'Me.Show
Dim t As Single
Dim rtn As Long
rtn = GetWindowLong(hwnd, GWL_EXSTYLE)
rtn = rtn Or WS_EX_LAYERED
SetWindowLong hwnd, GWL_EXSTYLE, rtn
SetLayeredWindowAttributes hwnd, 0, 192, LWA_ALPHA '半透明
'SetLayeredWindowAttributes hwnd, &H0;, 0, LWA_COLORKEY '去除透明色
t = Timer
If Me.Picture <> 0 Then
Call SetAutoRgn(Me) ', 0)
End If
'MsgBox "运行时间：" & Timer - t & "秒", vbInformation
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
ReleaseCapture
SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End If
End Sub
266
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
