جعفر الطريبق

سبتمبر 8, 2021

السلام عليكم.

أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة.

كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة .

لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة .

الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم

تعريف الحدث هو كالتالي:

Public Sub OnMouseWheelScroll( _
    ByVal UserForm As Object, _
    ByVal obj As Object, _
    ByVal WheelRotation As WHEEL_ROTATION, _
    ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByRef Cancel As Boolean _
)

على كل- الكود بأكمله على النحو التالي:

1 - كود في موديول عادي :

Option Explicit

Public Enum CTRL_KEY_PRESS_STATE
    Released
    Pressed
End Enum

Public Enum WHEEL_ROTATION
    Forward
    Backward
End Enum

Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If Win64 Then
    Private Type MSG
        hwnd As LongLong
        message As Long
        wParam As LongLong
        lParam As LongLong
        time As Long
        pt As POINTAPI
    End Type
#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
#End If
    
#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongLong, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
    #Else
        Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As Any, pvarChild As Variant) As Long
        Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As LongPtr
        Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    #End If
    Private Declare PtrSafe Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare PtrSafe Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
    Private Declare PtrSafe Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetAncestor Lib "user32" (ByVal hwnd As LongPtr, ByVal gaFlags As Long) As LongPtr
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer

    Private hwnd As LongPtr, hObjUnderMouse As LongPtr, lPtr As LongPtr
#Else
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg1 As Long, ByVal arg2 As Long) As Long
    Private Declare Function IUnknown_GetWindow Lib "shlwapi" Alias "#172" (ByVal pIUnk As IUnknown, ByVal hwnd As Long) As Long
    Private Declare Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function EnumWindows Lib "user32" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetMessage Lib "user32" Alias "GetMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
    Private Declare Function TranslateMessage Lib "user32" (lpMsg As MSG) As Long
    Private Declare Function DispatchMessage Lib "user32" Alias "DispatchMessageA" (lpMsg As MSG) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function GetAncestor Lib "user32" (ByVal hwnd As Long, ByVal gaFlags As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    
    Private hwnd As Long, hObjUnderMouse As Long
#End If

Private oCurrentUserForm As Object, oCurrentIgnoreList As Variant
Private oCollection As Collection
Private objUnderMouse As Object

Private WheelRotation As WHEEL_ROTATION
Private CtrlKey As CTRL_KEY_PRESS_STATE
Private tMsg As MSG
Private tCurPos As POINTAPI, tPt As POINTAPI, tWinRect As RECT, tClient As RECT
Private oIA As IAccessible, oIACtrl As IAccessible, oIAPage As IAccessible
Private oTempCtrl As Control, oCtrl As Control, oTempPage As Control
Private vKid  As Variant
Private lLeft As Long, lTop As Long, lAccResult As Long, lPtInRectlResult As Long, i As Long
Private bCancel As Boolean




Public Property Let EnableWheelScroll(ByVal UserForm As Object, Optional IgnoreList As Variant, ByVal Enable As Boolean)

    Call KillTimer(hwnd, 0)
    If Enable = False Then
        Set oCollection = Nothing
    Else
        Set oCurrentUserForm = UserForm
        oCurrentIgnoreList = IgnoreList
        Call IUnknown_GetWindow(UserForm, VarPtr(hwnd))
        Set oCollection = New Collection
        Call SetTimer(hwnd, 0, 0, AddressOf TimerProc)
    End If

End Property



'________________________________PRIVATE SUBS___________________________________

Private Sub TimerProc()

    Const SCROLL_CHANGE = 20     ' <== Change Const as required '//
    '/////////////////////////////////////////////////////////////

    Const CHILDID_SELF = &H0&
    Const S_OK As Long = &H0
    Const WM_NCLBUTTONDOWN = &HA1
    Const WM_TIMER = &H113
    Const WM_MOUSEWHEEL = &H20A
    Const WHEEL_DELTA = 120
    Const PM_REMOVE = &H1
    Const MK_CONTROL = &H8
    Const GA_ROOT = 2
    Const POINTSPERINCH As Long = 72
    Const LOGPIXELSX As Long = 88
    Const LOGPIXELSY As Long = 90
    

    On Error Resume Next
    
    'RETRIEVE AND STORE THE LOCATION OF EACH CONTROL.
    For Each oIACtrl In oCurrentUserForm.Controls
        Set oTempCtrl = oIACtrl
        If IsError(Application.Match(TypeName(oTempCtrl), oCurrentIgnoreList, 0)) Then
            Call oIACtrl.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
            If TypeName(oTempCtrl) = "MultiPage" Then
                Set oIAPage = oTempCtrl.Pages(oTempCtrl.Value)
                Call oIAPage.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
                Set oTempPage = oIAPage
                oCollection.Add oTempPage, CStr(lLeft & lTop & oTempCtrl.Name & oTempCtrl.Pages(oTempCtrl.Value).Caption)
            End If
            oCollection.Add oTempCtrl, CStr(lLeft & lTop)
        End If
    Next
        
    'RETRIEVE ELEMENTS UNDER THE MOUSE POINTER.
    Call GetCursorPos(tCurPos)
    Call GetWindowRect(hwnd, tWinRect)
    
    #If Win64 Then
        Call CopyMemory(lPtr, tCurPos, LenB(tCurPos))
        lAccResult = AccessibleObjectFromPoint(lPtr, oIA, vKid)
        hObjUnderMouse = WindowFromPoint(lPtr)
        lPtInRectlResult = PtInRect(tWinRect, lPtr)
    #Else
        lAccResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        hObjUnderMouse = WindowFromPoint(tCurPos.X, tCurPos.Y)
        lPtInRectlResult = PtInRect(tWinRect, tCursPos.X, tCursPos.Y)
    #End If
    
    'EXIT TIMER PROC IF MOUSE OUTSIDE FORM RECT.
    If lPtInRectlResult = 0 Then
        Call KillTimer(hwnd, 0)
        GoTo Xit
    End If
 
    If lAccResult = S_OK Then
    
        Call oIA.accLocation(lLeft, lTop, 0, 0, CHILDID_SELF)
        Set objUnderMouse = oCollection.Item(lLeft & lTop)
        
        If GetAncestor(hObjUnderMouse, GA_ROOT) <> hwnd Then
            If TypeName(objUnderMouse) <> "ComboBox" Then
                Exit Sub
            End If
        End If
        
        For Each oCtrl In oCurrentUserForm.Controls
            If TypeName(oCtrl) = "MultiPage" Then
                Set objUnderMouse = oCollection.Item(lLeft & lTop & oCtrl.Name & oCtrl.Pages(oCtrl.Value).Caption)
            End If
        Next
        
        If oIA.accName(CHILDID_SELF) = oCurrentUserForm.Caption Then
            Set objUnderMouse = oCurrentUserForm
        End If
        
        'WAIT FOR A MOUSEWHEEL-SCROLL AND RAISE THE SCROLL PSEUDO-EVENT WHEN IT HAPPENS.
        If Not objUnderMouse Is Nothing Then
        
            Call GetMessage(tMsg, 0, 0, 0)
            
            'EXIT TIMER PROC WHEN MOVING THE FORM.
            If tMsg.message = WM_NCLBUTTONDOWN Then
                Call KillTimer(hwnd, 0)
                Call TranslateMessage(tMsg)
                Call DispatchMessage(tMsg)
                GoTo Xit
            End If
                
            tPt = tMsg.pt
            Call GetClientRect(hwnd, tClient)
            Call ScreenToClient(hwnd, tPt)
            
            If GetAsyncKeyState(vbKeyLButton) = 0 And tPt.Y <= 0 Then
                Call KillTimer(hwnd, 0)
                GoTo Xit
            End If
            
            'EXIT TIMER PROC WHEN MOVING THE FORM.
            If tPt.Y <= 0 Then
                If tMsg.message = WM_TIMER Then
                    Call KillTimer(hwnd, 0)
                    Call TranslateMessage(tMsg)
                    Call DispatchMessage(tMsg)
                    GoTo Xit
                End If
            End If

            If tMsg.message = WM_MOUSEWHEEL Then
            
                CtrlKey = IIf(loword(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
        
                If (hiword(CLng(tMsg.wParam)) / WHEEL_DELTA) > 0 Or (hiword(CLng(tMsg.wParam)) = WHEEL_DELTA) Then
                    WheelRotation = Forward
                Else
                    WheelRotation = Backward
                End If
                
                'RAISE THE PSEUDO-SCROLL EVENT LOCATED IN THE oCurrentUserForm MODULE.
                Call oCurrentUserForm.OnMouseWheelScroll(oCurrentUserForm, objUnderMouse, WheelRotation, CtrlKey, tCurPos.X - lLeft, tCurPos.Y - lTop, bCancel)
                 
                'IF SCROLL EVENT NOT CANCELED FOR THE CURRENT CONTROL, GO AHEAD AND IMPLEMENT THE SCROLLING.
                If Not bCancel Then
                
                    If TypeName(objUnderMouse) = "TextBox" Then
                        With objUnderMouse
                            .SetFocus
                            If i = 0 Then
                                .SelStart = 0
                            Else
                                .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                            End If
                            If WheelRotation = Forward Then
                                .CurLine = .CurLine - 1
                            Else
                                .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                            End If
                        End With
                        i = i + 1
                    End If
                    
                    If TypeName(objUnderMouse) = "ScrollBar" Then
                        With objUnderMouse
                            If WheelRotation = Forward Then
                                .Value = IIf(.Value - objUnderMouse.SmallChange > .Min, .Value - objUnderMouse.SmallChange, .Min)
                            Else
                                .Value = IIf(.Value + objUnderMouse.SmallChange < .Max, .Value + objUnderMouse.SmallChange, .Max)
                            End If
                        End With
                    End If
                    
                    If TypeName(objUnderMouse) = "ListBox" Or TypeName(objUnderMouse) = "ComboBox" Then
                    
                        With objUnderMouse
                            If CtrlKey = Released Then
                                If WheelRotation = Forward Then
                                .TopIndex = .TopIndex - 1
                                Else
                                .TopIndex = .TopIndex + 1
                                End If
                            Else
                                .SetFocus
                                If WheelRotation = Forward Then
                                    SendKeys "{LEFT}", True
                                    DoEvents
                                    SendKeys "{RIGHT}", True
                                Else
                                    SendKeys "{RIGHT}", True
                                    DoEvents
                                    SendKeys "{RIGHT}", True
                                End If
                            End If
                        End With
                        
                    End If
                    
                    If TypeName(objUnderMouse) <> "ComboBox" Then
                        Call EnumWindows(AddressOf HideDropDown, ByVal 0)
                    End If
                    
                    With objUnderMouse
                        If CtrlKey = Released Then
                            If WheelRotation = Forward Then
                                .ScrollTop = Application.Max(0, .ScrollTop - SCROLL_CHANGE)
                            Else
                                .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                            End If
                        Else
                            If WheelRotation = Forward Then
                                .ScrollLeft = Application.Max(0, .ScrollLeft - SCROLL_CHANGE)
                            Else
                                .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                            End If
                        End If
                    End With
                    
                End If
            End If
        End If
    End If

    Call TranslateMessage(tMsg)
    Call DispatchMessage(tMsg)
    
    Exit Sub

Xit:
    
    Call SetTimer(hwnd, 0, 0, AddressOf TimerProc)

End Sub



Private Function loword(DWord As Long) As Integer
    If DWord And &H8000& Then
        loword = DWord Or &HFFFF0000
    Else
        loword = DWord And &HFFFF&
    End If
End Function

Private Function hiword(ByVal DWord As Long) As Integer
    hiword = (DWord And &HFFFF0000) \ &H10000
End Function


#If Win64 Then
    Private Function HideDropDown(ByVal hwnd As LongLong, ByVal lParam As Long) As Long
#Else
    Private Function HideDropDown(ByVal hwnd As Long, ByVal lParam As Long) As Long
#End If

    Dim sClassName As String * 256
    
    Call GetClassName(hwnd, sClassName, 256)
    If Left(sClassName, 2) = "F3" Then
        Call ShowWindow(hwnd, 0)
        HideDropDown = 0
        Exit Function
    End If
    HideDropDown = 1

End Function

2 - كود في اليوزرفورم موديول

Option Explicit

Private Sub UserForm_Initialize()
    Dim i As Long

    For i = 1 To 100
        Me.ListBox1.AddItem i
        Me.ComboBox1.AddItem i
    Next i
End Sub

Private Sub UserForm_Activate()
    EnableWheelScroll(Me) = True
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    EnableWheelScroll(Me) = False
    With Sheet1
        .[a9].ClearContents
        .[a12].ClearContents
        .[a15].ClearContents
        .[a18].ClearContents
        .[a21].ClearContents
        .[a24].ClearContents
        .[a27].ClearContents
    End With
End Sub


Private Sub CommandButton1_Click()
    UserForm2.Show vbModeless
End Sub

Private Sub CommandButton2_Click()
    Unload Me
End Sub



'--------------------
'Public Generic event
'Set the Cancel Argument to TRUE to disable scrolling
Public Sub OnMouseWheelScroll( _
    ByVal UserForm As Object, _
    ByVal obj As Object, _
    ByVal WheelRotation As WHEEL_ROTATION, _
    ByVal CtrlKey As CTRL_KEY_PRESS_STATE, _
    ByVal X As Long, _
    ByVal Y As Long, _
    ByRef Cancel As Boolean _
)

    With Sheet1
        If TypeName(obj) = "Page" Then
            .[a12] = obj.Parent.Name & "." & obj.Name
        Else
            .[a12] = obj.Name
        End If
        .[a9] = UserForm.Name
        .[a15] = IIf(WheelRotation = Forward, "Forward", "Backward")
        .[a18] = IIf(CtrlKey = Pressed, "Pressed", "Released")
        .[a21] = IIf(CtrlKey = Pressed, "Horizontal", "Vertical")
        .[a24] = X
        .[a27] = Y
    End With

End Sub

أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك. وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى

سبتمبر 17, 2018

لماذا تريد اخفاء شريط الاكسيل ... وما هو اصدار الاكسيل لديك

سبتمبر 17, 2018

مثلا

Option Explicit

Private Sub CommandButton1_Click()
    Call MakeFolder("C:\", "MyNewFolder")
End Sub


Private Function MakeFolder(ByVal Root As String, ByVal NewFolderName As String) As String
    Dim oShell As Object
    
    Set oShell = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder and click Ok.", 0, Replace(Replace(Replace(Root, ":", ""), "\", "") & ":\", " ", ""))
    If Not oShell Is Nothing Then
        MkDir oShell.Self.Path & "\" & Replace(NewFolderName, "\", "")
    End If
End Function

أغسطس 20, 2018

برنامج اكسيل لا يتوفر على حدث النقر على الخلايا بالزر الأيسر.

الكود التالي كنت قد كتبته قبل فترة وعدلته بعض الشيئ لكي يشتغل فقط عندما ينقر المستخدم بالزر الأيسر على الخلايا الموجودة في العمود B و الشيت Sheet1.. يمكن تغيير العمود المستهدف و الورقة المستهدفة بسهولة في الحدث Wb_CellClick الموجود في ال ThisWorkBook Module

الجديد والمفيد في هذا الكود هو انه لا يشتغل عند الدخول الى الخلايا عن طريق لوحة الكيبورد كما هو الشان بالنسبة لحدث ال Worksheet_SelectionChange .. الكود التالي يشتغل فقط عند الدحول الى الخلايا عن طريق النقر بالماوس .

ملف للتحميل

1- أضف كلاس موديول جديد الى البروجيكت و سميه C_CellClickEvent

ضع الكود التالي في الكلاس موديول

Code in C_CellClickEvent Class Module :

Option Explicit

Private WithEvents CmBrasEvents As CommandBars
Private WithEvents wbEvents As Workbook
Event CellClick(ByVal Target As Range)

Private Type POINTAPI
    x As Long
    Y As Long
End Type

Private Type KeyboardBytes
     kbByte(0 To 255) As Byte
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare PtrSafe Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
#Else
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function GetKeyState Lib "user32" (ByVal nVirtKey As Long) As Integer
    Private Declare Function GetActiveWindow Lib "user32" () As Long
    Private Declare Function GetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
    Private Declare Function SetKeyboardState Lib "user32" (kbArray As KeyboardBytes) As Long
#End If

Private kbArray As KeyboardBytes
Private oPrevSelection As Range

Private Sub Class_Initialize()
    Set CmBrasEvents = Application.CommandBars
    Set wbEvents = ThisWorkbook
    GetKeyboardState kbArray
    kbArray.kbByte(vbKeyLButton) = 0
    SetKeyboardState kbArray
End Sub

Private Sub Class_Terminate()
    Set CmBrasEvents = Nothing
    Set wbEvents = Nothing
End Sub

Private Sub CmBrasEvents_OnUpdate()
    Dim tpt As POINTAPI
    
    On Error Resume Next
    GetKeyboardState kbArray
    If GetActiveWindow <> Application.hwnd Then Exit Sub
    GetCursorPos tpt
    If GetKeyState(vbKeyLButton) = 1 Then
        If TypeName(ActiveWindow.RangeFromPoint(tpt.x, tpt.Y)) = "Range" Then
            If oPrevSelection.Address = ActiveWindow.RangeFromPoint(tpt.x, tpt.Y).Address Then
                RaiseEvent CellClick(Selection)
            End If
        End If
    End If
    kbArray.kbByte(vbKeyLButton) = 0
    SetKeyboardState kbArray
End Sub

Private Sub wbEvents_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error Resume Next
    Set oPrevSelection = Target
End Sub

2- ضع الكود التالي في ال ThisWorkBook Module :

Option Explicit

Private WithEvents Wb As C_CellClickEvent

Private Sub Workbook_Open()
    Set Wb = New C_CellClickEvent
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Set Wb = Nothing
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If Wb Is Nothing Then
        Set Wb = New C_CellClickEvent
    End If
End Sub

'Cell Click event handler
Private Sub Wb_CellClick(ByVal Target As Range)

If Target.Parent Is Sheet1 And Target.Column = 2 Then
    With Target
        .Font.Bold = True
        .Font.Name = IIf(.Value = "", "Wingdings", "calibri")
        .Value = IIf(.Value = "", "ü", "")
        MsgBox "You clicked cell : " & vbLf & .Address(External:=True), vbInformation
    End With
    
    End If
End Sub

أغسطس 20, 2018

في ٩‏/٨‏/٢٠١٨ at 06:59, محمود1980 said:

الاخ ياسر شكرا دائما على تعاونك وتجاوبك

سؤال : هل ممكن تنفيذ التعليمات اعلاه عند النقر على الخلية بالزر الايسر بعد ثانيتين بدل النقر المزدوج ؟

Sub Test()
    MsgBox "Hello Mahmoud"
End Sub

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Cells.CountLarge > 1 Then Exit Sub
    If Target.Column = 2 Then
        Cancel = True
        Call Test
    End If
End Sub

عفوا لم أقرأ السوأل جيدا ... ظننت أنك طلب نتفيذ الكود عند النقر بازر الأيمن

لكن سأحاول كتابة الكود المطلوب يعني عند النقر على الخلية بالزر الايسر ونشره هنا لتعميم الفائدة

أغسطس 20, 2018

في ١٩‏/٨‏/٢٠١٨ at 07:22, خليل خليل داماس said:

ألف شكر لردك السريع وجزاك الله كل خير

أخ علي
طلبي هو : الحدث عند الخروج من حلية معينة

مثلا: انا كنت في الخلية A1 فإذا أنا كتبت فيها شيئا حرف أو رقم لا تظهر اية رسائل تنبيه وإذا تركتها فارغة وانتقلت الى A2 او B1 تظهر رسالة تنبهني ان الخلية السابقة فارعة ويرجع التركيز إلى A1

ولكم كل الشكر

ليس هنالك حدث عند الخروج من خلية لكن يمكن تحقيق ما طلبته بشئ من الكود

أضف الكود التالي الى ThisWorkbook Module :

Option Explicit

Private oPrevCell As Range
Private Const TARGET_SHEET = "Sheet1" '<== Change Target Sheet as required.
Private Const TARGET_CELL = "A1" '<== Change Target Cell as required.

Private Sub Workbook_Activate()
    Call StoreTargetCell
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Call StoreTargetCell
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    On Error GoTo Xit
    If Sh Is Sheets(TARGET_SHEET) Then
        If Union(Target, Range(TARGET_CELL)).Address = Target.Address Then
            Set oPrevCell = Range(TARGET_CELL)
        Else
            If IsEmpty(oPrevCell) Then
                Application.EnableEvents = False
                Range(TARGET_CELL).Activate
                MsgBox "Oops!" & vbCrLf & vbCrLf & "You Can't Leave Cell : '" & TARGET_CELL & "' Empty", vbCritical
            End If
        End If
    End If
Xit:
    Application.EnableEvents = True
End Sub

Private Sub StoreTargetCell()
    If ActiveSheet Is Sheets(TARGET_SHEET) Then
       Set oPrevCell = IIf(ActiveCell.Address = Range(TARGET_CELL).Address, ActiveCell, Nothing)
    End If
End Sub

الكود أعلاه يفترض أن الخلية المقصودة هي خلية A1 في الورقة Sheet1.. عدل ال Constants الموجودتان في أعلا الكود حسب الاحتياج

سبتمبر 9, 2016

السلام عليكم

من المعروف أن الاكسل يسمح باضافة صورة خلفية لورقة العمل عن طريق Page Layout ==> BackGround

لكن ليس من الممكن اضافة صورة خلفية فقط لجزء من الورقة يعني صورة وراء بعض الخلايا فقط .. الكود التالي يسمح لنا بذالك

http://

الكود في موديول عادي

Option Explicit

Private Type POINTAPI
    x As Long
    y As Long
End Type

Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    #If Win64 Then
        Private Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    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 GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

#If VBA7 Then
    Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal nCmdShow As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function MoveWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare PtrSafe Function ScreenToClient Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, 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 SetWindowRgn Lib "user32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Private Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As LongPtr
    Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long
    Private Declare PtrSafe Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Private Declare PtrSafe Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As LongPtr, ByVal lpString As String) As LongPtr
    Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hwnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function IsIconic Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function DrawMenuBar Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As LongPtr, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
    
    Private lRgn1 As LongPtr, lRgn2 As LongPtr
    Private hwndImage As LongPtr, hwndExcel7 As LongPtr
#Else
    Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex 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 MoveWindow Lib "user32" (ByVal hWnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
    Private Declare Function ScreenToClient Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent 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 SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    Private Declare Function SelectClipRgn Lib "gdi32" (ByVal hDC As Long, ByVal hRgn As Long) As Long
    Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal x2 As Long, ByVal y2 As Long) As Long
    Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function PtInRect Lib "user32" (lpRect As RECT, pt As POINTAPI) As Long
    Private Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hWnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Private Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hWnd As Long, ByVal lpString As String) As Long
    Private Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hWnd As Long, ByVal lpString As String) 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
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare Function IsIconic Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd 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 lRgn1 As Long, lRgn2 As Long
    Private hwndImage As Long, hwndExcel7 As Long
#End If

Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_BORDER = &H800000
Private Const WS_DLGFRAME = &H400000
Private Const WS_THICKFRAME = &H40000
Private Const WS_DISABLED = &H8000000

Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_LAYERED = &H80000
Private Const WS_EX_TRANSPARENT = &H20&
Private Const WS_EX_DLGMODALFRAME = &H1
Private Const WS_EX_TOPMOST = &H8&

Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Const POINTSPERINCH = 72

Private Const SWP_FRAMECHANGED = &H20
Private Const RGN_AND = 1
Private Const LWA_ALPHA = &H2&

Private tTargetRangeRect As RECT
Private oTargetRange As Range


'Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
' Calling Macros ..
'--------------------------
Public Sub ShowImage()
    Call DisplayImage(UserForm1, Sheet1.Range("B8: E20"))
End Sub

Public Sub HideImage()
    Call CleanUp(UserForm1)
End Sub


'Public Routines ..
'-------------------
Public Sub DisplayImage(ByVal Img As Object, ByVal TargetRange As Range)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    If GetProp(Application.hwnd, "Image") <> 0 Then Exit Sub
    Set oTargetRange = TargetRange
    hwndExcel7 = FindWindowEx(FindWindowEx(Application.hwnd, 0, "XLDESK", vbNullString), 0, "EXCEL7", vbNullString)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    Img.StartUpPosition = 0
    hwndImage = FindWindow(vbNullString, Img.Caption)
    SetProp Application.hwnd, "Image", hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) And Not WS_CAPTION)
    DrawMenuBar hwndImage
    Call SetWindowLong(hwndImage, GWL_STYLE, GetWindowLong(hwndImage, GWL_STYLE) _
    And Not WS_BORDER And Not WS_THICKFRAME And Not WS_DLGFRAME Or WS_DISABLED)
    With tTargetRangeRect
        Call SetWindowPos(hwndImage, WS_EX_TOPMOST, .Left, .Top, .Right - .Left, .Bottom - .Top, SWP_FRAMECHANGED)
    End With
    Call SetWindowLong(hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) And Not WS_EX_DLGMODALFRAME)
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_LAYERED
    SetWindowLong hwndImage, GWL_EXSTYLE, GetWindowLong(hwndImage, GWL_EXSTYLE) Or WS_EX_TRANSPARENT
    SetLayeredWindowAttributes hwndImage, 0, 128, LWA_ALPHA
    Img.Show vbModeless
    SetTimer Application.hwnd, 0, 1, AddressOf ImagePositionMonitor
