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
延伸閱讀
文章來源于領測軟件測試網 http://www.kjueaiud.com/
