一个Form1，图片框一个PicShape，在图片框内放置任何图片时，系统将使用图片框中的图片为窗体，并且屏蔽图片中白色部分，从而建立特效的变形窗体。  

Option Explicit 

Dim MoveTrue As Boolean, OldX As Long, OldY As Long 

Private 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 

Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long 
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long 
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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long 
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long 

Private Sub FitToPicture() 
Const RGN_OR = 2 

Dim border_width As Single 
Dim title_height As Single 
Dim bm As BITMAP 
Dim bytes() As Byte 
Dim ints() As Integer 
Dim longs() As Long 
Dim R As Integer 
Dim C As Integer 
Dim start_c As Integer 
Dim stop_c As Integer 
Dim x0 As Long 
Dim y0 As Long 
Dim combined_rgn As Long 
Dim new_rgn As Long 
Dim offset As Integer 
Dim colourDepth As Integer 

ScaleMode = vbPixels 

picShape.ScaleMode = vbPixels 
picShape.AutoRedraw = True 
picShape.Picture = picShape.Image 

注释： 获取窗体的边框大小 
border_width = (ScaleX(Width, vbTwips, vbPixels) - ScaleWidth) / 2 
title_height = ScaleX(Height, vbTwips, vbPixels) - border_width - ScaleHeight 

注释： 获取图片大小 
x0 = picShape.Left + border_width 
y0 = picShape.Top + title_height 

注释：给出图片信息 
GetObject picShape.Image, Len(bm), bm 
Select Case bm.bmBitsPixel 
Case 15, 16: 
注释：MsgBox _ 
"图片框中图片的颜色大高。",vbExclamation + vbOKOnly 

colourDepth = 2 

注释： 分配空格给图片. 
ReDim ints(0 To bm.bmWidthBytes \ 2 - 1, 0 To bm.bmHeight - 1) 
注释： 给出图片表面数据 
GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, ints(0, 0) 

注释： 建立表单区域 
For R = 0 To bm.bmHeight - 2 

C = 0 
Do While C < bm.bmWidth 
start_c = 0 
stop_c = 0 

注释： 查找白色区域,屏蔽 
Do While C < bm.bmWidth 
If (ints(C, R) And &H7FFF) <> &H7FFF Then Exit Do 
C = C + 1 
Loop 
start_c = C 

Do While C < bm.bmWidth 
If (ints(C, R) And &H7FFF) = &H7FFF Then Exit Do 
C = C + 1 
Loop 
stop_c = C 

If start_c < bm.bmWidth Then 
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1 

new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1) 

If combined_rgn = 0 Then 
combined_rgn = new_rgn 
Else 
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR 
DeleteObject new_rgn 
End If 
End If 
Loop 
Next R 

Case 24: 
colourDepth = 3 

ReDim bytes(0 To bm.bmWidthBytes - 1, 0 To bm.bmHeight - 1) 

GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, bytes(0, 0) 

For R = 0 To bm.bmHeight - 2 
注释： Create a region for this row. 
C = 0 
Do While C < bm.bmWidth 
start_c = 0 
stop_c = 0 

offset = C * colourDepth 

Do While C < bm.bmWidth 
If bytes(offset, R) <> 255 Or _ 
bytes(offset + 1, R) <> 255 Or _ 
bytes(offset + 2, R) <> 255 Then Exit Do 
C = C + 1 
offset = offset + colourDepth 
Loop 
start_c = C 

Do While C < bm.bmWidth 
If bytes(offset, R) = 255 And _ 
bytes(offset + 1, R) = 255 And _ 
bytes(offset + 2, R) = 255 _ 
Then Exit Do 
C = C + 1 
offset = offset + colourDepth 
Loop 
stop_c = C 

If start_c < bm.bmWidth Then 
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1 

注释： 建立区域 
new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1) 

If combined_rgn = 0 Then 
combined_rgn = new_rgn 
Else 
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR 
DeleteObject new_rgn 
End If 
End If 
Loop 
Next R 

Case 32: 
colourDepth = 4 

ReDim longs(0 To bm.bmWidthBytes \ 4 - 1, 0 To bm.bmHeight - 1) 

GetBitmapBits picShape.Image, bm.bmHeight * bm.bmWidthBytes, longs(0, 0) 


For R = 0 To bm.bmHeight - 2 

C = 0 
Do While C < bm.bmWidth 
start_c = 0 
stop_c = 0 

Do While C < bm.bmWidth 
If (longs(C, R) And &HFFFFFF) <> &HFFFFFF Then Exit Do 
C = C + 1 
Loop 
start_c = C 

Do While C < bm.bmWidth 
If (longs(C, R) And &HFFFFFF) = &HFFFFFF Then Exit Do 
C = C + 1 
Loop 
stop_c = C 

If start_c < bm.bmWidth Then 
If stop_c >= bm.bmWidth Then stop_c = bm.bmWidth - 1 

new_rgn = CreateRectRgn(start_c + x0, R + y0, stop_c + x0, R + y0 + 1) 

If combined_rgn = 0 Then 
combined_rgn = new_rgn 
Else 
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR 
DeleteObject new_rgn 
End If 
End If 
Loop 
Next R 

Case Else 
MsgBox "对不起，程序必须在 16位, 24-位 或 32-位 颜色下。", _ 
vbExclamation + vbOKOnly 

Exit Sub 
End Select 

注释： 设置表单外观为建立区域 
SetWindowRgn hWnd, combined_rgn, True 
    DeleteObject combined_rgn 
End Sub 

Private Sub picShape_Click() 

End Sub 

Private Sub Form_Load() 

Move (Screen.Width - Width) / 2, (Screen.Height - Height) / 2 

FitToPicture 

End Sub 

Private Sub picShape_DblClick() 

Unload Me 

End Sub 

Private Sub picshape_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) 
MoveTrue = True 
OldX = x: OldY = y 
End Sub 

Private Sub picshape_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) 

If MoveTrue = True Then 
Form1.Left = Form1.Left + x - OldX 
Form1.Top = Form1.Top + y - OldY 
End If 

End Sub 

Private Sub picshape_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) 

MoveTrue = False 

End Sub