Excel VBA 窗体之特殊形状窗体 任意形状窗体 完成代码

在Excel中当我们有时需要一些特殊形状的窗体，如果是几何形状组合的窗体，那么我们可以使用定制化窗体之特殊形状窗体一：几何形状组合窗体中的方法来实现。但有时我们需要显示一个文字窗口，或者显示一幅镂空图画的窗体，或者任意形状的窗体，那又怎么做呢？

制作思路：

?你首先需要准备一张图片，在图片上画出你需要显示的图形或文字等，然后将图片上需要透明的部分设置为同一种颜色（在示例中我用的是白色）。之后在窗体初始化时载入此图片，并将窗体的PictureSizeMode属性设置为1fmPictureSizeModeStretch。

?然后在窗体初始化时用FindWindow取得窗体的句柄，再用GetWindowLong取得窗体的样式位和拓展样式位。用SetWindowLong设置窗体新的样式位和拓展样式位（无标题栏和边框）。以达到去除窗体标题栏和边框的效果。

?接下来最重要的部分就是使我们不需要的那部分窗体透明。这里我们将用到一个API函数SetLayeredWindowAttributes。我们将函数中的参数crKey设为你需要透明部分的颜色。参数bAlpha设为0~255之间的任意值（这里将忽略此参数）。参数dwFlags设为LWA_COLORKEY，以达到使窗体镂空显示的效果。

附件下载：

点击链接从百度网盘下载

操作如下：

?在Excel的VBE窗口中插入一个用户窗体，将其命名为EspecialForm。然后再添加一个模块。在窗体和模块中添加后面所列代码。

?在工作薄中的任意工作表中添加一窗体按钮控件，将指定其设置宏为ShowForm。其供示范之用

具体代码：

"mdArbitrary"模块代码

?

'---工作表按钮调用---
Sub ShowForm()
ArbitraryForm.Show 0
End Sub

"ArbitraryForm" 窗体代码

'****************************************
'---此模块创建了一个可以是任意形状的窗口---
'****************************************
Option Explicit
'以下声明API函数
#If Win64 Then '64位
'设置窗体透明度或透明样式
Private Declare PtrSafe Function SetLayeredWindowAttributes _
Lib "user32" ( _
ByVal Hwnd As LongPtr, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) _
As LongPtr
'取得窗体样式位
Private Declare PtrSafe Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongPtrA" ( _
ByVal Hwnd As LongPtr, _
ByVal nIndex As Long) _
As LongPtr
'查找窗口
Private Declare PtrSafe Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
As LongPtr
'设置窗体样式位
Private Declare PtrSafe Function SetWindowLong _
Lib "user32" _
Alias "SetWindowLongPtrA" ( _
ByVal Hwnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) _
As LongPtr
'绘制窗体标题栏
Private Declare PtrSafe Function DrawMenuBar _
Lib "user32" ( _
ByVal Hwnd As LongPtr) _
As Long
'视情况向和窗体发送消息
Private Declare PtrSafe Function SendMessage _
Lib "user32" _
Alias "SendMessageA" ( _
ByVal Hwnd As LongPtr, _
ByVal wMsg As Long, _
ByVal wParam As LongPtr, _
lParam As Any) _
As LongPtr
'释放鼠标
Private Declare PtrSafe Function ReleaseCapture _
Lib "user32" () _
As Long
#Else
'设置窗体透明度或透明样式
Private Declare Function SetLayeredWindowAttributes _
Lib "user32" ( _
ByVal hwnd As Long, _
ByVal crKey As Long, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) _
As Long
'取得窗体样式位
Private Declare Function GetWindowLong _
Lib "user32" _
Alias "GetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long) _
As Long
'查找窗口
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) _
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 DrawMenuBar _
Lib "user32" ( _
ByVal hwnd As Long) _
As Long
'视情况向窗体发送消息
Private Declare Function SendMessage _
Lib "user32" _
Alias "SendMessageA" ( _
ByVal hwnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Any) _
As Long
'释放鼠标控制
Private Declare Function ReleaseCapture _
Lib "user32" () _
As Long
#End If
#If Win64 Then '64位
Private hWndForm As LongPtr
Private FIstype As LongPtr
#Else
Private hWndForm As Long
Private FIstype As Long
#End If
'以下定义常数和变量
Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE = (-20) '拓展窗口样式
Private Const LWA_COLORKEY = &H1
Private Const GWL_STYLE = (-16) '窗口样式
Private Const WS_CAPTION = &HC00000
Private Const WS_EX_DLGMODALFRAME = &H1&
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE_MOUSE = &HF012&
'---窗体双击---
Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
Unload Me
End Sub
'---窗体初始化---
Private Sub UserForm_Initialize()
On Error Resume Next
'设置窗体背景图片, 这里为了方便我使用的是工作表中图片控件储存的图片，可以用下面第三行的语句载入自己准备好的图片
Me.Picture = ThisWorkbook.Worksheets("源图").Image1.Picture
'设置窗体背景图片时也可以用以下语句载入图片
'Me.Picture = LoadPicture(ThisWorkbook.Path & "\创作.bmp")
If Err <> 0 Then
MsgBox "窗体背景图片未找到，请将压缩包内图片和此文档放置在同一目录下", vbCritical, "错误"
End
End If
'设置窗体尺寸模式
Me.PictureSizeMode = fmPictureSizeModeStretch
'查找窗体句柄
hWndForm = FindWindow("ThunderDFrame", Me.Caption)
'取得窗体样式
FIstype = GetWindowLong(hWndForm, GWL_STYLE)
'窗体样式：原样式无标题
FIstype = FIstype And Not WS_CAPTION
'重设窗体样式
SetWindowLong hWndForm, GWL_STYLE, FIstype
'取得窗体拓展样式
FIstype = GetWindowLong(hWndForm, GWL_EXSTYLE)
'窗体拓展样式：无边框，分层
FIstype = FIstype And Not WS_EX_DLGMODALFRAME Or WS_EX_LAYERED
'重设窗体拓展样式位
SetWindowLong hWndForm, GWL_EXSTYLE, FIstype
'重绘窗体标题栏
DrawMenuBar hWndForm
'设置窗体背景白色部分为透明，这里的RGB色设成你希望透明的颜色
SetLayeredWindowAttributes hWndForm, RGB(255, 255, 255), 255, LWA_COLORKEY
End Sub
'---鼠标按下---
Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
'释放控制
ReleaseCapture
'向窗体发送消息
SendMessage hWndForm, WM_SYSCOMMAND, SC_MOVE_MOUSE, 0
End Sub