现在的位置: 首页 > 窗体增强 > 正文

VBA 窗体之特殊形状窗体: 任意形状窗体

2014年06月04日 窗体增强 ⁄ 共 4326字 ⁄ 字号 暂无评论 ⁄ 阅读 2,256 次

 

主     题 VBA 窗体之特殊形状窗体:任意形状窗体
版     本 Excel2000及其以后版本
说     明 本示例主要运用API函数来定制化Excel中的用户窗体,使其显示任意形状。

 

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

 

001

 

 

制作思路:

  • 你首先需要准备一张图片,在图片上画出你需要显示的图形或文字等,然后将图片上需要透明的部分设置为同一种颜色(在示例中我用的是白色)。之后在窗体初始化时载入此图片,并将窗体的 PictureSizeMode 属性设置为 1 fmPictureSizeModeStretch。
  •  然后在窗体初始化时用 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

 

给我留言

您必须 [ 登录 ] 才能发表留言!