End Sub

Public Sub CleanUp(ByVal Img As Object)
    KillTimer Application.hwnd, 0
    RemoveProp Application.hwnd, "Image"
    Unload Img
End Sub

'Private Routines ..
'-------------------
Private Sub ImagePositionMonitor()
    Static l1 As Long, t1 As Long, r1 As Long, b1 As Long, _
    l2 As Long, t2 As Long, r2 As Long, b2 As Long
    Dim tpt1 As POINTAPI, tpt2 As POINTAPI, tCurPos As POINTAPI
    Dim tVsbRngRect As RECT
    
    On Error Resume Next
    tVsbRngRect = GetRangeRect(ActiveWindow.VisibleRange)
    tTargetRangeRect = GetRangeRect(oTargetRange)
    GetCursorPos tCurPos
'    If GetAsyncKeyState(vbKeyLButton) <> 0 And PtInRect(tVsbRngRect, tCurPos) <> 0 And _
'    TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _
'    tTargetRangeRect.Left = l1 Then Exit Sub
    If GetAsyncKeyState(vbKeyLButton) <> 0 And _
    TypeName(ActiveWindow.RangeFromPoint(tCurPos.x, tCurPos.y)) = "Range" And _
    tTargetRangeRect.Left = l1 Then Exit Sub
    If Not ActiveSheet Is oTargetRange.Parent Or IsIconic(Application.hwnd) Then
        ShowWindow hwndImage, 0
        Exit Sub
    Else
        ShowWindow hwndImage, 1
    End If
    With tTargetRangeRect
        MoveWindow hwndImage, .Left, .Top, _
        .Right - .Left, _
        .Bottom - .Top, True
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tVsbRngRect
        tpt1.x = .Left
        tpt1.y = .Top
        tpt2.x = .Right
        tpt2.y = .Bottom
        ScreenToClient hwndExcel7, tpt1
        ScreenToClient hwndExcel7, tpt2
        .Left = tpt1.x
        .Top = tpt1.y
        .Right = tpt2.x
        .Bottom = tpt2.y
    End With
    With tTargetRangeRect
        If .Left <> l1 Or .Top <> t1 Or tVsbRngRect.Left <> l2 Or tVsbRngRect.Top <> t2 Or _
        .Right <> r1 Or .Bottom <> b1 Or tVsbRngRect.Right <> r2 Or tVsbRngRect.Bottom <> b2 Then
            lRgn1 = CreateRectRgn(-tVsbRngRect.Left, -tVsbRngRect.Top, tVsbRngRect.Right, tVsbRngRect.Bottom)
            lRgn2 = CreateRectRgn(tVsbRngRect.Left - .Left, tVsbRngRect.Top - .Top, _
            tVsbRngRect.Right - .Left, tVsbRngRect.Bottom - .Top)
            Call CombineRgn(lRgn2, lRgn2, lRgn1, RGN_AND)
            SetWindowRgn hwndImage, lRgn2, True
            DeleteObject lRgn1
            DeleteObject lRgn2
        End If
    End With
    With tTargetRangeRect
        l1 = .Left
        t1 = .Top
        r1 = .Right
        b1 = .Bottom
    End With
    With tVsbRngRect
        l2 = .Left
        t2 = .Top
        r2 = .Right
        b2 = .Bottom
    End With
