月度归档： 2024 年 8 月

‘如下两个窗体均为透明，即，可以看到其后的屏幕。

Option Explicit

‘Example
‘Call Translucent(Me.hwnd)’设置当前窗体半透明
‘Translucent oAutoCAD.hwnd’设置已绑定的 AutoCAD 半透明

Private Declare Function GetWindowLong Lib “user32.dll” 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 CrKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long

Private Const WS_EX_LAYERED = &H80000
Private Const GWL_EXSTYLE As Long = -20
Private Const LWA_ALPHA = &H2
Private Const LWA_COLORKEY = &H1

‘hWnd是透明窗体的句柄
‘crKey为掩码的颜色,可以用RGB(r,g,b)来指定
‘bAlpha是不透明度,取值范围是（0,255）,其中0代表全透明,255代表不透明
‘dwFlags是透明方式,三种取值方式:
‘LWA_ALPHA时,crKey参数无效,bAlpha参数有效
‘LWA_COLORKEY时,颜色为crKey的地方变为透明,bAlpha参数无效
‘LWA_ALPHA Or LWA_COLORKEY时,crKey的地方将变为全透明,其它地方根据bAlpha参数确定透明度
Public Sub Translucent(ByVal hwnd As Long)
On Error Resume Next
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 255), 128, LWA_ALPHA
On Error GoTo 0
End Sub

Public Sub NoTranslucent(ByVal hwnd As Long)
On Error Resume Next
SetWindowLong hwnd, GWL_EXSTYLE, GetWindowLong(hwnd, GWL_EXSTYLE) Or WS_EX_LAYERED
SetLayeredWindowAttributes hwnd, RGB(255, 255, 255), 255, LWA_ALPHA
On Error GoTo 0
End Sub

Option Explicit
Private Declare Function GetMenu Lib “user32” (ByVal hwnd As Long) As Long
Private Declare Function GetSubMenu Lib “user32” (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function GetMenuItemID Lib “user32” (ByVal hMenu As Long, ByVal nPos As Long) As Long
Private Declare Function ModifyMenu Lib “user32” Alias “ModifyMenuA” (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal wIDNewItem As Long, ByVal lpString As String) As Long
Private Declare Function SetMenuItemBitmaps Lib “user32” (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long
Private Declare Function GetMenuCheckMarkDimensions Lib “user32” () As Long

‘Example:
‘为当前窗体的第 2 组菜单的第 2 项菜单设置 imgMenu(0) 中的图片
‘Call SetMenuPicture(Me, 2, 3, imgMenu(0))

Public Sub SetMenuPicture(ByVal oForm As Form, ByVal iMenu As Integer, ByVal iSubMenu As Integer, ByVal oImage As Image)
On Error Resume Next
Dim lMenu As Long, lSubMenu As Long, lMenuID As Long
lMenu = GetMenu(oForm.hwnd)
lSubMenu = GetSubMenu(lMenu, iMenu)
lMenuID = GetMenuItemID(lSubMenu, iSubMenu)
lRet = SetMenuItemBitmaps(lMenu, lMenuID, 0, oImage.Picture, 0&)
On Error GoTo 0
End Sub