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
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)
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)
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
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
影子的意见: (主持人注:下面的方法仅适用于Windows 2000/XP或更新版本,因为SetLayeredWindowAttributes函数在其他系统中不支持。) Public Sub NTSetfrmRgn(PicBox As PictureBox, frm As Form) '------------------------------------------------- ' 窗体形状及透明度 ' Color (取得0,0处象素的颜色,即要裁减的区域的颜色 ' SetLayeredWindowAttributes 设置透明度及窗体形状 '------------------------------------------------- Dim WindowExs As Long, Color As Long frm.Picture = PicBox.Picture Color = GetPixel(PicBox.hdc, 0, 0) WindowExs = GetWindowLong(frm.hwnd, GWL_EXSTYLE) WindowExs = WindowExs Or WS_EX_LAYERED SetWindowLong frm.hwnd, GWL_EXSTYLE, WindowExs
'If blnok Then SetLayeredWindowAttributes frm.hwnd, Color, 180, LWA_COLORKEY Or LWA_ALPHA 'Else 'SetLayeredWindowAttributes frm.hWnd, Color, 112, LWA_COLORKEY Or LWA_ALPHA 'End If
End Sub
以上代码支持98 200 xp 下面的代码只能在2000以上实现VB中半透明窗体实现 在程序往往需要程序窗体美观。那我们怎么让程序界面给人一种 朦胧的感觉呢?那我们就要想到弄一个半透明的窗体。 在VB中利用API函数浏览器我们可以找到函数 setlayeredwindowsattributes 作出半窗明的窗体。 首先要通用声名区内 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long '其中hwnd是透明窗体的句柄,crKey为颜色值,bAlpha是透明度,取值范围是[0,255],dwFlags是透明方式 Private Const WS_EX_LAYERED = &H80000 Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2 Private Const LWA_COLORKEY = &H1 做到这一点之后。在formload中加入 Private Sub Form_Load() Dim rtn As Long rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA End Sub
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
影子的意见:
(主持人注:下面的方法仅适用于Windows 2000/XP或更新版本,因为SetLayeredWindowAttributes函数在其他系统中不支持。)
Public Sub NTSetfrmRgn(PicBox As PictureBox, frm As Form)
'-------------------------------------------------
' 窗体形状及透明度
' Color (取得0,0处象素的颜色,即要裁减的区域的颜色
' SetLayeredWindowAttributes 设置透明度及窗体形状
'-------------------------------------------------
Dim WindowExs As Long, Color As Long
frm.Picture = PicBox.Picture
Color = GetPixel(PicBox.hdc, 0, 0)
WindowExs = GetWindowLong(frm.hwnd, GWL_EXSTYLE)
WindowExs = WindowExs Or WS_EX_LAYERED
SetWindowLong frm.hwnd, GWL_EXSTYLE, WindowExs
'If blnok Then
SetLayeredWindowAttributes frm.hwnd, Color, 180, LWA_COLORKEY Or LWA_ALPHA
'Else
'SetLayeredWindowAttributes frm.hWnd, Color, 112, LWA_COLORKEY Or LWA_ALPHA
'End If
End Sub
下面的代码只能在2000以上实现VB中半透明窗体实现
在程序往往需要程序窗体美观。那我们怎么让程序界面给人一种
朦胧的感觉呢?那我们就要想到弄一个半透明的窗体。
在VB中利用API函数浏览器我们可以找到函数
setlayeredwindowsattributes
作出半窗明的窗体。
首先要通用声名区内
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long '其中hwnd是透明窗体的句柄,crKey为颜色值,bAlpha是透明度,取值范围是[0,255],dwFlags是透明方式
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1
做到这一点之后。在formload中加入
Private Sub Form_Load() Dim rtn As Long rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA End Sub