End Sub

Private Function GetRangeRect(ByVal rng As Range) As RECT
    Dim OWnd  As Window
    
    Set OWnd = rng.Parent.Parent.Windows(1)
    With rng
        GetRangeRect.Left = PTtoPX(.Left * OWnd.Zoom / 100, 0) _
        + OWnd.PointsToScreenPixelsX(0)
        GetRangeRect.Top = PTtoPX(.Top * OWnd.Zoom / 100, 1) _
        + OWnd.PointsToScreenPixelsY(0)
        GetRangeRect.Right = PTtoPX(.Width * OWnd.Zoom / 100, 0) _
        + GetRangeRect.Left
        GetRangeRect.Bottom = PTtoPX(.Height * OWnd.Zoom / 100, 1) _
        + GetRangeRect.Top
    End With
End Function
Private Function PTtoPX _
(Points As Single, bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function
Private Function ScreenDPI(bVert As Boolean) As Long
    Static lDPI(1), lDC
   If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

بم تجريب الكود على Windows 64Bit Office 2010 64Bit و Windows 7 32Bit Office 2007

ملف للتحميل

سبتمبر 9, 2016

لقد جربت الكود على (ويندوز 7 32 بت أوفيس 2007) و اشتغل جيدا .. سأحاول تجريب الكود على أوفيس 2010/2016 لأرى هل المشكلة تحصل في بعض اضدارات الاوفيس

سبتمبر 9, 2016

شكرا على تجريب الكود يا أستاذ ياسر

سأحاول تجريب الكود هذا المساء في جهاز يشتغل على 32 بت

سبتمبر 9, 2016

لو ممكن ترفع البرنامج يمكن أنا أو عضو أخر أن نعدل الأكواد ليشتغل مع 32 و 64 بت

سبتمبر 9, 2016

السلام عليكم

السكرول بعجلة الماوس غير ممكن مع الفورم أو الكنترولات ... الكود التالي يفتح هذه الامكانية وهو كود جامع موحد

ملف للتحميل

1- الكود في موديول عاديي

Option Explicit

Public Enum CTRL_KEY_PRESS_STATE
    Released
    Pressed
End Enum

Public Enum WHEEL_ROTATION
    Forward
    Backward
End Enum

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LongToInteger
    Low As Integer
    High As Integer
End Type

#If VBA7 Then
    Private Type MSG
        hwnd As LongPtr
        message As Long
        wParam As LongPtr
        lParam As LongPtr
        time As Long
        pt As POINTAPI
    End Type
    
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
    Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Function GetParent Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function WindowFromPoint Lib "user32" (ByVal Point As LongPtr) As LongPtr
    Private Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wFlag As Long) As LongPtr
    Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RECT) As Long
    Private Declare PtrSafe Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As LongPtr, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg As Long) As Long
    Private Declare PtrSafe Function WaitMessage Lib "user32" () As Long
    Private Declare PtrSafe Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32.dll" (lpPoint As POINTAPI) As Long
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
    Private Declare PtrSafe Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dest As Any, ByVal numBytes As LongPtr)
    Private Declare PtrSafe Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As LongPtr) As Long
#If Win64 Then
     Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
#Else
     Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
#End If

#Else
    Private Type MSG
        hwnd As Long
        message As Long
        wParam As Long
        lParam As Long
        time As Long
        pt As POINTAPI
    End Type
    Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Private Declare Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
    Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
    Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
    Private Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
    Private Declare Function WaitMessage Lib "user32" () As Long
    Private Declare Function PeekMessage Lib "user32" Alias "PeekMessageA" (lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long, ByVal wRemoveMsg 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 AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
    Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
    Private Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long
#End If
 
Private Const CHILDID_SELF = &H0&
Private Const S_OK As Long = &H0
Private Const POINTSPERINCH As Long = 72
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
Private Const WM_MOUSEWHEEL = &H20A
Private Const PM_REMOVE = &H1
Private bCancelProcessing As Boolean
Private Const MK_CONTROL = &H8
Private Const SCROLL_CHANGE = 10

Private arObjCaptions() As Variant
Private arObjPointers() As Variant

Public Sub HookMouseWheelScroll(ByVal UF As Object)
    Dim WheelRotation As WHEEL_ROTATION
    Dim CtrlKey As CTRL_KEY_PRESS_STATE
    Dim tMsg As MSG
    Dim tCurPos As POINTAPI
    Dim oIA As IAccessible
    Dim oObjUnderMouse As Object
    Dim oPage As Object
    Dim oCtrl As Object
    Dim vKid  As Variant
    Dim i As Long
    Dim j As Long
    Dim lResult As Long
    Dim bCancel As Boolean
    Static k As Long
    #If VBA7 Then
        Dim Ptr As LongPtr
    #Else
        Dim Ptr As Long
    #End If
    
    bCancelProcessing = False
    k = 0
    UF.Caption = UF.Caption & Chr(10)
    j = 0
    Erase arObjCaptions
    Erase arObjPointers
    For Each oCtrl In UF.Controls
        If TypeName(oCtrl) = "MultiPage" Then
            For Each oPage In oCtrl.Pages
                i = i + 1
                oPage.Caption = oPage.Caption & String(i, Chr(10))
                ReDim Preserve arObjCaptions(j)
                ReDim Preserve arObjPointers(j)
                arObjCaptions(j) = oPage.Caption & Chr(10)
                arObjPointers(j) = ObjPtr(oPage)
                j = j + 1
            Next
        End If
    Next
    Do While Not bCancelProcessing
        DoEvents
        GetCursorPos tCurPos
        #If Win64 Then
            CopyMemory Ptr, tCurPos, LenB(tCurPos)
            lResult = AccessibleObjectFromPoint(Ptr, oIA, vKid)
        #Else
            lResult = AccessibleObjectFromPoint(tCurPos.X, tCurPos.Y, oIA, vKid)
        #End If
        If lResult = S_OK Then
            On Error Resume Next
            Set oObjUnderMouse = objUnderMouse(UF, oIA, tCurPos)
            If Not oObjUnderMouse Is Nothing Then
                WaitMessage
                If PeekMessage(tMsg, 0, WM_MOUSEWHEEL, WM_MOUSEWHEEL, PM_REMOVE) Then
                    CtrlKey = IIf(LoWord(CLng(tMsg.wParam)) = MK_CONTROL, Pressed, Released)
                    WheelRotation = IIf(tMsg.wParam > 0, Forward, Backward)
                    Call UF.OnScrollEvent(oObjUnderMouse, WheelRotation, CtrlKey, tMsg.pt.X, tMsg.pt.Y, bCancel)
                    If Not bCancel Then
                        If TypeName(oObjUnderMouse) = "TextBox" Then
                            With oObjUnderMouse
                                .SetFocus
                                If k = 0 Then
                                    .SelStart = 0
                                Else
                                    .SelStart = IIf(.SelStart = .LineCount, 0, .SelStart)
                                End If
                                If WheelRotation = Forward Then
                                    .CurLine = .CurLine - 1
                                Else
                                    .CurLine = IIf(.CurLine = .LineCount - 1, .CurLine, .CurLine + 1)
                                End If
                            End With
                            k = k + 1
                        End If
                        If TypeName(oObjUnderMouse) = "ScrollBar" Then
                            With oObjUnderMouse
                                If WheelRotation = Forward Then
                                    .Value = IIf(.Value - oObjUnderMouse.SmallChange > .Min, .Value - oObjUnderMouse.SmallChange, .Min)
                                Else
                                    .Value = IIf(.Value + oObjUnderMouse.SmallChange < .Max, .Value + oObjUnderMouse.SmallChange, .Max)
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = "ListBox" Or TypeName(oObjUnderMouse) = "ComboBox" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                    .TopIndex = .TopIndex - 1
                                    Else
                                    .TopIndex = .TopIndex + 1
                                    End If
                                Else
                                    .SetFocus
                                    If WheelRotation = Forward Then
                                        SendKeys "{LEFT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    Else
                                        SendKeys "{RIGHT}", True
                                        DoEvents
                                        SendKeys "{RIGHT}", True
                                    End If
                                End If
                            End With
                        End If
                        If TypeName(oObjUnderMouse) = UF.Name Or TypeName(oObjUnderMouse) = "Frame" Or TypeName(oObjUnderMouse) = "Page" Then
                            With oObjUnderMouse
                                If CtrlKey = Released Then
                                    If WheelRotation = Forward Then
                                        .ScrollTop = Application.Max(0, .ScrollTop - 5)
                                    Else
                                        .ScrollTop = Application.Min(.ScrollHeight - .InsideHeight, .ScrollTop + SCROLL_CHANGE)
                                    End If
                                Else
                                    If WheelRotation = Forward Then
                                        .ScrollLeft = Application.Max(0, .ScrollLeft - 5)
                                    Else
                                        .ScrollLeft = Application.Min(.ScrollWidth - .InsideWidth, .ScrollLeft + SCROLL_CHANGE)
                                    End If
                                End If
                            End With
                        End If
                    End If
                    DoEvents
                End If
            End If
        End If
    Loop
End Sub


Public Sub RemoveMouseWheelHook()
    bCancelProcessing = True
End Sub


'Private Routines ..
'-------------------

Private Function objUnderMouse(ByVal UF As Object, ByVal oAcc As IAccessible, MouseLoc As POINTAPI) As Object
    #If VBA7 Then
        Dim lngPtr As LongPtr
        Dim lObjPtr As LongPtr
        Dim lCtrlPtr As LongPtr
        Dim hwndForm As LongPtr
        Dim hwndFromPoint As LongPtr
    #Else
        Dim lObjPtr As Long
        Dim lCtrlPtr As Long
        Dim hwndForm As Long
        Dim hwndFromPoint As Long
    #End If
    Dim arCtrlsPosition() As Variant
    Dim arCtrlsPointers() As Variant
    Dim tPt As POINTAPI
    Dim tRect As RECT
    Dim oObj As Object
    Dim oCtrl As Control
    Dim sBuffer As String
    Dim lCtrlLeft As Long
    Dim lCtrlTop As Long
    Dim lPos1 As Long
    Dim lPos2 As Long
    Dim lPos3 As Long
    Dim lRet As Long
    Dim i As Long

    On Error Resume Next
    hwndForm = FindWindow(vbNullString, UF.Caption)
    For Each oCtrl In UF.Controls
        ReDim Preserve arCtrlsPosition(i + 1)
        ReDim Preserve arCtrlsPointers(i + 1)
        tPt = GetRealCtrlScreenLocation(oCtrl, hwndForm, UF)
        arCtrlsPosition(i) = tPt.X & tPt.Y
        arCtrlsPointers(i) = ObjPtr(oCtrl)
        arCtrlsPosition(i + 1) = tPt.X - 2 & tPt.Y - 1
        arCtrlsPointers(i + 1) = ObjPtr(oCtrl)
        i = i + 2
    Next
    lPos1 = WorksheetFunction.Match(oAcc.accName(CHILDID_SELF) & Chr(10), arObjCaptions, 0)
    lObjPtr = WorksheetFunction.Index(arObjPointers, 1, lPos1)
    Call oAcc.accLocation(lCtrlLeft, lCtrlTop, 0, 0, CHILDID_SELF)
    lPos2 = WorksheetFunction.Match(lCtrlLeft & lCtrlTop, arCtrlsPosition, 0)
    lCtrlPtr = WorksheetFunction.Index(arCtrlsPointers, 1, lPos2)
    #If VBA7 Then
        CopyMemory lngPtr, MouseLoc, LenB(MouseLoc)
        hwndFromPoint = WindowFromPoint(lngPtr)
    #Else
        hwndFromPoint = WindowFromPoint(MouseLoc.X, MouseLoc.Y)
    #End If
    sBuffer = Space(256)
    lRet = GetClassName(GetParent(hwndFromPoint), sBuffer, 256)
    lPos3 = InStr(1, Left(sBuffer, lRet), "MdcPopup")
    Select Case True
        Case lPos3 <> 0
            Set objUnderMouse = GetActiveComboBox(UF)
            Exit Function
        Case oAcc.accName(CHILDID_SELF) = UF.Caption
            Set oObj = UF
        Case lObjPtr = 0
            If IsBadCodePtr(lCtrlPtr) = 0 Then
                CopyMemory oObj, lCtrlPtr, 4
            End If
        Case lObjPtr <> 0
            If IsBadCodePtr(lObjPtr) = 0 Then
                CopyMemory oObj, lObjPtr, 4
            End If
    End Select
    Set objUnderMouse = oObj
    If Not oObj Is Nothing Then
        ZeroMemory oObj, 4
    End If
End Function

#If VBA7 Then
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As LongPtr, ByVal UF As Object) As POINTAPI
#Else
    Private Function GetRealCtrlScreenLocation(ByVal Ctl As Object, ByVal hwnd As Long, ByVal UF As Object) As POINTAPI
#End If
    Dim tRect As RECT
    Dim tTopLeft As POINTAPI
    Dim oMultiPage As Control
    Dim oTempObj As Control

    On Error Resume Next
    Set oTempObj = Ctl.Parent
    With tTopLeft
        Select Case True
             Case oTempObj Is Nothing
                .X = PTtoPX(Ctl.Left - UF.ScrollLeft * UF.Zoom / 100, False)
                .Y = PTtoPX(Ctl.Top - UF.ScrollTop * UF.Zoom / 100, True)
                ClientToScreen hwnd, tTopLeft
             Case TypeName(oTempObj) = "Frame"
                GetWindowRect oTempObj.[_GethWnd], tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left + 2
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top + 8
            Case TypeName(oTempObj) = "Page"
                Set oMultiPage = oTempObj.Parent
                GetWindowRect GetNextWindow(oMultiPage.[_GethWnd], 5), tRect
                .X = PTtoPX(Ctl.Left - oTempObj.ScrollLeft * (oTempObj.Zoom / 100), False) + tRect.Left
                .Y = PTtoPX(Ctl.Top - oTempObj.ScrollTop * (oTempObj.Zoom / 100), True) + tRect.Top
                Set oMultiPage = Nothing
            End Select
        End With
    GetRealCtrlScreenLocation = tTopLeft
    Set oTempObj = Nothing
End Function

