我无法使用户表单宽度小于105,高度小于29.25
我试过这个:
Sub test()
With UserForm1
.Width = 10
.Height = 10
.Show vbModeless
End With
End Sub
但它仍然比这更大:
Private Sub CommandButton1_Click()
MsgBox "Width=" & Me.Width & ", Height=" & Me.Height
Unload Me
End Sub
现在MsgBox显示:Width=102.3, Height=26.95
,当我问这个问题时,它是Width=105, Height=29.25
(我现在正在使用另一个监视器)。excel似乎不接受很小的用户表单
所以我的问题是:如何使我的用户表单非常小(例如,放入一个excel单元格)
注意:我在表单中使用了删除标题,我从这个链接中获得了删除标题:从用户窗体中删除标题
你不能让用户表单这么小,但你可以伪造它:
(1) 首先创建一个模拟Userform的Frame,使其尽可能小。(2) 然后使Userform透明&'Clic穿透式
支持这一点的代码(2),在64位(修改回到32位比反向更容易,我想现在每个人都应该有一个64位系统)
在单独的模块中:
Option Explicit
Private Declare PtrSafe Function GetWindowLong Lib "user32" _
Alias "GetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long) As LongPtr
Private Declare PtrSafe Function SetWindowLong Lib "user32" _
Alias "SetWindowLongA" _
(ByVal hWnd As LongPtr, _
ByVal nIndex As Long, _
ByVal dwNewLong As LongPtr) As LongPtr
Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" ( _
ByVal hWnd As LongPtr, _
ByVal crey As Byte, _
ByVal bAlpha As Byte, _
ByVal dwFlags As Long) As LongPtr
Private Const GWL_EXSTYLE As Long = (-20)
Private Const LWA_COLORKEY As Long = &H1
Private Const LWA_ALPHA As Long = &H2 'H2
Private Const WS_EX_LAYERED As Long = &H80000
Public Declare PtrSafe Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'
'
' *- TRANSPARENCE : SUPPR COULEUR / FORM ALPHA (auteur inconnu) -*
' =============================================================
Public Function WndSetOpacity(ByVal hWnd As LongPtr, Optional ByVal crKey As Long = vbBlack, Optional ByVal Alpha As Byte = 255, Optional ByVal ByAlpha As Boolean = True) As Boolean
' Return : True si il n'y a pas eu d'erreur.
' hWnd : hWnd de la fenêtre à rendre transparente
' crKey : Couleur à rendre transparente si ByAlpha=False (utiliser soit les constantes vb:vbWhite ou en hexa:&HFFFFFF)
' Alpha : 0-255 0=transparent 255=Opaque si ByAlpha=true (défaut)
On Error GoTo Lbl_Exit
Dim ExStyle As LongPtr
ExStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
If ExStyle <> (ExStyle Or WS_EX_LAYERED) Then
ExStyle = (ExStyle Or WS_EX_LAYERED)
Call SetWindowLong(hWnd, GWL_EXSTYLE, ExStyle)
End If
WndSetOpacity = (SetLayeredWindowAttributes(hWnd, crKey, Alpha, IIf(ByAlpha, LWA_COLORKEY Or LWA_ALPHA, LWA_COLORKEY)) <> 0)
Lbl_Exit:
On Error GoTo 0
If Not Err.Number = 0 Then Err.Clear
End Function
Public Sub UserformTransparent(ByRef uf As Object, TransparenceControls As Integer)
'uf as MSForms.UserForm won't work !!!!
Dim B As Boolean
Dim lHwnd As LongPtr
On Error GoTo 0
'- Recherche du handle de la fenêtre par son Caption
lHwnd = FindWindowA(vbNullString, uf.Caption)
If lHwnd = 0 Then
MsgBox "Handle de " & uf.Caption & " Introuvable", vbCritical
Exit Sub
End If
'If d And F Then
B = WndSetOpacity(lHwnd, uf.BackColor, TransparenceControls, True)
'ElseIf d Then
' 'B = WndSetOpacity(M.hwnd, , 255, True)
' B = WndSetOpacity(lHwnd, , TransparenceControls, True)
'Else
' B = WndSetOpacity(lHwnd, , 255, True)
'End If
End Sub
Public Sub ActiveTransparence(stCaption As String, d As Boolean, F As Boolean, Couleur As Long, Transparence As Integer)
Dim B As Boolean
Dim lHwnd As Long
'- Recherche du handle de la fenêtre par son Caption
lHwnd = FindWindowA(vbNullString, stCaption)
If lHwnd = 0 Then
MsgBox "Handle de " & stCaption & " Introuvable", vbCritical
Exit Sub
End If
If d And F Then
B = WndSetOpacity(lHwnd, Couleur, Transparence, True)
ElseIf d Then
'B = WndSetOpacity(M.hwnd, , 255, True)
B = WndSetOpacity(lHwnd, , Transparence, True)
Else
B = WndSetOpacity(lHwnd, , 255, True)
End If
End Sub
注意:如果将D
和f
设置为True
,则两个子UserFormTransparent
和ActiveTransparence
完全相同。
Couleur
必须是用户表单背景的颜色(没有图片),如果不是黑色(=0),我有时会遇到困难。
要从Userform_Initialize:UserformTransparent Me, 255
内部调用Subs,255是控件的最大不透明度,我不建议低于50(不可见)。
如果你需要假标题栏来移动表单,你不需要Api,只需添加一个标签和两个事件:_mousemove和_mouseown,两个变量X
&Y
常见的形式,瞧!