制作无边框用户窗体并使其透明

3

我已经让我的一些用户窗体不再显示标题栏。以下是我必须添加的代码:

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
1个回答

5

没有冲突,只需将此添加到您的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)

1
太好了,谢谢!所有这些Windows的折腾对我来说都是黑魔法... - Bread Doughlas
我会尝试将从以前的所有旧代码整合在一起...形成一个连贯的东西,你可以自由使用它。这是教程的综合体哈哈... - Peyter
1
好的,我在答案中添加了一些有趣的东西供您玩耍,包括将用户窗体制成梯形并使其出现在活动单元旁边的代码。:))) - Peyter
1
太棒了!按单元格定位是我待办清单上的下一个任务。 - Bread Doughlas
CP的定位器有一个很酷的功能,就是可以在活动单元格周围同时加载多个用户窗体。简而言之,我想在Excel中重新创建钢铁侠UI...所以需要透明、圆形的无边框用户窗体,并使用带有选项卡的插件在每个工作簿上出现应用程序事件,以更改颜色和调整功能...结果非常出色,但也很有趣,可以给人留下深刻印象XD。 - Peyter

网页内容由stack overflow 提供, 点击上面的
可以查看英文原文,
原文链接