Private Function GetActiveComboBox(ByVal Ctl As Object) As Control
    Dim oCtl As Object
    Dim lCur As Long
    On Error Resume Next
    For Each oCtl In Ctl.Controls
        Err.Clear
        lCur = oCtl.CurX
        If Err.Number = 0 And TypeName(oCtl) = "ComboBox" Then Set GetActiveComboBox = oCtl: Exit Function
    Next
End Function

Private Function LoWord(ByVal Word As Long) As Integer
    Dim X As LongToInteger
    CopyMemory X, Word, LenB(X)
    LoWord = X.Low
End Function

Private Function ScreenDPI(ByVal bVert As Boolean) As Long
    Static lDPI(1), lDC
    If lDPI(0) = 0 Then
        lDC = GetDC(0)
        lDPI(0) = GetDeviceCaps(lDC, LOGPIXELSX)
        lDPI(1) = GetDeviceCaps(lDC, LOGPIXELSY)
        lDC = ReleaseDC(0, lDC)
    End If
    ScreenDPI = lDPI(Abs(bVert))
End Function

Private Function PTtoPX(ByVal Points As Single, ByVal bVert As Boolean) As Long
    PTtoPX = Points * ScreenDPI(bVert) / POINTSPERINCH
End Function

2- كود في موديول الفورم


Option Explicit

Private Sub UserForm_Activate()
    Dim i As Long
    
    'Populate the controls
    For i = 0 To 100
        With ListBox1
            .ColumnCount = 4
            .ColumnWidths = "100;100;100;100"
            .AddItem "COLUMN1"
            .List(i, 1) = "COLUMN2"
            .List(i, 2) = "COLUMN3"
            .List(i, 3) = "COLUMN4"
        End With
        ListBox2.AddItem i
        ComboBox1.AddItem i
        ComboBox2.AddItem i
        ComboBox3.AddItem i
        ComboBox4.AddItem i
        ComboBox5.AddItem i
        ComboBox6.AddItem i
        ComboBox7.AddItem i
        ComboBox8.AddItem i
        ComboBox9.AddItem i
    Next i
    With TextBox1
        .Text = .Text & String(300, "A")
        .Text = .Text & String(300, "I")
        .Text = .Text & String(300, "X")
    End With
    Label1.Caption = "Object :"
    Label2.Caption = "Wheel Rotation :"
    Label3.Caption = "Scroll Direction :"
    Label4.Caption = "Cursor X :"
    Label5.Caption = "Cursor Y :"
    Label6.Caption = "Scroll Cancelled :"

    
    'Hook MouseWheel Scroll of Form and of all its controls
    Call HookMouseWheelScroll(Me)

End Sub
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Call RemoveMouseWheelHook
End Sub
Private Sub CommandButton1_Click()
    Unload Me
End Sub


'--------------------
'Public Generic event
'--------------------

Public Sub OnScrollEvent(ByVal Obj As Object, ByVal WheelRotation As WHEEL_ROTATION, _
ByVal CtrlKey As CTRL_KEY_PRESS_STATE, ByVal X As Long, ByVal Y As Long, Cancel As Boolean)

    Dim sObjName As String, sWheelRot As String, sCtrlKey As String
    Dim sCurX As String, sCurY As String, sCancelScrol As String
    
    sObjName = "Object :  (" & Obj.Name & ")"
    sWheelRot = "Wheel Rotation :  (" & IIf(WheelRotation = Forward, "Forward", "Backward") & ")"
    sCtrlKey = "Scroll Direction :  (" & IIf(CtrlKey = Released, "Vert", "Horiz") & ")"
    sCurX = "Cursor X :  (" & X & ")"
    sCurY = "Cursor Y :  (" & Y & ")"
    sCancelScrol = "Scroll Cancelled :  (" & Cancel & ")"
    
    Label1.Caption = sObjName
    Label2.Caption = sWheelRot
    Label3.Caption = sCtrlKey
    Label4.Caption = sCurX
    Label5.Caption = sCurY
    Label6.Caption = sCancelScrol
End Sub

سبتمبر 9, 2016

7 ساعات مضت, ياسر خليل أبو البراء said:

أنا أعمل الآن على نظام ويندوز 7 32 بت ويعمل بشكل ممتاز

بارك الله فيك وجزاك الله كل خير

بارك الله فيك أستاذ ياسر .. سعيد بنجاح الكود على الويندوز 32 بت

سبتمبر 8, 2016

شكرا لكم على الردود

يا استاذ ياسر - هل جربت الكود على نظام 32 بت و اشتغل

سبتمبر 8, 2016

السلام عليكم

قبل فترة كتات هذا الكود على الويندوز 64 بت لكنني لم أجربه على الويندوز 32 بت .. أرجو أن يعمل في كلا النظامين

http://

ملف للتحميل

1- الكود في موديول عادي

'Code written in Excel2010 Win10 by jaafar tribak on 10/04/2016
'This code is an attempt to let the user add elliptical buttons to an excel userform @ runtime
'The 'AddRoundButton' Sub lets you specify the button's attributes
'Written and tested on Excel 2010/Win 2010 64 bits

Option Explicit
Option Base 1

Public Enum E_V_E_N_T
    ClickEvent = 1
    BeforeRightClick = 2
    MouseMoveEvent = 4
End Enum
    
Private Type POINTAPI
    X As Long
    Y As Long
End Type

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type LOGFONT
    lfHeight As Long
    lfWidth As Long
    lfEscapement As Long
    lfOrientation As Long
    lfWeight As Long
    lfItalic As String * 1
    lfUnderline As String * 1
    lfStrikeOut As String * 1
    lfCharSet As String * 1
    lfOutPrecision As String * 1
    lfClipPrecision As String * 1
    lfQuality As String * 1
    lfPitchAndFamily As String * 1
    lfFaceName As String * 32
End Type

Private Type LOGBRUSH
    lbStyle As Long
    lbColor As Long
#If VBA7 Then
    lbHatch As LongPtr
#Else
    lbHatch As Long
#End If
End Type

Private Type PAINTSTRUCT
#If VBA7 Then
    hDC As LongPtr
#Else
    hDC As Long
#End If
    fErase As Long
    rcPaint As RECT
    fRestore As Long
    fIncUpdate As Long
    rgbReserved(0 To 31) As Byte
End Type

#If VBA7 Then
    #If Win64 Then
        Declare PtrSafe Function SetWindowLong Lib "USER32" Alias "SetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Declare PtrSafe Function GetWindowLong Lib "USER32" Alias "GetWindowLongPtrA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #Else
        Declare PtrSafe Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        Declare PtrSafe Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As LongPtr, ByVal nIndex As Long) As LongPtr
    #End If
#Else
    Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
#End If

