Excel VBA 特殊形状窗体代码详解及CreateEllipticRgn及CombineRgn图解，搭配API函数说明查看

CDamogu

已于 2022-02-14 11:06:53 修改

阅读量941

点赞数 1

文章标签： vba

于 2022-01-05 23:40:09 首次发布

本文链接：https://blog.csdn.net/qq_33704787/article/details/122326141

版权

Excel VBA 特殊形状窗体代码

'->Forms
'  Module
'  ClassModules
Option Explicit

Const HWND_TOPMOST = -1
Const HWND_NOTOPMOST = -2
Const SWP_NOSIZE = &H1
Const SWP_NOMOVE = &H2
Const SWP_NOACTIVATE = &H10
Const SWP_SHOWWINDOW = &H40
Private Declare Sub SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)

#If Win64 Then
    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 CreateEllipticRgn _
    Lib "gdi32" ( _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long) _
    As LongPtr
    
    Private Declare PtrSafe Function CombineRgn _
    Lib "gdi32" ( _
    ByVal hDestRgn As LongPtr, _
    ByVal hSrcRgn1 As LongPtr, _
    ByVal hSrcRgn2 As LongPtr, _
    ByVal nCombineMode As Long) _
    As Long
    
    Private Declare PtrSafe Function SetWindowRgn _
    Lib "user32" ( _
    ByVal hwnd As LongPtr, _
    ByVal hRgn As LongPtr, _
    ByVal bRedraw As Long) _
    As Long
    
    Private Declare PtrSafe Function FindWindow _
    Lib "user32" _
    Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
    As LongPtr
    
    Private Declare PtrSafe Function ReleaseCapture _
    Lib "user32" () _
    As Long
#Else

    Private Declare Function SendMessage _
    Lib "user32" _
    Alias "SendMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) _
    As Long
    
    Private Declare Function CreateEllipticRgn _
    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 FindWindow _
    Lib "user32" _
    Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) _
    As Long
    
    Private Declare Function ReleaseCapture _
    Lib "user32" () _
    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 CreateRoundRectRgn _
    Lib "gdi32" ( _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As Long, _
    ByVal X3 As Long, _
    ByVal Y3 As Long) _
    As Long
    
    Private Declare Function DeleteObject _
    Lib "gdi32" ( _
    ByVal hObject As Long) _
    As Long
#End If
                                    
Private Const WM_SYSCOMMAND = &H112
Private Const SC_MOVE_MOUSE = &HF012&
'CombineMode
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
'Return Val
Private Const ERROR = 0
Private Const NULLREGION = 1
Private Const SIMPLEREGION = 2
Private Const COMPLEXREGION = 3


#If Win64 Then
    Dim hDRgn As LongPtr
    Dim FHwnd As LongPtr
    Dim FRgn1 As LongPtr
    Dim FRgn2 As LongPtr
    Dim FRgn3 As LongPtr
    Dim FRgn4 As LongPtr
#Else
    Dim hDRgn As Long
    Dim FHwnd As Long
    Dim FRgn1 As Long
    Dim FRgn2 As Long
    Dim FRgn3 As Long
    Dim FRgn4 As Long
#End If



Private Sub UserForm_Initialize()
    FRgn1 = CreateEllipticRgn(10, 40, 200, 230)
    'FRgn2 = CreateEllipticRgn(40, 70, 170, 200)
    FRgn2 = CreateEllipticRgn(100, 140, 220, 260)
    FRgn3 = CreateRectRgn(10, 40, 200, 230)
    FRgn4 = CreateRoundRectRgn(30, 30, 200, 230, 100, 100)
    CombineRgn FRgn1, FRgn1, FRgn2, RGN_XOR
    FHwnd = FindWindow(vbNullString, Me.Caption)
    SetWindowRgn FHwnd, FRgn1, 1
    SetWindowPos FHwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE
End Sub


Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
    ReleaseCapture
    SendMessage FHwnd, WM_SYSCOMMAND, SC_MOVE_MOUSE, 0
End Sub

Private Sub UserForm_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    Unload Me
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
        If FRgn1 <> 0 Then DeleteObject FRgn1
        If FRgn2 <> 0 Then DeleteObject FRgn2
        If FRgn3 <> 0 Then DeleteObject FRgn3
        If FRgn4 <> 0 Then DeleteObject FRgn4
End Sub