Windows Routine
Windows Module
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function GetWindowLong _
Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLong _
Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe Function DrawMenuBar _
Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function FindWindowA _
Lib "user32" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function DeleteMenu _
Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetSystemMenu _
Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare PtrSafe Function GetParent _
Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
Public Declare PtrSafe Function GetSystemMetrics _
Lib "user32" (ByVal Index As Long) As Long
Private Declare PtrSafe Function GetDC _
Lib "user32" (ByVal hWnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC _
Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps _
Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Private Declare PtrSafe Function GetWindowRect _
Lib "user32" (ByVal hWnd As Long, ByRef lpRect As udtRECT) As Long
' Private Declare PtrSafe Function SetWindowLong _
' Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare PtrSafe 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 wFlags As Long) As Long
Private Declare PtrSafe Function ExtractIcon32 _
Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, _
ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare PtrSafe Function GetActiveWindow32 _
Lib "user32" Alias "GetActiveWindow" () As Long
Private Declare PtrSafe Function SendMessage32 _
Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare PtrSafe Function InitCommonControlsEx _
Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Public Declare PtrSafe Sub InitCommonControls Lib "comctl32.dll" ()
Public Declare PtrSafe Function capCreateCaptureWindow _
Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _
(ByVal lpszWindowName As String, ByVal dwStyle As Long _
, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long _
, ByVal nHeight As Long, ByVal hwndParent As LongPtr _
, ByVal nID As Long) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
, ByVal wParam As Long, ByRef lParam As Any) As Long
#Else
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 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 Declare Function DeleteMenu _
Lib "user32" (ByVal hMenu As Long, _
ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Declare Function GetSystemMenu _
Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetParent _
Lib "user32.dll" (ByVal hWnd As Long) As Long
Public Declare Function GetSystemMetrics _
Lib "user32" (ByVal Index As Long) As Long
Private Declare Function GetDC _
Lib "user32" (ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC _
Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetDeviceCaps _
Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Private Declare Function GetWindowRect _
Lib "user32" (ByVal hWnd As Long, ByRef lpRect As udtRECT) 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 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 wFlags As Long) As Long
Private Declare Function ExtractIcon32 _
Lib "shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, _
ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long
Private Declare Function GetActiveWindow32 _
Lib "user32" Alias "GetActiveWindow" () As Long
Private Declare Function SendMessage32 _
Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function InitCommonControlsEx _
Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
Public Declare Function capCreateCaptureWindow _
Lib "avicap32.dll" Alias "capCreateCaptureWindowA" _
(ByVal lpszWindowName As String, ByVal dwStyle As Long _
, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long _
, ByVal nHeight As Long, ByVal hwndParent As LongPtr _
, ByVal nID As Long) As Long
Public Declare Function SendMessage Lib "user32" _
Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long _
, ByVal wParam As Long, ByRef lParam As Any) As Long
#End If
Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Constants
Private Const SWP_NOMOVE = &H2
Private Const SWP_NOSIZE = &H1
Private Const GWL_EXSTYLE = (-20)
Private Const HWND_TOP = 0
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_HIDEWINDOW = &H80
Private Const SWP_SHOWWINDOW = &H40
Private Const WS_EX_APPWINDOW = &H40000
Private Const WS_MINIMIZEBOX = &H20000
Private Const SWP_FRAMECHANGED = &H20
Private Const WM_SETICON = &H80
Private Const ICON_SMALL = 0&
Private Const ICON_BIG = 1&
Private Const GWL_STYLE = -16
Private Const WS_CAPTION = &HC00000
Private Const WS_SYSMENU = &H80000
Private Const SC_CLOSE = &HF060
Const WS_CHILD As Long = &H40000000
Const WS_VISIBLE As Long = &H10000000
Const WM_USER As Long = &H400
Const WM_CAP_START As Long = WM_USER
Const WM_CAP_DRIVER_CONNECT As Long = WM_CAP_START + 10
Const WM_CAP_DRIVER_DISCONNECT As Long = WM_CAP_START + 11
Const WM_CAP_SET_PREVIEW As Long = WM_CAP_START + 50
Const WM_CAP_SET_PREVIEWRATE As Long = WM_CAP_START + 52
Const WM_CAP_DLG_VIDEOFORMAT As Long = WM_CAP_START + 41
Const WM_CAP_FILE_SAVEDIB As Long = WM_CAP_START + 25
Private Type tagInitCommonControlsEx
lngSize As Long
lngICC As Long
End Type
'Public Declare Sub InitCommonControls Lib "comctl32.dll" ()
'Private Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean
Private Const ICC_USEREX_CLASSES = &H200
Dim hCap As LongPtr
#If Win64 Then
Public Function GetUserformHwnd( _
ByRef ufmTarget As MSForms.UserForm) As LongPtr
Dim lngHwndControl As LongPtr
#Else
Public Function GetUserformHwnd( _
ByRef ufmTarget As MSForms.UserForm) As Long
Dim lngHwndControl As Long
#End If
Dim objControl As MSForms.Control
Dim strRandomName As String
Randomize
strRandomName = CStr(Rnd)
Set objControl = ufmTarget.Controls.Add( _
"Forms.Frame.1", strRandomName, False)
objControl.Left = ufmTarget.ScrollLeft + ufmTarget.InsideWidth
objControl.Visible = True
lngHwndControl = objControl.[_GethWnd]
GetUserformHwnd = GetParent(GetParent(lngHwndControl))
ufmTarget.Controls.Remove strRandomName
End Function
Public Function RenderXP()
On Error Resume Next
Dim iccex As tagInitCommonControlsEx
With iccex
.lngSize = LenB(iccex)
.lngICC = ICC_USEREX_CLASSES
End With
InitCommonControlsEx iccex
On Error GoTo 0
End Function
Public Sub SystemButtonSettings(frm As Object, show As Boolean)
Dim windowStyle As Long
Dim windowHandle As Long
windowHandle = FindWindowA(vbNullString, frm.Caption)
windowStyle = GetWindowLong(windowHandle, GWL_STYLE)
If show = False Then
SetWindowLong windowHandle, GWL_STYLE, (windowStyle And Not WS_SYSMENU)
Else
SetWindowLong windowHandle, GWL_STYLE, (windowStyle + WS_SYSMENU)
End If
DrawMenuBar (windowHandle)
End Sub
Public Sub CloseButtonSettings(frm As Object, show As Boolean)
Dim windowHandle As Long
Dim menuHandle As Long
windowHandle = FindWindowA(vbNullString, frm.Caption)
If show = True Then
menuHandle = GetSystemMenu(windowHandle, 1)
Else
menuHandle = GetSystemMenu(windowHandle, 0)
DeleteMenu menuHandle, SC_CLOSE, 0&
End If
End Sub
Sub HideTitleBar(frm As Object)
#If VBA7 Then
Dim lFrmHdl As LongPtr
#Else
Dim lFrmHdl As Long
#End If
Dim lngWindow As Long
lFrmHdl = GetWndHandle(frm)
'lFrmHdl = FindWindowA(vbNullString, frm.Caption)
lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE)
lngWindow = lngWindow And (Not WS_CAPTION)
Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow)
Call DrawMenuBar(lFrmHdl)
End Sub
Function LoadImage(Target As image, file As String)
Target.Picture = LoadPicture(file)
End Function
Function GetWndHandle(ByRef frm As UserForm)
#If VBA7 Then
Dim lFrmHdl As LongPtr
#Else
Dim lFrmHdl As Long
#End If
lFrmHdl = FindWindowA(vbNullString, frm.Caption)
GetWndHandle = lFrmHdl
End Function
Public Sub ReturnPosition_CenterScreen(ByRef hWnd As Long, ByVal sngHeight As Single, _
ByVal sngWidth As Single, _
ByRef sngLeft As Single, _
ByRef sngTop As Single)
Dim sngAppWidth As Single
Dim sngAppHeight As Single
'Dim hWnd As Long
Dim lreturn As Long
Dim lpRect As udtRECT
'hWnd = Application.hWnd 'Used in Excel and Word
'hWnd = Application.hWndAccessApp 'Used in Access
lreturn = GetWindowRect(hWnd, lpRect)
sngAppWidth = ConvertPixelsToPoints(lpRect.Right - lpRect.Left, "X")
sngAppHeight = ConvertPixelsToPoints(lpRect.Bottom - lpRect.Top, "Y")
sngLeft = ConvertPixelsToPoints(lpRect.Left, "X") + ((sngAppWidth - sngWidth) / 2)
sngTop = ConvertPixelsToPoints(lpRect.Top, "Y") + ((sngAppHeight - sngHeight) / 2)
End Sub
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, _
ByVal sXorY As String) As Single
Dim hDC As Long
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
End Function
Public Sub AppTasklist(ByRef hWnd As Long)
'Add this userform into the Task bar
Dim WStyle As Long
Dim Result As Long
'Dim hWnd As Long
'hWnd = FindWindow(vbNullString, myForm.Caption)
WStyle = GetWindowLong(hWnd, GWL_EXSTYLE)
WStyle = WStyle Or WS_EX_APPWINDOW
Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_HIDEWINDOW)
Result = SetWindowLong(hWnd, GWL_EXSTYLE, WStyle)
Result = SetWindowPos(hWnd, HWND_TOP, 0, 0, 0, 0, _
SWP_NOMOVE Or _
SWP_NOSIZE Or _
SWP_NOACTIVATE Or _
SWP_SHOWWINDOW)
End Sub
Public Sub SetIcon(hWnd As Long, PathToIcon As String, Optional StrCaption As String = "MY APPLICATION")
'Dim NewIcon As String
'NewIcon = ThisWorkbook.Path & "\MYICON.ICO"
'*****************************
Dim NewIco
NewIco = ExtractIcon32(0, PathToIcon, 0)
'SendMessage32 GetActiveWindow32(), &H80, 0, NewIco '< 1 = big Icon
'SendMessage32 GetActiveWindow32(), &H80, 1, NewIco '< 0 = small Icon
SendMessage32 hWnd, &H80, 0, NewIco '< 1 = big Icon
SendMessage32 hWnd, &H80, 1, NewIco '< 0 = small Icon
'NewIco = ExtractIcon32(0, myIcoFile, 0)
'SendMessage32 GetActiveWindow32(), &H80, 1, NewIco
'ActiveWindow.Caption = StrCaption
End Sub