Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindWindowA Lib "User32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetWindowLongA Lib "User32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function SetWindowLongA Lib "User32" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLongA 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 FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare PtrSafe Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare PtrSafe Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare PtrSafe Function DrawMenuBar Lib "User32" (ByVal hWnd 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 GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Declare PtrSafe Function EnableMenuItem Lib "User32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, _
ByVal wEnable As Long) As Long
Private Declare PtrSafe Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#Else
' Private
Declare Function FindWindowA Lib "User32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetWindowLongA Lib "User32" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLongA Lib "User32" (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 FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function GetActiveWindow Lib "user32.dll" () As Long
Private Declare Function SendMessage Lib "User32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
Private Declare Function GetSystemMenu Lib "User32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "User32" (ByVal hMenu As Long) As Long
Private Declare Function EnableMenuItem Lib "User32" (ByVal hMenu As Long, ByVal wIDEnableItem As Long, _
ByVal wEnable As Long) As Long
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, _
ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
#End If
' Déclaration des constantes
Public Const WS_MAXIMIZEBOX = &H10000
Public Const WS_FULLSIZING = &H70000
'تكبير وتصغير ووشريط التول بار
'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 GWL_STYLE = (-16)
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 mcGWL_STYLE = (-16)
Private Const mcWS_SYSMENU = &H80000
'تفعيل الغاء وتشغيل اغلاق الفورم
Private Const MF_ENABLED = &H0&
Private Const MF_DISABLED = &H2&
Private Const MF_BYPOSITION = &H400
Private Const C_USERFORM_CLASSNAME = "ThunderDFrame"
'Attention, envoyer après changement du caption de l'UF
Public Sub InitMaxMin(mCaption As String, Optional Max As Boolean = True, Optional Min As Boolean = True _
, Optional Sizing As Boolean = True)
On Error Resume Next
Dim hWnd As Long
hWnd = FindWindowA(vbNullString, mCaption)
If Max Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_MAXIMIZEBOX
If Min Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_MINIMIZEBOX
If Sizing Then SetWindowLongA hWnd, GWL_STYLE, GetWindowLongA(hWnd, GWL_STYLE) Or WS_FULLSIZING
End Sub
Sub AddIcon(myForm)
'Add an icon on the titlebar
Dim hWnd As Long
Dim lngRet As Long
Dim hIcon As Long
hIcon = Sheet1.Image1.Picture.Handle
hWnd = FindWindow(vbNullString, myForm.Caption)
lngRet = SendMessage(hWnd, WM_SETICON, ICON_SMALL, ByVal hIcon)
lngRet = SendMessage(hWnd, WM_SETICON, ICON_BIG, ByVal hIcon)
lngRet = DrawMenuBar(hWnd)
End Sub
Sub AddMinimizeButton()
'Add a Minimize button to Userform
Dim hWnd As Long
hWnd = GetActiveWindow
Call SetWindowLongA(hWnd, GWL_STYLE, _
GetWindowLongA(hWnd, GWL_STYLE) Or _
WS_MINIMIZEBOX)
Call SetWindowPos(hWnd, 0, 0, 0, 0, 0, _
SWP_FRAMECHANGED Or _
SWP_NOMOVE Or _
SWP_NOSIZE)
End Sub
Sub AppTasklist(myForm)
'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 = GetWindowLongA(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 = SetWindowLongA(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 subRemoveCloseButton(frm As Object)
Dim lngStyle As Long
Dim lngHWnd As Long
lngHWnd = FindWindow(vbNullString, frm.Caption)
lngStyle = GetWindowLongA(lngHWnd, mcGWL_STYLE)
If lngStyle And mcWS_SYSMENU > 0 Then
SetWindowLongA lngHWnd, mcGWL_STYLE, (lngStyle And Not mcWS_SYSMENU)
End If
End Sub
Function EnableCloseButton(UF As MSForms.UserForm, Disable As Boolean) As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' EnableCloseButton
' This function enables (if Disable is False) or disables (if
' Disable is True) the "X" button on a UserForm UF.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim UFHWnd As Long
Dim hMenu As Long
Dim ItemCount As Long
Dim Res As Long
' Get the HWnd of the UserForm.
UFHWnd = HWndOfUserForm(UF)
If UFHWnd = 0 Then
EnableCloseButton = False
Exit Function
End If
' Get the menu handle
hMenu = GetSystemMenu(UFHWnd, 0&)
If hMenu = 0 Then
EnableCloseButton = False
Exit Function
End If
ItemCount = GetMenuItemCount(hMenu)
If Disable = True Then
Res = EnableMenuItem(hMenu, ItemCount - 1, MF_DISABLED Or MF_BYPOSITION)
Else
Res = EnableMenuItem(hMenu, ItemCount - 1, MF_ENABLED Or MF_BYPOSITION)
End If
If Res = -1 Then
EnableCloseButton = False
Exit Function
End If
DrawMenuBar UFHWnd
EnableCloseButton = True
End Function
Function HWndOfUserForm(UF As MSForms.UserForm) As Long
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' HWndOfUserForm
' This returns the window handle (HWnd) of the userform referenced
' by UF. It first looks for a top-level window, then a child
' of the Application window, then a child of the ActiveWindow.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim AppHWnd As Long
Dim DeskHWnd As Long
Dim WinHWnd As Long
Dim UFHWnd As Long
Dim Cap As String
Dim WindowCap As String
Cap = UF.Caption
' First, look in top level windows
UFHWnd = FindWindow(C_USERFORM_CLASSNAME, Cap)
If UFHWnd <> 0 Then
HWndOfUserForm = UFHWnd
Exit Function
End If
' Not a top level window. Search for child of application.
AppHWnd = Application.hWnd
UFHWnd = FindWindowEx(AppHWnd, 0&, C_USERFORM_CLASSNAME, Cap)
If UFHWnd <> 0 Then
HWndOfUserForm = UFHWnd
Exit Function
End If
' Not a child of the application.
' Search for child of ActiveWindow (Excel's ActiveWindow, not
' Window's ActiveWindow).
If Application.ActiveWindow Is Nothing Then
HWndOfUserForm = 0
Exit Function
End If
'WinHWnd = WindowHWnd(Application.ActiveWindow)
UFHWnd = FindWindowEx(WinHWnd, 0&, C_USERFORM_CLASSNAME, Cap)
HWndOfUserForm = UFHWnd
End Function
Option Explicit
Dim Lg As Single
Dim Ht As Single
Dim Fini As Boolean
Private Sub UserForm_Activate()
Dim B As Boolean
'لإخفاء العناصر على شريط الفورم
'subRemoveCloseButton Me
'إخفاء ملف الإكسيل
'Application.Visible = False
AddMinimizeButton 'Add a Minimize button to Userform
'لتسمية شريط المهام بإسم الفورم
AppTasklist Me 'Add this userform into the Task bar
'لاغلاق خاصية الخروج
B = EnableCloseButton(UF:=Me, Disable:=True)
'لتفعيل تكبير وتصغير الفورم ووضع التكبير بشريط الفورم
InitMaxMin Me.Caption
'==============
Ht = Me.Height
Lg = Me.Width
Application.WindowState = xlMaximized
End Sub
Private Sub UserForm_Resize()
Dim RtL As Single, RtH As Single
If Me.Width < 300 Or Me.Height < 200 Or Fini Then Exit Sub
RtL = Me.Width / Lg
RtH = Me.Height / Ht
Me.Zoom = IIf(RtL < RtH, RtL, RtH) * 100
End Sub
'لاغلاق خاصية الخروج
B = EnableCloseButton(UF:=Me, Disable:=True)
'لإخفاء العناصر على شريط الفورم
'subRemoveCloseButton Me
Application.Visible = False
AddMinimizeButton 'Add a Minimize button to Userform
'لتسمية شريط المهام بإسم الفورم
AppTasklist Me 'Add this userform into the Task bar
'لتفعيل تكبير وتصغير الفورم ووضع التكبير بشريط الفورم
InitMaxMin Me.Caption
Ht = Me.Height
Lg = Me.Width
Application.WindowState = xlMaximized
[2]
تكبير وتصغير ووضع يوزرفورم على شريط الادوات والتحكم بإغلاقة
تحميل محتوى الموضوع
عرض نسخة صالحة للطباعة
أرسل هذا الموضوع إلى صديق
