[推荐]为VBA窗体添加最大化,最小化,图标
本帖最后由 作者 于 2008-11-3 20:40:07 编辑'/ /'
'///////////////////////////////////////'
'
'Written: Jan. 30, 2007
'Author: Leith Ross
'Returns an Icon from a File (.ico)
Private Declare Function LoadImage _
Lib "user32.dll" _
Alias "LoadImageA" _
(ByVal hInst As Long, _
ByVal lpsz As String, _
ByVal uType As Long, _
ByVal cxDesired As Long, _
ByVal cyDesired As Long, _
ByVal fuLoad As Long) As Long
'Direct System what to do with the Window
Private Declare Function SendMessage _
Lib "user32.dll" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
lParam As Long) As Long
'Constants for SendMessage
Const WM_GETICON As Long = &H7F
Const WM_SETICON As Long = &H80
Const ICON_SMALL As Long = &H0
Const ICON_BIG As Long = &H1
'Constants for Load Image's fuLoad Parameter (Load Resource)
Const LR_DEFAULTCOLOR As Long = &H0
Const LR_MONOCHROME As Long = &H1
Const LR_COLOR As Long = &H2
Const LR_COPYRETURNORG As Long = &H4
Const LR_COPYDELETEORG As Long = &H8
Const LR_LOADFROMFILE As Long = &H10
Const LR_LOADTRANSPARENT As Long = &H20
Const LR_DEFAULTSIZE As Long = &H40
Const LR_VGACOLOR As Long = &H80
Const LR_LOADMAP3DCOLORS As Long = &H1000
Const LR_CREATEDIBSECTION As Long = &H2000
Const LR_COPYFROMRESOURCE As Long = &H4000
Const LR_SHARED As Long = &H8000
'Constants for Load Image's uType Parameter
Const IMAGE_BITMAP As Long = &H0
Const IMAGE_ICON As Long = &H1
Const IMAGE_CURSOR As Long = &H2
'Constants for ShowWindow (nCmdShow)
Const SW_HIDDEN As Long = 0
Const SW_NORMAL As Long = 1
Const SW_MINIMIZED As Long = 2
Const SW_MAXIMIZED As Long = 3
Const SW_NOTACTIVE As Long = 4
Const SW_UNHIDDEN As Long = 5
Const SW_MINWITHFOCUS As Long = 6
Const SW_MINNOTACTIVE As Long = 7
Const SW_RESTORE As Long = 9
'Constants for GetWindow
Const GW_HWNDFIRST As Long = &H0
Const GW_HWNDLAST As Long = &H1
Const GW_HWNDNEXT As Long = &H2
Const GW_HWNDPREV As Long = &H3
Const GW_OWNER As Long = &H4
Const GW_CHILD As Long = &H5
'Window Style constants
Const WS_DISABLE As Long = 0
Const WS_MAXIMIZEBOX As Long = &H10000
Const WS_MINIMIZEBOX As Long = &H20000
Const WS_THICKFRAME As Long = &H40000 'Style to add a sizable frame
Const WS_SYSMENU As Long = &H80000
Const WS_ENABLE As Long = &HFFFFFFFF
'Get Window Long constants
Const GWL_HINSTANCE As Long = (-6)
Const GWL_HWNDPARENT As Long = (-8)
Const GWL_ID As Long = (-12)
Const GWL_STYLE As Long = (-16)
Const GWL_EXSTYLE As Long = (-20)
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.dll" _
Alias "SetWindowLongA" _
(ByVal hWnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
'Function to Change how Window is Displayed
Private Declare Function ShowWindow _
Lib "user32.dll" _
(ByVal hWnd As Long, _
ByVal nCmdShow As Long) As Long
'Returns the Window Handle of the Active Window
Private Declare Function GetActiveWindow _
Lib "user32.dll" () As Long
'Redraw the Icons on the Window's Title Bar
Private Declare Function DrawMenuBar _
Lib "user32.dll" _
(ByVal hWnd As Long) As Long
Public Sub MinimizeWindow(Optional ByVal Window_Handle As Long, Optional ByVal With_Focus As Boolean)
Dim RetVal
If With_Focus = True Then
RetVal = ShowWindow(Window_Handle, SW_MINWITHFOCUS)
Else
RetVal = ShowWindow(Window_Handle, SW_MINNOTACTIVE)
End If
End Sub
Public Sub RestoreWindow(Optional ByVal Window_Handle As Long)
Dim RetVal
RetVal = ShowWindow(Window_Handle, SW_NORMAL)
End Sub
Public Sub AddMinBox(Optional Window_Handle As Long)
Dim hWnd As Long
Dim BitMask As Long
Dim WindowStyle As Long
If Window_Handle = 0 Then
hWnd = GetActiveWindow()
Else
hWnd = Window_Handle
End If
WindowStyle = GetWindowLong(hWnd, GWL_STYLE)
BitMask = WindowStyle Or WS_MINIMIZEBOX
Call SetWindowLong(hWnd, GWL_STYLE, BitMask)
Call DrawMenuBar(hWnd)
End Sub
Public Sub AddMaxBox(Optional Window_Handle As Long)
Dim hWnd As Long
Dim BitMask As Long
Dim WindowStyle As Long
If Window_Handle = 0 Then
hWnd = GetActiveWindow()
Else
hWnd = Window_Handle
End If
WindowStyle = GetWindowLong(hWnd, GWL_STYLE)
BitMask = WindowStyle Or WS_MAXIMIZEBOX
Call SetWindowLong(hWnd, GWL_STYLE, BitMask)
Call DrawMenuBar(hWnd)
End Sub
Public Function ChangeIcon(ByVal Icon_File_Path As String, Optional ByVal Window_Handle As Long)
Dim hWnd As Long
Dim hIcon As Long
Dim LoadMask As Long
If Window_Handle = 0 Then
hWnd = GetActiveWindow()
Else
hWnd = Window_Handle
End If
LoadMask = LR_LOADFROMFILE Or LR_DEFAULTSIZE Or LR_SHARED
hIcon = LoadImage(0&, Icon_File_Path, IMAGE_ICON, 32, 32, LoadMask)
Call SendMessage(hWnd, WM_SETICON, ICON_BIG, ByVal hIcon)
Call DrawMenuBar(hWnd)
End Function
Private Sub UserForm_Activate()
AddMinBox
AddMaxBox
ChangeIcon "C:\ndpsetup.ico" '图标路径
End Sub
没想到还比较麻烦. 不错!!!!!!!!!! 用了API技术 很好，谢谢分享！ 程序很好，支持了！！！ 不能运行啊，运行后没反应
页:
[1]