جعفر الطريبق

السلام عليكم. أفتقد هذا المنتدى لأنني لم أزوره منذ فترة طويلة. كما هو معلوم خاصية التمرير باستخدام عجلة الماوس غير متاحة على اليوزرفورم رغم أنها خاصية مهمة ومطلوبة . لقد كتبت مؤخرا هذا الكود لحل هذه المشكلة ... الكود عام ويشتغل على يوزرفومات متعددة . الكود سهل الاستعمال حيث يمنح للمستعمل الحدث التالي الذي يكون موجودا داخل موديول الفورم والذي يعطي للمستعمل كل التحكم ملف للتحميل تعريف الحدث هو كالتالي: 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 أتمنى أن يكون الكود مفيدا وإذا وجدت أي مشكلة ، فيرجى إبلاغي بذلك. وأخيرا أتقدم بسلام خاص للأستاذ الفاضل ياسر خليل من مصر الحبيبة الذي عرفني بهذا المنتدى

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

مثلا 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

برنامج اكسيل لا يتوفر على حدث النقر على الخلايا بالزر الأيسر. الكود التالي كنت قد كتبته قبل فترة وعدلته بعض الشيئ لكي يشتغل فقط عندما ينقر المستخدم بالزر الأيسر على الخلايا الموجودة في العمود 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

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 عفوا لم أقرأ السوأل جيدا ... ظننت أنك طلب نتفيذ الكود عند النقر بازر الأيمن لكن سأحاول كتابة الكود المطلوب يعني عند النقر على الخلية بالزر الايسر ونشره هنا لتعميم الفائدة

ليس هنالك حدث عند الخروج من خلية لكن يمكن تحقيق ما طلبته بشئ من الكود أضف الكود التالي الى 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 الموجودتان في أعلا الكود حسب الاحتياج

السلام عليكم من المعروف أن الاكسل يسمح باضافة صورة خلفية لورقة العمل عن طريق 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 ملف للتحميل

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

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

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

السلام عليكم السكرول بعجلة الماوس غير ممكن مع الفورم أو الكنترولات ... الكود التالي يفتح هذه الامكانية وهو كود جامع موحد ملف للتحميل 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

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

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

السلام عليكم قبل فترة كتات هذا الكود على الويندوز 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

السلام عليكم الأستاذ نحنود غباشي للاسف اذا بحثت عن 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

جربوا الملف في الرابط أدناه https://app.box.com/s/8lzxirs3i6d8jpci9xe809az7odf5ngh

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

أسف نسيت أنني أشتغل على نسخة الاكسيل باللغة الفرنسية و بالتالي ال 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 باقي الكود يبقى كما هو

أستاذي الكريم ياسر أنا أعمل على ويندوز 10 64 بت والأوفيس 2010 64 بت و الكود يعمل جيدا عندي استعمال ال SendKeys ليس أمنا و غالبا ما يسبب المشاكل ... على أي حال لننتظر الأستاذ محمود و لنرى هل سيعمل الكود عنده

السلام عليكم أخي الحبيب ياسر شكرا على مرورك الكريم ... تمنيت لو كان لدي الوقت لكي أشارك بانتظام أكثر أستاذ محمود غباشي حاولت أن أجد حلا للمشكلة و هذا أقصى ما يمكن فعله ... الكود يشتغل عندي فهو يقوم بفلترة القائمة تلقائيا عند تغيير قيمة الخلية 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

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

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

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

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

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