Создание прозрачной пользовательской формы без рамки

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

Answer 1

Нет, никакого конфликта нет, просто добавьте это в ваше событие Userform_Initialize ().

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

Мне очень понравилось это в тот день, особенно если вы объединили форму без полей + изменение непрозрачности + cExcel Application Events + Chip Pearson позиционер пользовательской формы и код для изменения форм пользовательской формы.

Вы можете создавать трапециевидные пользовательские формы Metro-Style в VBA: 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

Окно Userform Hacks:

'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)