#If VBA7 Then
    Declare PtrSafe Function GetDesktopWindow Lib "USER32" () As LongPtr
    Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    Declare PtrSafe Function IsWindow Lib "USER32" (ByVal hWnd As LongPtr) As Long
    Declare PtrSafe Function MessageBeep Lib "USER32" (ByVal wType As Long) As Long
    Declare PtrSafe Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long
    Declare PtrSafe Function ScreenToClient Lib "USER32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
    Declare PtrSafe Function ClientToScreen Lib "USER32" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
    Declare PtrSafe Function CreateWindowEx Lib "USER32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName 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 hMenu As LongPtr, ByVal hInstance As LongPtr, lpParam As Any) As LongPtr
    Declare PtrSafe Function DestroyWindow Lib "USER32" (ByVal hWnd As LongPtr) As Long
    Declare PtrSafe Function ShowWindow Lib "USER32" (ByVal hWnd As LongPtr, ByVal nCmdShow As Long) As Long
    Declare PtrSafe Function SetParent Lib "USER32" (ByVal hWndChild As LongPtr, ByVal hWndNewParent As LongPtr) As LongPtr
    Declare PtrSafe Function SetRect Lib "USER32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function GetClientRect Lib "USER32" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
    Declare PtrSafe Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As LongPtr
    Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
    Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
    Declare PtrSafe Function FillRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr, ByVal hBrush As LongPtr) As Long
    Declare PtrSafe Function FillRect Lib "USER32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
    Declare PtrSafe Function OffsetRgn Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function SetWindowRgn Lib "USER32" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
    Declare PtrSafe Function SelectClipRgn Lib "gdi32" (ByVal hDC As LongPtr, ByVal hRgn As LongPtr) As Long
    Declare PtrSafe Function PtVisible Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function PtInRegion Lib "gdi32" (ByVal hRgn As LongPtr, ByVal X As Long, ByVal Y As Long) As Long
    Declare PtrSafe Function EqualRect Lib "USER32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Declare PtrSafe Function IntersectRect Lib "USER32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    Declare PtrSafe Function SetWindowPos Lib "USER32" (ByVal hWnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
    Declare PtrSafe Function DrawEdge Lib "USER32" (ByVal hDC As LongPtr, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Declare PtrSafe Function CallWindowProc Lib "USER32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As LongPtr, ByVal hWnd As LongPtr, ByVal Msg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Declare PtrSafe Function GetSysColor Lib "USER32" (ByVal nIndex As Long) As Long
    Declare PtrSafe Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Declare PtrSafe Function SetTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Declare PtrSafe Function KillTimer Lib "USER32" (ByVal hWnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
    Declare PtrSafe Function SetProp Lib "USER32" Alias "SetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal hData As LongPtr) As Long
    Declare PtrSafe Function GetProp Lib "USER32" Alias "GetPropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function RemoveProp Lib "USER32" Alias "RemovePropA" (ByVal hWnd As LongPtr, ByVal lpString As String) As LongPtr
    Declare PtrSafe Function SendMessage Lib "USER32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Declare PtrSafe Function GetSystemMetrics Lib "USER32" (ByVal nIndex As Long) As Long
    Declare PtrSafe Function InvalidateRect Lib "USER32" (ByVal hWnd As LongPtr, lpRect As RECT, ByVal bErase As Long) As Long
    Declare PtrSafe Function SetMapMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nMapMode As Long) As Long
    Declare PtrSafe Function GetAsyncKeyState Lib "USER32" (ByVal vKey As Long) As Integer
    Declare PtrSafe Function SetWindowText Lib "USER32" Alias "SetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String) As Long
    Declare PtrSafe Function RedrawWindow Lib "USER32" (ByVal hWnd As LongPtr, ByVal lprcUpdate As Long, ByVal hrgnUpdate As LongPtr, ByVal fuRedraw As Long) As Long
    Declare PtrSafe Function GetDC Lib "USER32" (ByVal hWnd As LongPtr) As LongPtr
    Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hWnd As LongPtr, ByVal hDC As LongPtr) As Long
    Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Declare PtrSafe Function BeginPaint Lib "USER32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As LongPtr
    Declare PtrSafe Function EndPaint Lib "USER32" (ByVal hWnd As LongPtr, lpPaint As PAINTSTRUCT) As Long
    Declare PtrSafe Function SetTextColor Lib "gdi32" (ByVal hDC As LongPtr, ByVal crColor As Long) As Long
    Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare PtrSafe Function StretchBlt Lib "gdi32" (ByVal hDC As LongPtr, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Declare PtrSafe Function SetBkMode Lib "gdi32" (ByVal hDC As LongPtr, ByVal nBkMode As Long) As Long
    Declare PtrSafe Function DrawText Lib "USER32" Alias "DrawTextA" (ByVal hDC As LongPtr, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Declare PtrSafe Function GetTextCharacterExtra Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Declare PtrSafe Function SetTextCharacterExtra Lib "gdi32" (ByVal hDC As LongPtr, ByVal nCharExtra As Long) As Long
    Declare PtrSafe Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Declare PtrSafe Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Declare PtrSafe Function GetWindowText Lib "USER32" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As Long) As Long
    Declare PtrSafe Function GetCurrentThreadId Lib "kernel32.dll" () As Long
    Declare PtrSafe Function CallNextHookEx Lib "user32.dll" (ByVal hhk As LongPtr, ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Declare PtrSafe Function SetWindowsHookExW Lib "user32.dll" (ByVal idHook As Long, ByVal lpfn As LongPtr, ByVal hMod As LongPtr, ByVal dwThreadId As Long) As LongPtr
    Declare PtrSafe Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hhk As LongPtr) As Long
    Declare PtrSafe Function EnumChildWindows Lib "USER32" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long

    Private lFormHwnd, lFormDC, hFormMinusButtonsRegion, lFormPrevWndProc, lCurrentRGN, _
    hwndToolTip, lToolTipPrevWndProc, lButtonReleasedMemDC, lButtonPressedMemDC, hHook As LongPtr
    
#Else
    Declare Function GetDesktopWindow Lib "user32" () As Long
    Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function MessageBeep Lib "user32" (ByVal wType As Long) As Long
    Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Declare Function ClientToScreen Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
    Declare Function CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName 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 Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
    Declare Function DestroyWindow Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ShowWindow Lib "user32" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
    Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
    Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
    Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
    Declare Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare Function CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Declare Function FillRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long, ByVal hBrush As Long) As Long
    Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
    Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
    Declare Function OffsetRgn Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
    Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Long) As Long
    Declare Function SelectClipRgn Lib "gdi32" (ByVal hDc As Long, ByVal hRgn As Long) As Long
    Declare Function PtVisible Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long) As Long
    Declare Function PtInRegion Lib "gdi32" (ByVal hRgn As Long, ByVal X As Long, ByVal Y As Long) As Long
    Declare Function EqualRect Lib "user32" (lpRect1 As RECT, lpRect2 As RECT) As Long
    Declare Function IntersectRect Lib "user32" (lpDestRect As RECT, lpSrc1Rect As RECT, lpSrc2Rect As RECT) As Long
    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
    Declare Function DrawEdge Lib "user32" (ByVal hDc As Long, qrc As RECT, ByVal edge As Long, ByVal grfFlags As Long) As Long
    Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
    Declare Function TranslateColor Lib "oleaut32.dll" Alias "OleTranslateColor" (ByVal clr As OLE_COLOR, ByVal palet As Long, Col As Long) As Long
    Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Declare Function SetProp Lib "user32" Alias "SetPropA" (ByVal hwnd As Long, ByVal lpString As String, ByVal hData As Long) As Long
    Declare Function GetProp Lib "user32" Alias "GetPropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function RemoveProp Lib "user32" Alias "RemovePropA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
    Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
    Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT, ByVal bErase As Long) As Long
    Declare Function SetMapMode Lib "gdi32" (ByVal hDc As Long, ByVal nMapMode As Long) As Long
    Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Integer
    Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
    Declare Function RedrawWindow Lib "user32" (ByVal hwnd As Long, ByVal lprcUpdate As Long, ByVal hrgnUpdate As Long, ByVal fuRedraw As Long) As Long
    Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDc As Long) As Long
    Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
    Declare Function BeginPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Declare Function EndPaint Lib "user32" (ByVal hwnd As Long, lpPaint As PAINTSTRUCT) As Long
    Declare Function SetTextColor Lib "gdi32" (ByVal hDc As Long, ByVal crColor As Long) As Long
    Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
    Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
    Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
    Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
    Declare Function StretchBlt Lib "gdi32" (ByVal hDc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
    Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
    Declare Function DrawText Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
    Declare Function GetTextCharacterExtra Lib "gdi32" (ByVal hDc As Long) As Long
    Declare Function SetTextCharacterExtra Lib "gdi32" (ByVal hDc As Long, ByVal nCharExtra As Long) As Long
    Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" (ByVal lpString As String) As Integer
    Declare Function GlobalGetAtomName Lib "kernel32" Alias "GlobalGetAtomNameA" (ByVal nAtom As Integer, ByVal lpBuffer As String, ByVal nSize As Long) As Long
    Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
    Declare Function GetCurrentThreadId Lib "kernel32.dll" () As Long
    Declare Function CallNextHookEx Lib "user32.dll" (ByVal hhk As Long, ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Declare Function SetWindowsHookExW Lib "user32.dll" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hMod As Long, ByVal dwThreadId As Long) As Long
    Declare Function UnhookWindowsHookEx Lib "user32.dll" (ByVal hhk As Long) As Long
    Declare Function EnumChildWindows Lib "user32" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long

    Private lFormHwnd, lFormDC, hFormMinusButtonsRegion, lFormPrevWndProc, lCurrentRGN, _
    hwndToolTip, lToolTipPrevWndProc, lButtonReleasedMemDC, lButtonPressedMemDC, hHook As Long
#End If
   
Private tButtonXYCoords As POINTAPI
Private bToollTipDelayExists As Boolean
Private bStreching As Boolean
Private bAnErrorHasOccurred As Boolean
Private sButtonsAttributesArray() As String
Private sToolTipText As String
Private iBoutonsCounter As Integer
Private oForm As Object
    
Private Const WM_RBUTTONDOWN = &H204
Private Const WM_LBUTTONDOWN = &H201
Private Const WM_PARENTNOTIFY = &H210
Private Const WM_PAINT = &HF
Private Const WM_SETREDRAW = &HB
Private Const WM_ERASEBKGND = &H14
Private Const WM_NCHITTEST = &H84
Private Const WM_NCDESTROY = &H82
Private Const WM_EXITSIZEMOVE = &H232
Private Const WM_DESTROY = &H2
Private Const WM_MOVE = &H3
Private Const WM_SETCURSOR = &H20
Private Const BDR_SUNKENOUTER = &H2
Private Const BDR_RAISEDINNER = &H4
Private Const EDGE_ETCHED = (BDR_SUNKENOUTER Or BDR_RAISEDINNER)
Private Const BF_BOTTOM = &H8
Private Const BF_LEFT = &H1
Private Const BF_RIGHT = &H4
Private Const BF_TOP = &H2
Private Const BF_RECT = (BF_LEFT Or BF_TOP Or BF_RIGHT Or BF_BOTTOM)
Private Const DT_LEFT = &H0
Private Const DT_WORDBREAK = &H10
Private Const DT_CALCRECT = &H400
Private Const DT_EDITCONTROL = &H2000
Private Const DT_NOCLIP = &H100
Private Const DT_SINGLELINE = &H20
Private Const DT_CENTER = &H1
Private Const DT_VCENTER = &H4
Private Const COLOR_INFOTEXT = 23
Private Const COLOR_INFOBK = 24
Private Const GWL_STYLE = (-16)
Private Const WS_CAPTION = &HC00000
Private Const WS_CLIPCHILDREN = &H2000000
Private Const WS_CHILD = &H40000000
Private Const WS_EX_TOOLWINDOW = &H96
Private Const WS_EX_NOACTIVATE = &H8000000
Private Const WS_EX_TOPMOST As Long = &H8
Private Const DS_MODALFRAME = &H96
Private Const SRCCOPY = &HCC0020
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RDW_INTERNALPAINT = &H2
Private Const GWL_USERDATA = (-21)
Private Const GWL_WNDPROC = -4
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const MB_ICONASTERISK = &H40&
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5


Public Sub AddRoundButton( _
    ByVal Form As Object, _
    ByVal ButtonName As String, _
    ByVal Left As Long, _
    ByVal Top As Long, _
    ByVal Width As Long, _
    ByVal Height As Long, _
    Optional ByVal Caption As String, _
    Optional ByVal FontColor As Variant, _
    Optional ByVal BackColor As Variant, _
    Optional ByVal TooltipText As String, _
    Optional ToolTipBeep As Boolean = False, _
    Optional AnimateButton As Boolean = False, _
    Optional EventMacro As String)

#If VBA7 Then
    Dim hwndButton, hRgnWnd, hRgnClient, lPrevRgn As LongPtr
    Dim hFont, hFillBrush, hButtonDC, lPrevWinButtonProc As LongPtr
 #Else
    Dim hwndButton, hRgnWnd, hRgnClient, lPrevRgn As Long
    Dim hFont, hFillBrush, hButtonDC, lPrevWinButtonProc As Long
#End If
    Dim tFormRect As RECT
    Dim tSourceRect As RECT
    Dim tDestinationRect As RECT
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    Dim tFont As LOGFONT
    Dim tFillLB As LOGBRUSH
    Dim tButtonWinRect As RECT
    Dim tButtonClientRect As RECT
    Dim lRealcolor1 As Long
    Dim i As Long
    Dim Atom_ID As Integer
    Const FontHeight As Long = 14
    Const FontWidth As Long = 9
    Const PtToPix = 96 / 72
    
    On Error GoTo errHandler
    If Len(Caption) = 0 Then Caption = ButtonName
    Set oForm = Form
    lFormHwnd = FindWindow(vbNullString, Form.Caption)
    SetProp Application.hWnd, "FormHwnd", lFormHwnd
    GetWindowRect lFormHwnd, tFormRect
    hwndButton = CreateWindowEx(WS_EX_TOOLWINDOW, "static", _
    vbNullString, WS_CHILD + WS_CLIPCHILDREN, Left * PtToPix, Top * PtToPix, _
    Width * PtToPix, Height * PtToPix, lFormHwnd, 0, 0, 0)
    If hwndButton <> 0 Then
        GetClientRect hwndButton, tButtonClientRect
        lFormDC = GetDC(lFormHwnd)
        hButtonDC = GetDC(hwndButton)
        SetParent hwndButton, lFormHwnd
        SetBkMode hButtonDC, 1
        ShowWindow hwndButton, 1
        TranslateColor oForm.BackColor, 0, lRealcolor1
        If IsMissing(BackColor) Then
            BackColor = oForm.BackColor
        End If
        TranslateColor BackColor, 0, lRealcolor1
        BackColor = lRealcolor1
        tFillLB.lbColor = BackColor
        hFillBrush = CreateBrushIndirect(tFillLB)
        DoEvents
        GetWindowRect hwndButton, tButtonWinRect
        With tButtonWinRect
            hRgnWnd = CreateEllipticRgn _
            (.Left, .Top, .Right, .Bottom)
            tPt1.X = .Left
            tPt1.Y = .Top
            tPt2.X = .Right
            tPt2.Y = .Bottom
            ScreenToClient lFormHwnd, tPt1
            ScreenToClient lFormHwnd, tPt2
            .Left = tPt1.X
            .Top = tPt1.Y
            .Right = tPt2.X
            .Bottom = tPt2.Y
            lPrevRgn = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
            SetProp hwndButton, "ButtonLeft", CStr(.Left)
            SetProp hwndButton, "ButtonTop", CStr(.Top)
            SetProp hwndButton, "ButtonRight", CStr(.Right)
            SetProp hwndButton, "ButtonBottom", CStr(.Bottom)
        End With
        With tButtonClientRect
            hRgnClient = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
            If hFormMinusButtonsRegion = 0 Then
                hFormMinusButtonsRegion = CreateRectRgn(0, 0, tFormRect.Right, tFormRect.Bottom)
            End If
            CombineRgn hFormMinusButtonsRegion, hFormMinusButtonsRegion, lPrevRgn, RGN_XOR
            FillRgn hButtonDC, hRgnClient, hFillBrush
            SelectClipRgn hButtonDC, hRgnClient
            SetWindowRgn hwndButton, hRgnClient, True
            tFont.lfHeight = FontHeight
            tFont.lfWidth = FontWidth
            FontColor = IIf(IsMissing(FontColor), vbBlack, FontColor)
            SetTextColor hButtonDC, FontColor
            hFont = CreateFontIndirect(tFont)
            Call SelectObject(hButtonDC, hFont)
            Call Add3DEffect(hwndButton, hButtonDC, BackColor, hRgnClient, False)
            DrawText hButtonDC, Caption, Len(Caption), tButtonClientRect, _
            DT_CENTER + DT_VCENTER + DT_SINGLELINE
        End With
        ReDim Preserve sButtonsAttributesArray(iBoutonsCounter + 1)
        sButtonsAttributesArray(iBoutonsCounter + 1) = ButtonName & Chr(1) & CStr(tButtonWinRect.Left) _
        & Chr(1) & CStr(tButtonWinRect.Top) & Chr(1) & CStr(tButtonWinRect.Left) & Chr(1) & _
        CStr(tButtonWinRect.Right) & Chr(1) & CStr(tButtonWinRect.Bottom) & Chr(1) & _
        Caption & Chr(1) & CStr(BackColor) & Chr(1) & FontColor & Chr(1) & TooltipText & _
        Chr(1) & CStr(hwndButton) & Chr(1) & CStr(hButtonDC) & Chr(1) & CStr(hRgnWnd) & Chr(1) _
        & CStr(hRgnClient) & Chr(1) & AnimateButton & Chr(1) & EventMacro
        iBoutonsCounter = iBoutonsCounter + 1
        GetWindowRect hwndButton, tButtonWinRect
        For i = 1 To UBound(sButtonsAttributesArray)
            GetWindowRect Split(sButtonsAttributesArray(i), Chr(1))(10), tSourceRect
            If EqualRect(tButtonWinRect, tSourceRect) = 0 Or _
                CBool(Split(sButtonsAttributesArray(i), Chr(1))(14)) = False Then
                If IntersectRect(tDestinationRect, tButtonWinRect, tSourceRect) <> 0 Then
                    SetProp hwndButton, "DoNotStretch", 1
                    SetProp Split(sButtonsAttributesArray(i), Chr(1))(10), "DoNotStretch", 1
                End If
            End If
        Next i
        Atom_ID = GlobalAddAtom(TooltipText & Chr(1) & EventMacro)
        SetProp hwndButton, "ToolTipTextAndEventMacro_Atom", (Atom_ID)
        SetProp hwndButton, "RGN", hRgnClient
        With tButtonWinRect
            lButtonReleasedMemDC = TakeSnapShot(.Left, .Top, .Right, .Bottom, Caption, FontColor, hFillBrush, BackColor, False)
            SetProp hwndButton, "ButtonReleased", lButtonReleasedMemDC
            lButtonPressedMemDC = TakeSnapShot(.Left, .Top, .Right, .Bottom, Caption, FontColor, hFillBrush, BackColor, True)
            SetProp hwndButton, "ButtonPressed", lButtonPressedMemDC
        End With
        If ToolTipBeep Then SetProp hwndButton, "Beep", 1
        InstallCBTHook
        Application.OnTime Now, "HookTheButtons"
        Application.OnTime Now, "HookTheForm"
        DeleteObject hFillBrush
        DeleteObject hFont
        ReleaseDC hwndButton, hButtonDC
    Else
        MsgBox "failed to create button"
    End If
    Exit Sub
errHandler:
    If Err.Number = 457 Then
        MsgBox "Error ..." & vbCr & "Failed to add the Button :" & " '" & ButtonName & "'", _
        vbCritical, "Button Name Duplicate !"
    Else
        MsgBox Err.Number & vbCr & Err.Description
    End If
End Sub

#If VBA7 Then
Sub EventMacro(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, ByVal X As Long, _
ByVal Y As Long, ByVal hWnd As LongPtr)
    Dim Atom_ID As LongPtr
    Dim hDC As LongPtr
#Else
Sub EventMacro(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, ByVal X As Long, _
ByVal Y As Long, ByVal hWnd As Long)
    Dim Atom_ID As Long
    Dim hDC As Long
#End If
    Dim tButtonWinRect As RECT
    Dim tPt As POINTAPI
    Dim sBuffer As String
    Dim lRet As Long
    
    On Error GoTo errHandler:
    If IsWindow(hwndToolTip) Then DestroyWindow hwndToolTip
    If SoughtEvent = ClickEvent Then
        Do
            DoEvents
        Loop Until GetAsyncKeyState(VBA.vbKeyLButton) = 0
    End If
    GetCursorPos tPt
    ScreenToClient hWnd, tPt
    hDC = GetDC(hWnd)
    If PtVisible(hDC, tPt.X, tPt.Y) = 0 Then GoTo errHandler
    sBuffer = Space(256)
    Atom_ID = GetProp(hWnd, "ToolTipTextAndEventMacro_Atom")
    lRet = GlobalGetAtomName(CInt(Atom_ID), sBuffer, Len(sBuffer))
    sBuffer = Left(sBuffer, lRet)
    sBuffer = Split(sBuffer, Chr(1))(1)
    If Len(sBuffer) <> 0 Then
        CallByName oForm, sBuffer, VbMethod, ButtonName, SoughtEvent, X, Y
    End If
errHandler:
    If Err.Number = 438 Then
        MsgBox "The Button Event Macro" & " '" & sBuffer & "' " & "doesn't exist", vbCritical, "Error"
        Err.Clear
    End If
    GetWindowRect hWnd, tButtonWinRect
    tPt.X = tButtonWinRect.Left
    tPt.Y = tButtonWinRect.Top
    ScreenToClient lFormHwnd, tPt
    With tButtonWinRect
        BitBlt lFormDC, tPt.X, tPt.Y, .Right - .Left, .Bottom - .Top, _
        GetProp(hWnd, "ButtonReleased"), 0, 0, SRCCOPY
    End With
    ReleaseDC hWnd, hDC
    oForm.Repaint
End Sub

Private Sub HookTheButtons()
#If VBA7 Then
    Dim lPrevProc As LongPtr
    Dim i As Long
    For i = 1 To UBound(sButtonsAttributesArray)
        If GetWindowLong(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA) = 0 Then
            lPrevProc = SetWindowLong _
            (Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_WNDPROC, AddressOf ButtonWinProc)
            SetWindowLong Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA, lPrevProc
        End If
    Next i
#Else
    Dim lPrevProc As Long
    Dim i As Long
    For i = 1 To UBound(sButtonsAttributesArray)
        If GetWindowLong(Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA) = 0 Then
            lPrevProc = SetWindowLong _
            (Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_WNDPROC, AddressOf ButtonWinProc)
            SetWindowLong Split(sButtonsAttributesArray(i), Chr(1))(10), GWL_USERDATA, lPrevProc
        End If
    Next i
#End If
End Sub

Private Sub HookTheForm()
#If VBA7 Then
    If lFormPrevWndProc = 0 Then
        lFormPrevWndProc = SetWindowLong _
        (lFormHwnd, GWL_WNDPROC, AddressOf FormWinProc)
        SetWindowLong lFormHwnd, GWL_USERDATA, lFormPrevWndProc
        SetWindowLong Application.hWnd, GWL_USERDATA, lFormPrevWndProc
    End If
#Else
        If lFormPrevWndProc = 0 Then
        lFormPrevWndProc = SetWindowLong _
        (lFormHwnd, GWL_WNDPROC, AddressOf FormWinProc)
        SetWindowLong lFormHwnd, GWL_USERDATA, lFormPrevWndProc
        SetWindowLong Application.hWnd, GWL_USERDATA, lFormPrevWndProc
    End If
#End If
End Sub
Private Sub unHookTheForm()
#If VBA7 Then
    Call SetWindowLong(GetProp(Application.hWnd, "FormHwnd"), GWL_WNDPROC, _
    GetWindowLong(Application.hWnd, GWL_USERDATA))
    RemoveProp Application.hWnd, "FormHwnd"
    lFormPrevWndProc = 0
#Else
     Call SetWindowLong(GetProp(Application.hWnd, "FormHwnd"), GWL_WNDPROC, _
    GetWindowLong(Application.hWnd, GWL_USERDATA))
    RemoveProp Application.hWnd, "FormHwnd"
    lFormPrevWndProc = 0
#End If
End Sub


#If VBA7 Then
Private Function TakeSnapShot(ByVal Left As Long, _
    ByVal Top As Long, _
    ByVal Right As Long, _
    ByVal Bottom As Long, _
    Optional ByVal Caption As String, _
    Optional FontColor As Variant, _
    Optional ByVal Brush As Variant, _
    Optional ByVal Fill As Variant, _
    Optional ByVal PressState As Boolean) As LongPtr
    Dim hwndTempButton, hTempShapeDC, lMemoryDC, lBmp, hTempRgnClient As LongPtr
#Else
Private Function TakeSnapShot(ByVal Left As Long, _
    ByVal Top As Long, _
    ByVal Right As Long, _
    ByVal Bottom As Long, _
    Optional ByVal Caption As String, _
    Optional FontColor As Variant, _
    Optional ByVal Brush As Variant, _
    Optional ByVal Fill As Variant, _
    Optional ByVal PressState As Boolean) As Long
    Dim hwndTempButton, hTempShapeDC, lMemoryDC, lBmp, hTempRgnClient As Long
#End If
    Dim tTempShapeClientRect As RECT
    
    hwndTempButton = CreateWindowEx(WS_EX_TOOLWINDOW, "static", _
    vbNullString, WS_CHILD + WS_CLIPCHILDREN, Left + 100, Top + 100, _
    (Right - Left), (Bottom - Top), GetDesktopWindow, 0, 0, 0)
    hTempShapeDC = GetDC(hwndTempButton)
    SetParent hwndTempButton, GetDesktopWindow
    SetBkMode hTempShapeDC, 1
    ShowWindow hwndTempButton, 1
    GetClientRect hwndTempButton, tTempShapeClientRect
    With tTempShapeClientRect
        hTempRgnClient = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
    End With
    DoEvents
    FillRgn hTempShapeDC, hTempRgnClient, Brush
    SelectClipRgn hTempShapeDC, hTempRgnClient
    SetWindowRgn hwndTempButton, hTempRgnClient, True
    Call Add3DEffect(hwndTempButton, hTempShapeDC, Fill, hTempRgnClient, PressState)
    SetTextColor hTempShapeDC, FontColor
    DrawText hTempShapeDC, Caption, Len(Caption), tTempShapeClientRect, _
    DT_CENTER + DT_VCENTER + DT_SINGLELINE
    If lMemoryDC = 0 Then
        lMemoryDC = CreateCompatibleDC(lFormDC)
    End If
    With tTempShapeClientRect
        lBmp = CreateCompatibleBitmap(hTempShapeDC, .Right - .Left, .Bottom - .Top)
        DeleteObject SelectObject(lMemoryDC, lBmp)
        BitBlt lMemoryDC, 0, 0, .Right - .Left, .Bottom - .Top, _
        hTempShapeDC, 0, 0, SRCCOPY
    End With
    TakeSnapShot = lMemoryDC
    DeleteObject lBmp
    ReleaseDC hwndTempButton, hTempShapeDC
    DestroyWindow hwndTempButton
End Function

#If VBA7 Then
Private Sub StretchButton(ByVal hWnd As LongPtr)
    Dim hBmp, lOldBmp, hMemoryDC, hDC As LongPtr
#Else
Private Sub StretchButton(ByVal hWnd As Long)
    Dim hBmp, lOldBmp, hMemoryDC, hDC As Long
#End If
    Dim tWinRect As RECT
    
    hDC = GetDC(0)
    GetWindowRect hWnd, tWinRect
    hMemoryDC = CreateCompatibleDC(hDC)
    With tWinRect
        hBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
        lOldBmp = SelectObject(hMemoryDC, hBmp)
        BitBlt hMemoryDC, 0, 0, .Right - .Left, .Bottom - .Top, _
        hDC, .Left, .Top, SRCCOPY
        StretchBlt _
        hDC, .Left, .Top, (.Right - .Left) * 1.1, (.Bottom - .Top) * 1.1, _
        hMemoryDC, 0, 0, _
        (.Right - .Left), (.Bottom - .Top), SRCCOPY
    End With
    ReleaseDC 0, hDC
End Sub

#If VBA7 Then
Private Sub Add3DEffect(ByVal hWnd As LongPtr, ByVal hDC As LongPtr, ByVal Fill As Long, _
ByVal ClientRegion As LongPtr, ByVal ButtonPressed As Boolean)
    Dim hRgn1, hRgn2, hRgn3 As LongPtr
    Dim hBrush1, hBrush2, hBrush3 As LongPtr
    Dim hDestRGN1, hDestRGN2, hDestRGN3 As LongPtr
#Else
Private Sub Add3DEffect(ByVal hWnd As Long, ByVal hDC As Long, ByVal Fill As Long, _
ByVal ClientRegion As Long, ByVal ButtonPressed As Boolean)
    Dim hRgn1, hRgn2, hRgn3 As Long
    Dim hBrush1, hBrush2, hBrush3 As Long
    Dim hDestRGN1, hDestRGN2, hDestRGN3 As Long
#End If
    Dim tBrush1 As LOGBRUSH
    Dim tBrush2 As LOGBRUSH
    Dim tBrush3 As LOGBRUSH
    Dim tClientRect As RECT
    Dim tPt1 As POINTAPI
    Dim tPt2 As POINTAPI
    Dim Offset As Integer
    Dim lRealColor As Long

    TranslateColor oForm.BackColor, 0, lRealColor
    Offset = IIf(ButtonPressed, IIf(Fill = lRealColor, 2, 3), IIf(Fill = lRealColor, -2, -3))
    GetClientRect hWnd, tClientRect
    With tClientRect
        hRgn1 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
        hDestRGN1 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
        OffsetRgn hRgn1, Offset, Offset
        tBrush1.lbColor = DarkenColor(Fill)
        hBrush1 = CreateBrushIndirect(tBrush1)
        CombineRgn hDestRGN1, hRgn1, ClientRegion, RGN_OR
        CombineRgn hDestRGN1, hRgn1, hDestRGN1, RGN_XOR
        FillRgn hDC, hDestRGN1, hBrush1
        hRgn2 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
        hDestRGN2 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
        OffsetRgn hRgn2, -Offset, -Offset
        tBrush2.lbColor = LightenColor(Fill)
        hBrush2 = CreateBrushIndirect(tBrush2)
        CombineRgn hDestRGN2, hRgn2, ClientRegion, RGN_OR
        CombineRgn hDestRGN2, hRgn2, hDestRGN2, RGN_XOR
        FillRgn hDC, hDestRGN2, hBrush2
        hRgn3 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
        hDestRGN3 = CreateEllipticRgn(.Left, .Top, .Right, .Bottom)
     End With
    OffsetRgn hRgn3, 1, 1
    tBrush3.lbColor = DarkenColor(Fill)
    hBrush3 = CreateBrushIndirect(tBrush3)
    CombineRgn hDestRGN3, hRgn3, ClientRegion, RGN_OR
    CombineRgn hDestRGN3, hRgn3, hDestRGN3, RGN_XOR
    If Fill <> lRealColor Then
        FillRgn hDC, hDestRGN3, hBrush3
    End If
    DoEvents
    DeleteObject hRgn1
    DeleteObject hRgn2
    DeleteObject hRgn3
    DeleteObject hDestRGN1
    DeleteObject hDestRGN2
    DeleteObject hDestRGN3
    DeleteObject hBrush1
    DeleteObject hBrush2
    DeleteObject hBrush3
End Sub

Private Sub ShowToolTip(ByVal Text As String, ByVal Left As Long, ByVal Top As Long, _
Right As Long, Bottom As Long, ByVal OffsetX As Long, ByVal OffsetY As Long, _
Optional ByVal ToolTipSecondsDelay As Variant)
#If VBA7 Then
    Dim hOldFont, hFont, hDC, lCurrentStyle, lNewStyle As LongPtr
#Else
    Dim hOldFont, hFont, hDC, lCurrentStyle, lNewStyle As Long
#End If
    Dim lFontHeight As Long
    Dim lFontWidth As Long
    Dim lPrevCharSpacing As Long
    Dim lCalc As Long
    Dim tFont As LOGFONT
    Dim tRect As RECT
    Dim tPt As POINTAPI

    sToolTipText = Text
    hDC = GetDC(0)
    SetMapMode hDC, 1
    SetBkMode hDC, 1
    lPrevCharSpacing = SetTextCharacterExtra(hDC, 1)
    With tFont
        .lfFaceName = "TAHOMA" & Chr$(0)
        .lfHeight = 16
        .lfWidth = 6
        lFontHeight = .lfHeight
        lFontWidth = .lfWidth
    End With
    hFont = CreateFontIndirect(tFont)
    hOldFont = SelectObject(hDC, hFont)
    SetRect tRect, 0, 0, (lFontWidth) * 20, 0
    lCalc = DrawText(hDC, sToolTipText, Len(sToolTipText), tRect, _
    DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK + DT_CALCRECT)
    hOldFont = SelectObject(hDC, hFont)
    DeleteObject hFont
    hwndToolTip = CreateWindowEx(WS_EX_TOOLWINDOW + WS_EX_TOPMOST, "STATIC", _
    vbNullString, WS_CHILD, 0, 0, 0, 0, GetDesktopWindow, 0, 0, 0)
    Call SetTextCharacterExtra(hDC, lPrevCharSpacing)
    #If VBA7 Then
        lCurrentStyle = GetWindowLong(hwndToolTip, GWL_STYLE)
        lCurrentStyle = lCurrentStyle And (Not WS_CAPTION)
        lNewStyle = SetWindowLong(hwndToolTip, GWL_STYLE, lCurrentStyle)
        lToolTipPrevWndProc = SetWindowLong(hwndToolTip, GWL_WNDPROC, AddressOf ToolTipWinProc)
    #Else
        lCurrentStyle = GetWindowLong(hwndToolTip, GWL_STYLE)
        lCurrentStyle = lCurrentStyle And (Not WS_CAPTION)
        lNewStyle = SetWindowLong(hwndToolTip, GWL_STYLE, lCurrentStyle)
        lToolTipPrevWndProc = SetWindowLong(hwndToolTip, GWL_WNDPROC, AddressOf ToolTipWinProc)
    #End If
    tPt.X = Right + OffsetX
    tPt.Y = Bottom + OffsetY
    ClientToScreen lFormHwnd, tPt
    SetWindowPos hwndToolTip, 0, tPt.X, tPt.Y, _
    (lFontWidth + GetTextCharacterExtra(hDC)) * 20, lCalc + 5, &H40
    ReleaseDC 0, hDC
    If Not IsMissing(ToolTipSecondsDelay) Then
        SetTimer hwndToolTip, 0, ToolTipSecondsDelay * 1000, AddressOf DestroyToolTip
    End If
End Sub

Private Sub DestroyToolTip()
    #If VBA7 Then
    Call SetWindowLong(hwndToolTip, GWL_WNDPROC, _
    lToolTipPrevWndProc)
    #Else
    Call SetWindowLong(hwndToolTip, GWL_WNDPROC, _
    lToolTipPrevWndProc)
    #End If
    DestroyWindow hwndToolTip
    hwndToolTip = 0
    oForm.Repaint
End Sub

#If VBA7 Then
Private Function FormWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hRgnWnd As LongPtr
#Else
Private Function FormWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hRgnWnd As Long
#End If

    Dim i As Integer
    Dim TempArray() As String
    Dim LOWORD As Long, HIWORD As Long
    Dim tCursorPos As POINTAPI
    Dim tPt As POINTAPI
    Dim tButtonWinRect As RECT
    Dim tFormRect As RECT
    Dim tFormClientRect As RECT
    Dim EventAction As E_V_E_N_T

    On Error Resume Next

    Call MonitorErrors
    Select Case uMsg
        Case WM_PARENTNOTIFY
            GetHiLoword CLng(wParam), LOWORD, HIWORD
            If LOWORD = WM_LBUTTONDOWN Then
                EventAction = ClickEvent
            ElseIf LOWORD = WM_RBUTTONDOWN Then
                EventAction = BeforeRightClick
            End If
            If EventAction <> 0 Then
                GetHiLoword CLng(lParam), LOWORD, HIWORD
                tCursorPos.X = LOWORD
                tCursorPos.Y = HIWORD
                ClientToScreen hWnd, tCursorPos
                For i = 1 To UBound(sButtonsAttributesArray)
                    TempArray = Split(sButtonsAttributesArray(i), Chr(1))
                    hRgnWnd = TempArray(12)
                    If PtInRegion(hRgnWnd, tCursorPos.X, tCursorPos.Y) <> 0 Then
                        If Len(TempArray(15)) > 0 Then
                            GetWindowRect TempArray(10), tButtonWinRect
                            tPt.X = tButtonWinRect.Left
                            tPt.Y = tButtonWinRect.Top
                            ScreenToClient lFormHwnd, tPt
                            With tButtonWinRect
                            BitBlt lFormDC, tPt.X, tPt.Y, .Right - .Left, .Bottom - .Top, _
                            GetProp(TempArray(10), "ButtonPressed"), 0, 0, SRCCOPY
                            oForm.Repaint
                            End With
                            Application.OnTime Now, " 'EventMacro " & Chr(34) & TempArray(0) & Chr(34) & _
                            ", " & Chr(34) & EventAction & Chr(34) & ", " & Chr(34) & tButtonXYCoords.X & Chr(34) & ", " & _
                            Chr(34) & tButtonXYCoords.Y & Chr(34) & ", " & Chr(34) & TempArray(10) & Chr(34) & " ' "
                        End If
                        Exit For
                    End If
                Next i
            End If
            
        Case WM_SETCURSOR
            GetCursorPos tCursorPos
            ScreenToClient hWnd, tCursorPos
            If PtInRegion(hFormMinusButtonsRegion, tCursorPos.X, tCursorPos.Y) <> 0 Then
            bToollTipDelayExists = False
                lCurrentRGN = 0
                If CBool(IsWindow(hwndToolTip)) Then
                 Call DestroyToolTip
                End If
                If bStreching = True Then
                    bStreching = False
                    oForm.Repaint
                End If
            End If
                
        Case WM_MOVE
            For i = 1 To UBound(sButtonsAttributesArray)
                TempArray = Split(sButtonsAttributesArray(i), Chr(1))
                GetWindowRect TempArray(10), tButtonWinRect
                DeleteObject TempArray(12)
                With tButtonWinRect
                    TempArray(12) = CreateEllipticRgn _
                    (.Left, .Top, .Right, .Bottom)
                End With
                sButtonsAttributesArray(i) = Join(TempArray, Chr(1))
            Next i

        Case WM_EXITSIZEMOVE
            SendMessage hWnd, ByVal WM_SETREDRAW, ByVal 1&, 0&

        Case WM_ERASEBKGND
            Call GetWindowRect(hWnd, tFormRect)
            With tFormRect
                If .Right > GetSystemMetrics(SM_CXSCREEN) Or .Left < 0 Or _
                .Bottom > GetSystemMetrics(SM_CYSCREEN) Or .Top < 0 Then
                    SendMessage hWnd, ByVal WM_SETREDRAW, ByVal 0&, 0&
                End If
            End With
            
        Case WM_DESTROY
            Call unHookTheForm
            RemoveCBTHook
            hHook = 0
            bAnErrorHasOccurred = False
            GetClientRect hWnd, tFormClientRect
            InvalidateRect hWnd, tFormClientRect, 0
            For i = 1 To UBound(sButtonsAttributesArray)
                TempArray = Split(sButtonsAttributesArray(i), Chr(1))
                DeleteObject TempArray(12)
                DestroyWindow TempArray(10)
            Next i
            Erase TempArray
            Call CleanUp
    End Select
    #If VBA7 Then
    FormWinProc = CallWindowProc _
    (GetWindowLong(Application.hWnd, GWL_USERDATA), _
    GetProp(Application.hWnd, "FormHwnd"), uMsg, wParam, lParam)
    #Else
    FormWinProc = CallWindowProc _
    (GetWindowLong(Application.hWnd, GWL_USERDATA), _
    GetProp(Application.hWnd, "FormHwnd"), uMsg, wParam, lParam)
    #End If
End Function

Private Sub CleanUp()
    Erase sButtonsAttributesArray
    DestroyWindow hwndToolTip
    ReleaseDC lFormHwnd, lFormDC
    DeleteDC lButtonReleasedMemDC
    DeleteDC lButtonPressedMemDC
    DeleteObject hFormMinusButtonsRegion
    bStreching = False
    iBoutonsCounter = 0
    hwndToolTip = 0
    hFormMinusButtonsRegion = 0
    lCurrentRGN = 0
    Set oForm = Nothing
End Sub

#If VBA7 Then
Private Function ButtonWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim Atom_ID As LongPtr
#Else
Private Function ButtonWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim Atom_ID As Long
#End If
    Dim sBuffer As String
    Dim lRet As Long
    Dim LOWORD As Long, HIWORD As Long
    Dim OffsetX, OffsetY As Long
    
    On Error Resume Next
    Select Case uMsg
        Case WM_NCHITTEST
            GetHiLoword CLng(lParam), LOWORD, HIWORD
            tButtonXYCoords.X = LOWORD
            tButtonXYCoords.Y = HIWORD
            lCurrentRGN = GetProp(hWnd, "RGN")
            ScreenToClient hWnd, tButtonXYCoords
            If PtVisible(GetDC(hWnd), tButtonXYCoords.X, tButtonXYCoords.Y) <> 0 Then
                If Not CBool(IsWindow(hwndToolTip)) And bToollTipDelayExists = False Then
                    sBuffer = Space(256)
                    Atom_ID = GetProp(hWnd, "ToolTipTextAndEventMacro_Atom")
                    lRet = GlobalGetAtomName(CInt(Atom_ID), sBuffer, Len(sBuffer))
                    sBuffer = Left(sBuffer, lRet)
                    sBuffer = Split(sBuffer, Chr(1))(0)
                    If Len(Left(sBuffer, lRet)) > 0 Then
                    OffsetX = IIf(GetProp(hWnd, "DoNotStretch") = 0, 15, -15)
                    OffsetY = IIf(GetProp(hWnd, "DoNotStretch") = 0, 2, -2)
                        Call ShowToolTip(Left(sBuffer, lRet), _
                        CLng(GetProp(hWnd, "ButtonLeft")), CLng(GetProp(hWnd, "ButtonTop")), _
                        CLng(GetProp(hWnd, "ButtonRight")), CLng(GetProp(hWnd, "ButtonBottom")), OffsetX, OffsetY, 5)
                            If GetProp(hWnd, "Beep") = 1 Then
                                MessageBeep MB_ICONASTERISK
                            End If
                        bToollTipDelayExists = True
                    End If
                End If
                If GetProp(hWnd, "DoNotStretch") = 0 Then
                    If Not bStreching Then
                        bStreching = True
                        DoEvents
                        StretchButton hWnd
                        DoEvents
                    End If
                End If
            End If
        Case WM_NCDESTROY
            #If VBA7 Then
             Call SetWindowLong(hWnd, GWL_WNDPROC, GetWindowLong(hWnd, GWL_USERDATA))
            #Else
             Call SetWindowLong(hWnd, GWL_WNDPROC, GetWindowLong(hWnd, GWL_USERDATA))
            #End If
            DestroyWindow hWnd
    End Select
    #If VBA7 Then
    ButtonWinProc = CallWindowProc(GetWindowLong(hWnd, GWL_USERDATA), _
    hWnd, uMsg, wParam, lParam)
    #Else
        ButtonWinProc = CallWindowProc(GetWindowLong(hWnd, GWL_USERDATA), _
    hWnd, uMsg, wParam, lParam)
    #End If
End Function

#If VBA7 Then
Private Function ToolTipWinProc _
(ByVal hWnd As LongPtr, ByVal uMsg As Long, _
ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim hDC, hOldFont, hFont, hBrush As LongPtr
#Else
Private Function ToolTipWinProc _
(ByVal hWnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim hDC, hOldFont, hFont, hBrush As Long
#End If
    Dim tPS As PAINTSTRUCT
    Dim tFont As LOGFONT
    Dim tFillLB As LOGBRUSH
    Dim tToolTipClientRect As RECT
    
    Select Case uMsg
        Case WM_PAINT
            BeginPaint hWnd, tPS
                GetClientRect hWnd, tToolTipClientRect
                hDC = GetDC(hWnd)
                SetMapMode hDC, 1
                SetBkMode hDC, 1
                With tFont
                    .lfFaceName = "Tahoma" & Chr$(0)
                    .lfHeight = 16
                    .lfWidth = 6 '
                End With
                hFont = CreateFontIndirect(tFont)
                hOldFont = SelectObject(hDC, hFont)
                tFillLB.lbColor = GetSysColor(COLOR_INFOBK)
                hBrush = CreateBrushIndirect(tFillLB)
                FillRect hDC, tToolTipClientRect, hBrush
                Call DeleteObject(hBrush)
                DrawEdge hDC, tToolTipClientRect, EDGE_ETCHED, BF_RECT
                SetTextColor hDC, GetSysColor(COLOR_INFOTEXT)
                DrawText _
                hDC, sToolTipText, Len(sToolTipText), tToolTipClientRect, _
                DT_NOCLIP + DT_LEFT + DT_EDITCONTROL + DT_WORDBREAK
                RedrawWindow hWnd, ByVal 0&, ByVal 0&, RDW_INTERNALPAINT
                DeleteObject hFont
                ReleaseDC 0, hDC
            EndPaint hWnd, tPS
            #If VBA7 Then
            Call SetWindowLong(hWnd, GWL_WNDPROC, lToolTipPrevWndProc)
            #Else
            Call SetWindowLong(hWnd, GWL_WNDPROC, lToolTipPrevWndProc)
            #End If
    End Select
    ToolTipWinProc = CallWindowProc(lToolTipPrevWndProc, hWnd, uMsg, wParam, lParam)
End Function

Private Sub InstallCBTHook()
    If hHook = 0 Then
        hHook = SetWindowsHookExW(WH_CBT, AddressOf CBTProc, 0, GetCurrentThreadId)
    End If
End Sub

Private Sub RemoveCBTHook()
    Call UnhookWindowsHookEx(hHook)
    hHook = 0
End Sub

#If VBA7 Then
Private Function EnumChildProc(ByVal hWnd As LongPtr, ByVal lParam As Long) As Long
#Else
Private Function EnumChildProc(ByVal hWnd As Long, ByVal lParam As Long) As Long
#End If
    DestroyWindow hWnd
    EnumChildProc = 1
End Function


#If VBA7 Then
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As LongPtr
    Dim lCurrentStyle As LongPtr
#Else
Private Function CBTProc(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Dim lCurrentStyle As Long
#End If
    Dim sBuffer As String
    Dim lRet As Long
 
    Select Case nCode
        Case HCBT_ACTIVATE
            sBuffer = Space(255)
            lRet = GetWindowText(wParam, sBuffer, Len(sBuffer))
            #If VBA7 Then
            lCurrentStyle = GetWindowLong(wParam, GWL_STYLE)
            #Else
            lCurrentStyle = GetWindowLong(wParam, GWL_STYLE)
            #End If
            If lCurrentStyle And DS_MODALFRAME Then
                If InStr(1, Left(sBuffer, lRet), "Microsoft Visual Basic") > 0 Then
                    Call RemoveCBTHook
                    bAnErrorHasOccurred = True
                End If
            End If
    End Select
    CBTProc = CallNextHookEx(hHook, nCode, wParam, lParam)
End Function

Private Sub MonitorErrors()
    If bAnErrorHasOccurred Then
        EnumChildWindows lFormHwnd, AddressOf EnumChildProc, ByVal 0&
        Call unHookTheForm
    End If
End Sub

Private Function DarkenColor(ByVal lColor As Long) As Long
    Dim R As Integer, g As Integer, B As Integer, i As Integer
    R = lColor And &HFF
    g = (lColor \ &H100) And &HFF
    B = lColor \ &H10000
    For i = 1 To 96
        If R - 1 > -1 Then R = R - 1
        If g - 1 > -1 Then g = g - 1
        If B - 1 > -1 Then B = B - 1
    Next i
    DarkenColor = RGB(R, g, B)
End Function

Private Function LightenColor(ByVal lColor As Long) As Long
    Dim R As Integer, g As Integer, B As Integer, i As Integer
    R = lColor And &HFF
    g = (lColor \ &H100) And &HFF
    B = lColor \ &H10000
        R = R + 96
        g = g + 96
        B = B + 96
    LightenColor = RGB(R, g, B)
End Function

Private Sub GetHiLoword _
(Param As Long, ByRef LOWORD As Long, ByRef HIWORD As Long)
    LOWORD = Param And &HFFFF&
    HIWORD = Param \ &H10000 And &HFFFF&
End Sub

Private Function LongToUShort(Unsigned As Long) As Integer
    LongToUShort = CInt(Unsigned - &H10000)
End Function


'******************************************************
'            USERFORM CODE USAGE EXAMPLE
'******************************************************
'Private Sub UserForm_Activate()
'    'Add first round button using named arguments:
'    Call AddRoundButton( _
'        Form:=Me, _
'        ButtonName:="Button1", _
'        Left:=320, _
'        Top:=20, _
'        Width:=50, _
'        Height:=50, _
'        Caption:="Hello !", _
'        FontColor:=vbBlack, _
'        BackColor:=Me.BackColor, _
'        TooltipText:= _
'        "This is a long tooltip text demo to show that the tooltip automatically adjusts its size in order to accomodate the whole text.", _
'        ToolTipBeep:=True, _
'        AnimateButton:=False, _
'        EventMacro:="Buttonevents" _
'    )
'
'    'Add rest of the buttons without named arguments
'    Call AddRoundButton(Me, "Button2", 130, 30, 100, 50, "Click Me", vbYellow, vbRed, , , , "ButtonEvents")
'    Call AddRoundButton(Me, "Button3", 130, 120, 120, 50, "Elliptical button", vbBlue, , "hello!", True, True, "ButtonEvents")
'    Call AddRoundButton(Me, "Button4", 250, 0, 60, 88, , vbYellow, RGB(200, 10, 200), "ToolTip Text.", , , "ButtonEvents")
'    Call AddRoundButton(Me, "Button5", 30, 130, 60, 60, "Click Me", vbBlue, vbCyan, , , , "ButtonEvents")
'    Call AddRoundButton(Me, "Button6", 80, 200, 40, 40, "hey", vbMagenta, , "This is an API based round Button.", True, True, "ButtonEvents")
'    Call AddRoundButton(Me, "Button7", 280, 120, 60, 60, "Click Me", vbRed, RGB(120, 200, 150), "This is an API based round Button.", True, True, "ButtonEvents")
'    Call AddRoundButton(Me, "Button8", 320, 180, 60, 80, "Click Me", vbRed, vbYellow, "This is an API based round Button.", True, True, "ButtonEvents")
'    Call AddRoundButton(Me, "Button9", 30, 15, 80, 80, "MrExcel", , vbGreen, "This Button swells when the mouse pointer is placed over it.", , True, "ButtonEvents")
'End Sub
'
'
'
''This is the generic event macro for all the buttons ... (MUST be Public!!)
''The name of this event macro is optionally passed in the last argument of the AddRoundButton Sub
'Public Sub ButtonEvents(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, _
'ByVal CurXPos As Long, ByVal CurYPos As Long)
'
'    'Click code:
'    If SoughtEvent = ClickEvent Then
'        MsgBox "You Clicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
'    End If
'
'    'RightClick code:
'    If SoughtEvent = BeforeRightClick Then
'    MsgBox "You RightClicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
'    End If
'
'    'Mouse Down code:
'    If SoughtEvent = MouseMoveEvent Then
'    ' other code here...
'    End If
'End Sub

2- الكود على القورم موديل

Option Explicit

Private Sub UserForm_Activate()
    'Add first round button using named arguments:
    Call AddRoundButton( _
        Form:=Me, _
        ButtonName:="Button1", _
        Left:=320, _
        Top:=20, _
        Width:=50, _
        Height:=50, _
        Caption:="Hello !", _
        FontColor:=vbBlack, _
        BackColor:=Me.BackColor, _
        TooltipText:= _
        "This is a long tooltip text demo to show that the tooltip automatically adjusts its size in order to accomodate the whole text.", _
        ToolTipBeep:=True, _
        AnimateButton:=False, _
        EventMacro:="Buttonevents" _
    )
    
    'Add rest of the buttons without named arguments
    Call AddRoundButton(Me, "Button2", 130, 30, 100, 50, "Click Me", vbYellow, vbRed, , , , "ButtonEvents")
    Call AddRoundButton(Me, "Button3", 130, 120, 120, 50, "Elliptical button", vbBlue, , "hello!", True, True, "ButtonEvents")
    Call AddRoundButton(Me, "Button4", 250, 0, 60, 88, , vbYellow, RGB(200, 10, 200), "ToolTip Text.", , , "ButtonEvents")
    Call AddRoundButton(Me, "Button5", 30, 130, 60, 60, "Click Me", vbBlue, vbCyan, , , , "ButtonEvents")
    Call AddRoundButton(Me, "Button6", 80, 200, 40, 40, "hey", vbMagenta, , "This is an API based round Button.", True, True, "ButtonEvents")
    Call AddRoundButton(Me, "Button7", 280, 120, 60, 60, "Click Me", vbRed, RGB(120, 200, 150), "This is an API based round Button.", True, True, "ButtonEvents")
    Call AddRoundButton(Me, "Button8", 320, 180, 60, 80, "Click Me", vbRed, vbYellow, "This is an API based round Button.", True, True, "ButtonEvents")
    Call AddRoundButton(Me, "Button9", 30, 15, 80, 80, "MrExcel", , vbGreen, "This Button swells when the mouse pointer is placed over it.", , True, "ButtonEvents")
End Sub



'This is the generic event macro for all the buttons ... (MUST be Public!!)
'The name of this event macro is optionally passed in the last argument of the AddRoundButton Sub
Public Sub ButtonEvents(ByVal ButtonName As String, ByVal SoughtEvent As E_V_E_N_T, _
ByVal CurXPos As Long, ByVal CurYPos As Long)

    'Click code:
    If SoughtEvent = ClickEvent Then
        MsgBox "You Clicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
    End If
    
    'RightClick code:
    If SoughtEvent = BeforeRightClick Then
    MsgBox "You RightClicked : " & ButtonName & vbCr & "Mouse XPos: " & CurXPos & vbCr & "Mouse YPos: " & CurYPos
    End If
    
    'Mouse Down code:
    If SoughtEvent = MouseMoveEvent Then
    ' other code here...
    End If
End Sub

Private Sub CommandButton1_Click()
    Unload Me
End Sub

يناير 17, 2016

السلام عليكم

الأستاذ نحنود غباشي

للاسف اذا بحثت عن 30 تأتي 300 و 3000 الخ ... لا يخطر ببالي حل لهذه المشكلة لأن الكود يعتمد على SendKeys و ليس على ال Excel Object Model

الأستاذ ياسر

الكود يحافظ على خاصية ال Undo-Redo لكنه ليس دقيقا و لا مأمونا مائة في المائة

ربما اضافة Application.EnableEvents = False يساعد شوية كالتالي

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
#Else
    Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    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 GetDesktopWindow Lib "user32" () As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
#End If
    
Private Const WM_SETREDRAW = &HB
Private Const VK_CAPSLOCK = &H14
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private oInpuCell As Range

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.GoTo FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{R}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Public Sub ShowAllRecords(ByVal FilterRange As Range)
    On Error GoTo ErrHandler
    Application.EnableEvents = False
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.GoTo FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{C}"
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    Application.EnableEvents = True
End Sub

Private Sub FilterNow()
    On Error GoTo ErrHandler
    KillTimer Application.hwnd, 0
    keybd_event vbKeyReturn, 0, 0, 0
    keybd_event vbKeyReturn, 0, KEYEVENTF_KEYUP, 0
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Private Sub RefreshScreen()
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    SendKeys "{NUMLOCK}", True
    SendKeys "{NUMLOCK}", True
    oInpuCell.Select
    Application.EnableEvents = True
End Sub

يناير 16, 2016

جربوا الملف في الرابط أدناه

https://app.box.com/s/8lzxirs3i6d8jpci9xe809az7odf5ngh

يناير 16, 2016

السلام عليكم

ما هي نسخة الويندوز و نسخة الأوفيس التي تشتغل عليهما

يناير 15, 2016

أسف نسيت أنني أشتغل على نسخة الاكسيل باللغة الفرنسية و بالتالي ال Filter Box ShortCuts مختلفة عن الانجليزية

المرجو القيام باستبدال كود الماكرو FilterRecords بالكود التالي (لاحظ التغيير باللون الأحمر)

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
On Error GoTo ErrHandler
Set oInpuCell = InputCell
If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
Application.Goto FilterRange.Cells(1)
Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
SendKeys "%{DOWN}"
SendKeys "+{E}"
SendKeys oInpuCell
SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
Exit Sub
ErrHandler:
Call RefreshScreen
End Sub

الكود المعدل

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{E}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

باقي الكود يبقى كما هو

يناير 15, 2016

أستاذي الكريم ياسر

أنا أعمل على ويندوز 10 64 بت والأوفيس 2010 64 بت و الكود يعمل جيدا عندي

استعمال ال SendKeys ليس أمنا و غالبا ما يسبب المشاكل ... على أي حال لننتظر الأستاذ محمود و لنرى هل سيعمل الكود عنده

يناير 15, 2016

السلام عليكم

أخي الحبيب ياسر

شكرا على مرورك الكريم ... تمنيت لو كان لدي الوقت لكي أشارك بانتظام أكثر

أستاذ محمود غباشي

حاولت أن أجد حلا للمشكلة و هذا أقصى ما يمكن فعله ... الكود يشتغل عندي فهو يقوم بفلترة القائمة تلقائيا عند تغيير قيمة الخلية A3 مع الحفاظ على خاصية ال Undo-Redo كما هو مطلوب

يبقى مشكل بسيط لا يحله الكود و هو مثلا في حالة ادخال القيمة 30 في الخلية A3 فان القائمة المفلترة تظهر أيضا الخلايا التي تحتوي على قيمة 300 ... أرجو ألا يشكل هذا عائقا كبيرا

تفضل الملف للتحميل:

https://app.box.com/s/om3uu0y2pjilzeybd37cvedxst8j413c

أما الكود الذي استعملته فهو كالتالي:

1- الكود في محرر ورقة العمل Sheet1:

Option Explicit
'change below Constsnates as required
'************************************
Private Const InputCellAddress As String = "A3"
Private Const FilterRangeAddress As String = "A5:A1000"

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim lRes As Long
    On Error Resume Next
    If Target.Address(False, False) = InputCellAddress Then
        If Me.AutoFilterMode = True Then
            If Target.Value <> "" Then
                lRes = Application.WorksheetFunction.Match(Target, Application.Transpose(Range(FilterRangeAddress)), 0)
                If Err.Number = 0 Then
                    Call FilterRecords(Range(FilterRangeAddress), Target)
                End If
            Else
                    If Range(FilterRangeAddress).SpecialCells(xlCellTypeVisible).Rows.Count <> _
                        Range(FilterRangeAddress).Rows.Count And Err.Number = 0 Then
                        Call ShowAllRecords(Range(FilterRangeAddress))
                    End If
            End If
        End If
    End If
End Sub

2- الكود في موديول عادي

Option Explicit

#If VBA7 Then
    Private Declare PtrSafe Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
    Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As Long) As Long
    Private Declare PtrSafe Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
    Private Declare PtrSafe Function InvalidateRect Lib "user32" (ByVal hwnd As LongPtr, ByVal lpRect As Long, ByVal bErase As Long) As Long
#Else
    Private Declare Sub keybd_event Lib "user32.dll" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
    Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
    Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
    Private Declare Function GetKeyState Lib "user32.dll" (ByVal nVirtKey As Long) As Integer
    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 GetDesktopWindow Lib "user32" () As Long
    Private Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, ByVal lpRect As Long, ByVal bErase As Long) As Long
#End If
    
Private Const WM_SETREDRAW = &HB
Private Const VK_CAPSLOCK = &H14
Private Const KEYEVENTF_EXTENDEDKEY = &H1
Private Const KEYEVENTF_KEYUP = &H2
Private oInpuCell As Range

Public Sub FilterRecords(ByVal FilterRange As Range, ByVal InputCell As Range)
    On Error GoTo ErrHandler
    Set oInpuCell = InputCell
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{R}"
    SendKeys oInpuCell
    SetTimer Application.hwnd, 0, 1, AddressOf FilterNow
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Public Sub ShowAllRecords(ByVal FilterRange As Range)
    On Error GoTo ErrHandler
    If GetKeyState(VK_CAPSLOCK) = 1 Then SendKeys "{CAPSLOCK}", True
    Application.Goto FilterRange.Cells(1)
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, False, 0&)
    SendKeys "%{DOWN}"
    SendKeys "+{C}"
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
End Sub

Private Sub FilterNow()
    On Error GoTo ErrHandler
    KillTimer Application.hwnd, 0
    keybd_event vbKeyReturn, 0, 0, 0
    keybd_event vbKeyReturn, 0, KEYEVENTF_KEYUP, 0
    Application.OnTime Now, "RefreshScreen"
    Exit Sub
ErrHandler:
    Call RefreshScreen
End Sub

Private Sub RefreshScreen()
    Call SendMessage(GetDesktopWindow, WM_SETREDRAW, True, 0&)
    InvalidateRect 0, 0, 0
    SendKeys "{NUMLOCK}", True
    SendKeys "{NUMLOCK}", True
    oInpuCell.Select
End Sub

يناير 14, 2016

السلام عليكم

أستاذ محمود غباشي

ان خاصية ال Undo-Redo دائما تتوقف عن العمل في اكسيل كلما تم تنفيذ أي كود يقوم بتغيير محيط الاكسيل مثل تغيير محتوى الخلايا أو الألوان أو الفلترة و غيرها ... و هذا مشكل معروف في الاكسيل يشتكي منه الكثيرون

الحل الوحيد الذي يخطر ببالي هو اجراء التغييرات ( أي الفلترة في هذه الحالة) بواسطة ال SendKeys

لو عندي وقت سأكتب الكود و أنشره هنا

ديسمبر 16, 2015

شكرا على الموضوع الجميل

للتذكير فقط يمكن فك حماية ملف الاكسيل المعمول بهده الطريقة عن طريق VB/VBA كود عندما يكون هذا الملف مفنوحا حتى لو ظل ملف الاكيسل هذا مخفيا على طول ... الكود سيعمل نسخة للملف (.SaveCopyAs) و يحفظ النسخة الجديدة في الديسك ثم يفك الباسوورد ... طبعا هذا الأمر يتطلب بعضا من المعرفة من طرف المسخدم و اصراره على فك شفرة الملف

ملاحظة ثانية

هل فكرت في تحويل ملف الاكسيل الى ADS File و الضاقه في ال exe File

الفائدة من ال ADS fILE هي أنك تحتاج ملف ال EXE فقط و لا تحتاج ملف البيانات منفصل

ديسمبر 13, 2015

السلام عليكم

بامكانك تحقيق المراد بسهولة عن طريق Boolean Flag

هل ممكن تحميل نسخة للملف

نوفمبر 12, 2015

19 دقائق مضت, الـعيدروس said:

اضن عبر دالة GetCursorPos

محاولات لم تنجح

api ليس لها الا جعفر الطريبق بارك الله فيه

شكرا على مرورك يا استاذ العيدروس

تعم ال API ممكن أن تحل هذه المشكلة بسهوله لكنها تحتاج الى تنفيذ الكود داخل حلقة تكرارية أو داخل API Timer و في كلتا الحالتين الكود سيبطئ و يثقل الاكسيل ... أنا أحاول اجتناب هذا الأمر و التفكير في طريقة أخرى أقل تكلفة و وقغ على الاكسيل

نوفمبر 12, 2015

عملت ملف جديد مبني على قكرة الليبل و ال Grouping التي تفضل بها الاستاذ مختار ... لاحظت أن عند جر أو تحريك ال Shape من مكان لأخر فان حجم الليبل يتغير

فكرة الليبل و ال Grouping جميلة لكن لو أردنا اضافة الليبل عن طريق ال VBA هنالك مشكل و هو أن ال VBA Project سيعمل RESET و تضيغ كل ال Varaibles

تسجيل الدخول

المنتدى

مكتبة الموقع

معرض الصور

المدونات

الوسائط المتعددة

مشاركات المكتوبه بواسطه جعفر الطريبق

Important Information