用API制作图形窗体

程序说明:

使用GetBitmapBits函数,将图片的颜色信息读到一个数组中,然后就对数组的数据进行扫描,使用CreateRectRgn函数生成每一个有用点的图窗体,再使用CombineRgn函数对有用的图象合并,组成所要的窗体,最后使用SetWindowRgn来设定窗体

程序代码:

Module1

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 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

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 WM_SYSCOMMAND = &H112

注释：Public Const SC_MOVE = &HF012

Public Const HTCAPTION = 2

Public Const WM_NCLBUTTONDOWN = &HA1

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

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, Y - 1, EPos, Y)

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

Form1

Private Sub Form_Load()

Form1.Left = Screen.Width / 2 - Form1.Width / 2

Form1.Top = Screen.Height / 2 - Form1.Height / 2

If Me.Picture <> 0 Then Call SetAutoRgn(Me)

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