excel - 使无框用户窗体透明

Question

我已经做到了，我的一些用户窗体不再显示它们的标题栏。这是我必须添加的代码才能实现这一点：

Option Explicit

#If VBA7 Then
    Public Declare PtrSafe Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long


    Public Declare PtrSafe Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long


    Public Declare PtrSafe Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long

    Public Declare PtrSafe Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long

    Public Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hWnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long
#Else
    Public Declare Function FindWindow Lib "user32" _
                Alias "FindWindowA" _
               (ByVal lpClassName As String, _
                ByVal lpWindowName As String) As Long


    Public Declare Function GetWindowLong Lib "user32" _
                Alias "GetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long) As Long


    Public Declare Function SetWindowLong Lib "user32" _
                Alias "SetWindowLongA" _
               (ByVal hWnd As Long, _
                ByVal nIndex As Long, _
                ByVal dwNewLong As Long) As Long


    Public Declare Function DrawMenuBar Lib "user32" _
               (ByVal hWnd As Long) As Long

    Public Declare Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hWnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long
#End If

Sub HideBar(frm As Object)
Dim Style As Long, Menu As Long, hWndForm As Long

hWndForm = FindWindow("ThunderDFrame", frm.Caption)
Style = GetWindowLong(hWndForm, &HFFF0)
Style = Style And Not &HC00000
SetWindowLong hWndForm, &HFFF0, Style
DrawMenuBar hWndForm

End Sub

我承认我不明白它的 90% 是做什么的，但它确实有效。现在我想添加使用户窗体的背景透明的选项。有谁知道我现有的代码和我要添加的代码之间是否会有冲突？

Declare Function SetLayeredWindowAttributes Lib "user32" ( _
                ByVal hWnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long

'Constants for title bar
Private Const GWL_STYLE As Long = (-16)           'The offset of a window's style
Private Const GWL_EXSTYLE As Long = (-20)         'The offset of a window's extended style
Private Const WS_CAPTION As Long = &HC00000       'Style to add a titlebar
Private Const WS_EX_DLGMODALFRAME As Long = &H1   'Controls if the window has an icon

'Constants for transparency
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1                  'Chroma key for fading a certain color on your Form
Private Const LWA_ALPHA = &H2                     'Only needed if you want to fade the entire userform

Private Sub UserForm_Activate()
HideTitleBarAndBorder Me 'hide the titlebar and border
MakeUserFormTransparent Me 'make certain color transparent
End Sub

Sub MakeUserFormTransparent(frm As Object, Optional Color As Variant)
'set transparencies on userform
Dim formhandle As Long
Dim bytOpacity As Byte

formhandle = FindWindow(vbNullString, Me.Caption)
If IsMissing(Color) Then Color = vbWhite 'default to vbwhite
bytOpacity = 100 ' variable keeping opacity setting

SetWindowLong formhandle, GWL_EXSTYLE, GetWindowLong(formhandle, GWL_EXSTYLE) Or WS_EX_LAYERED
'The following line makes only a certain color transparent so the
' background of the form and any object whose BackColor you've set to match
' vbColor (default vbWhite) will be transparent.
    Me.BackColor = Color
    SetLayeredWindowAttributes formhandle, Color, bytOpacity, LWA_COLORKEY
End Sub

标签： excelvba

Answer 1

不，没有冲突，只需将其添加到您的 Userform_Initialize() 事件中。

bytOpacity = 192 ' variable keeping opacity setting
Call SetLayeredWindowAttributes(Obj.hwnd, 0, bytOpacity, LWA_ALPHA)

那天我非常喜欢这个，特别是如果你结合了无边界用户窗体 + 不透明度更改 + cExcel 应用程序事件 + Chip Pearson 的用户窗体定位器和更改用户窗体形状的代码。

您可以在 VBA 中制作梯形 Metro 风格用户表单：D。

将用户表单置于其他用户表单之上：

Public Const SWP_NOMOVE = &H2
Public Const SWP_NOSIZE = &H1

Public Const HWND_TOP = 0
Public Const HWND_BOTTOM = 1
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2

'Public - changed on 12/30/14
Public Declare Function 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 uFlags As Long) As Long

'Public - changed on 12/30/14
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long

窗口用户窗体黑客：

'for shape ===============
Private Type POINT_TYPE
  x As Long
  y As Long
End Type
'======point type for shape
'for the shape change ==
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hrgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function CreatePolygonRgn Lib "gdi32" (ByRef lpPoint As POINT_TYPE, ByVal nCount As Long, ByVal nPolyFillMode 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 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 crey As Byte, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long


'hide the top bar========================================
Private Declare Function DrawMenuBar Lib "user32" ( _
ByVal hwnd As Long) As Long
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'==========================================================


Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_ALPHA = &H2&

'hide the top bar
Private Const WS_CAPTION = &HC00000
Dim formhandle As Long

'for the shape ==========
Private hRegion As Long
'========================
'Remember where we started
Dim mdOriginX As Double
Dim mdOriginY As Double

Public hwnd As Long

示例：将其放入您的用户表单初始化和

Dim bytOpacity As Byte
bytOpacity = 255 ' variable keeping opacity setting
hwnd = FindWindow("ThunderDFrame", Me.Caption)
Call SetWindowLong(Me.hwnd, GWL_EXSTYLE, GetWindowLong(Me.hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED)
Call SetLayeredWindowAttributes(Me.hwnd, 0, bytOpacity, LWA_ALPHA)

Dim ptarr(0 To 28) As POINT_TYPE

'load array for MIE ;-)
'ptarr(0).X = 200: ptarr(0).Y = 100
'ptarr(1).X = 600: ptarr(1).Y = 100
'ptarr(2).X = 500: ptarr(2).Y = 250
'ptarr(3).X = 100: ptarr(3).Y = 250
'ptarr(4).X = 200: ptarr(4).Y = 100

ptarr(0).x = 104: ptarr(0).y = 30
ptarr(1).x = 504: ptarr(1).y = 30
ptarr(2).x = 404: ptarr(2).y = 180
ptarr(3).x = 4: ptarr(3).y = 180
ptarr(4).x = 104: ptarr(4).y = 30

hRegion = CreatePolygonRgn(ptarr(0), 28, 1)

hwnd = FindWindow(vbNullString, Me.Caption)
SetWindowRgn hwnd, hRegion, True

 'Code to Place userform next to activecell================
     Dim ps As Positions

     Me.StartUpPosition = 0
     ps = PositionForm(Me, ActiveCell, 0 , -243) 'FhpFormLeftCellRight, cstFvpFormCenterCellBottomcst
'     ps = positionform(me,activecell,x, y
     Me.Top = ps.FrmTop
     Me.Left = ps.FrmLeft


     'Me.Top = ActiveCell.Top
     'Me.Left = ActiveCell.Left - 10

'==========================================================
'Unload TransbackerSupport
'TransbackerSupport.Show

Call HideTitleBar(Me)