نجوم المشاركات

الاخ سليم حاصبيا انك انسان مؤدب هذه هي القواعد القديمة التي نفتقدها

مرحبا و الله اخي عادل كلامك صحيح لكنني اعتمدت على ما قاله الاخ ابو بسمة ما يهمه هو عدد مرات البيع اما النوع فلا يهم هذا حسب فهمي للسؤال و ان كان هناك طرح آخر ارجو من الاخ ابو بسمة ان يشرح أكثر جزاك الله خيرا

تهنئة بالترقية نبارك لأستاذنا الكريم: سليم حاصبيا المحترم انضمامه إلى فريق القمة في منتدانا العريق أوفيسنا نرجو لكم دوام التقدم والعطاء

اخي العزيز قصدك هكذ مثل هذا المثال المرفق ؟؟! Database1.rar

سليم حاصبيا اخى الفاضل تحياتى و ايام مباركه تعودنا ان يكون هناك هديه مع الترقيه مبنحبش العيديه تكون ناشفه ياسر خليل أبو البراء _ عمر الحسيني _ أبو حنــــين مش كده ولا ايه فى الانتظار و كل عام و انتم بخير

وعليكم السلام أخي محمد ملفك يعمل بشكل ممتاز ولا مشكلة فيه عندي حاول توضح ما هي رسالة الخطأ التي تظهر لديك؟ انقر على كلمة Debug ثم انسخ سطر المشكلة إلى المشاركة أو صور المشكلة لتتضح الصورة الخطوات التي قمت بها صحيحة إن شاء الله والكود يعمل وإليك الدليل 2016-09-08_07-06-01.rar

السّلام عليكم و رحمة الله و بركاته ألف ألف مبروك التّرقيّة المستحقّة لأستاذنا الفاضل " سليم حاصبيا " مجهودات جبّارة لا ينكرها إلاّ جاحد طالما خدم الجميع بها بها تحت راية هذا الملتقى و هذا المنتدى التّعليمي الكبير وفّقك الله و سدّد خطاك و مزيد من النّجاحات في كل المجالات إن شاء الله فائق إحتراماتي

الساده / أعضاء المنتدى المحترمين سلام الله عليكم جميعا ورحمته وبركاته قمت بعمل تجميع لعديد من البرامج الجاهزة وقد قمت بتجميعها من خلال البحث فى المنتدى فسامحونى إن كنت نسيت نموذج لأحد الأساتذه الأعضاء نتمنى من الله عز وجل أن ينتفع بها الجميع تلك البرامج و النماذج القيمه هى مجهود للساده الأعضاء بارك الله فيهم وزادهم الله من فضله وجزاهم رب العالمين عنا خير الجزاء وبرامج ونماذج قاموا بتنفيذها بناء على طلبات من الساده الأعضاء وتقبلوا منى وافر الإحترام والتقدير أخيكم فى الله محمود الشريف وإليكم النماذج برنامج متابعه حركة السيارات للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=49733#entry303008 برنامج مصاريف سيارات وأرصده للأستاذ / محمد مصطفى أبو حمزة http://www.officena.net/ib/index.php?showtopic=46058#entry273859 برنامج مراقبة خطابات الضمان للاستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=38044#entry209393 برنامج نظام حركة المستودعات ومتابعة المخزون للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=38870#entry213211 برنامج للعيادات الطبية للأستاذ / مدحت http://www.officena.net/ib/index.php?showtopic=32830#entry169369 برنامج السكرتير الخاص للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=42018#entry239414 برنامج للأقساط _ مجهود مشترك بين الأستاذ / حسام والأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=46619#entry279457 تعديل للبرنامج السابق للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=46619#entry279481 تعديل للبرنامج السابق للاستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=46619#entry279786 برنامج أقساط الإصدار الأول للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=29892#entry148900 برنامج أقساط الإصدار الثانى للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=29892#entry149116 برنامج أقساط الإصدار الثالث للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=29892#entry149553 برنامج أقساط الإصدار الرابع للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=29892#entry150361 برنامج متابعة الوثائق للأستاذ / الجزيرة http://www.officena.net/ib/index.php?showtopic=31712#entry161472 برنامج لقاعده بيانات عمل مشترك بين الأستاذ / قارى _ والأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=44485#entry259617 نموذج أقساط للأستاذ /سايق الخير http://www.officena.net/ib/index.php?showtopic=38538#entry210055 قام بالتعديل عليه الأستاذ / عبد الله المجرب http://www.officena.net/ib/index.php?showtopic=38538#entry210056 قام بالتعديل عليه الأستاذ / بن عليه حاجى http://www.officena.net/ib/index.php?showtopic=38538#entry210084 برنامج المخزون الإصدار الأول للأستاذ / عمرو http://www.officena.net/ib/index.php?showtopic=41247#entry233101 برنامج المخزون الإصدار الثانى للأستاذ / عمرو http://www.officena.net/ib/index.php?showtopic=43332#entry250295 برنامج المخزون الإصدار الثالث للأستاذ / عمرو 2010 http://www.officena.net/ib/index.php?showtopic=46059#entry273864 برنامج المخزون الإصدار الثالث للأستاذ / عمرو 2007 : 2010 http://www.officena.net/ib/index.php?showtopic=46059#entry273864 برنامج مرتبات للقطاع الخاص للأستاذ / سعيد بيرم http://www.officena.net/ib/index.php?showtopic=41465#entry240172 برنامج الصادر والوارد _ الإتصالات الإدارية للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=46813#entry281283 برنامج الإتصالات الإدارية الإصدار الأول للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=37265#entry199078 برنامج الإتصالات الإدارية الإصدار الثانى للأستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=37265#entry199224 برنامج الإتصالات الإدارية الإصدار الأخير للاستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=37265#entry199421 برنامج للتعامل مع طلبات الشراء والموردين للأستاذ / أبو عبد الله http://www.officena.net/ib/index.php?showtopic=30844#entry155312 برنامج حجز الغرف الفندقية عمل مشترك بين الأستاذ / هانى بدر والأستاذ / أبو عبد الله http://www.officena.net/ib/index.php?showtopic=39568&page=2#entry224762 برنامج حسابات المطاعم للأستاذ هانى بدر http://www.officena.net/ib/index.php?showtopic=32220&page=2#entry189567 برنامج دليل الهاتف الإصدار الثانى للأستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=27222#entry131055 برنامج فواتير منوع للأستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=26948#entry129215 برنامج حافظة شخصية دليل الهواتف للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=26211#entry124665 برنامج التقويم ( التاريخ ) للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=26155#entry124252 فاتورة للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=24322#entry113573 برنامج الفواتير كامل للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=24191#entry112811 برنامج سندات القبض والصرف للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=24191#entry112811 برنامج خبور المحاسبى برنامج كامل للأستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=17944#entry80465 برنامج خبور المحاسبى الإصدار الثالث للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=16879#entry74858 برنامج خبور الإصدار الثانى للأستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=16256#entry71834 برنامج خبور المحاسبى الإصدار الأول للأستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=15933#entry69998 برنامج حسابات للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=14978#entry65693 برنامج حسابات للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=14880#entry65142 برنامج حسابات للاستاذ / عبد الله باقشير http://www.officena.net/ib/index.php?showtopic=14619#entry63693 برنامج شراكة العقارات للاستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=49900#entry304640 برنامج الشيكات للاستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=50143#entry306916 برنامج كشوف حسابات ( منه له ) للاستاذ / أحمد زمان http://www.officena.net/ib/index.php?showtopic=50819#entry312828 معظم برامج شئون العاملين وما يتعلق بها لعديد من الأساتذة رابط تجميعى لـ محمود الشريف http://www.officena.net/ib/index.php?showtopic=51271&hl= نسخة تجريبية لنموذج شيك لـ محمود الشريف http://www.officena.net/ib/index.php?showtopic=51306#entry317305 برنامج لمتابعة أسعار الصرف ( العملات ) لـ محمود الشريف http://www.officena.net/ib/index.php?showtopic=51109#entry315286 برنامج متابعة حركة السيارات قابل للتعديل وبه امكانية متابعة الوثائق لـ / محمود الشريف http://www.officena.net/ib/index.php?showtopic=51386#entry318102 برامج ونماذج التنبيه لعديد من الأساتذة رابط تجميعى لـ محمود الشريف http://www.officena.net/ib/index.php?showtopic=51261&hl= برنامج دليل الهاتف المتطور للأستاذ / أحمد حمور http://www.officena.net/ib/index.php?showtopic=33881#entry176806 برنامج دليل الهاتف العصرى للأستاذ / أحمد حمور http://www.officena.net/ib/index.php?showtopic=34679&page=2#entry182322 برنامج دليل الهاتف على طريقة سامسونج للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=46463#entry277636 برنامج خاص لمحاسبة وجرد وصيانه الهواتف للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=48351#entry292775 برنامج تسيير الأشخاص للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=48251#entry292035 برنامج تسيير شركات النقل للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=47818#entry289335 برنامج تسيير شئون الموظفين للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=46153#entry274883 برنامج تتبع للمضيفين والآليات للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=45902#entry272143 برنامج الموردين للأستاذ / شوقى ربيع http://www.officena.net/ib/index.php?showtopic=45883#entry271941 برنامج ادارة الإيجارات الإصدار الأول للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=50382#entry309122 برنامج إدارة الخدمات المصرفية للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=51110#entry315312 برنامج إدارة الإشتراكات الشهرية للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=49929#entry304870 برنامج مستحقات نهاية الخدمة للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=47291#entry284873 برنامج سند صرف مع بيان الدفعات للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=49296#entry299662 برنامج كشف حساب للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=48492#entry293528 برنامج استمارة العائلة الإلكترونى للأستاذ / ضاحى الغريب http://www.officena.net/ib/index.php?showtopic=47555#entry287386 برامج الكنترول والمدارس لعديد من الأساتذة رابط تجميعى لـ محمود الشريف http://www.officena.net/ib/index.php?showtopic=51265&hl=

نرحب بالأخ سليم حاصبيا فى فريق الموقع ونسأل الله أن يعينك على مهام الاشراف أهلا وسهلا

احلى واغلى تحية لهذا الصرح العظيم وكل عام وانتم بخير وهذا المنتدى فى تقدم وازدهار

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

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة القائمة المنسدلة بدون فراعات تم ارفاق كود الحل من الفاضل ا / رحمه الله_ الحسامي _ هشام شلبى _ بن علية حاجي و لا تنسونا من صالح الدعاء تحياتى book_HOSSMI-new.rar _HISHAMمنسدلة بدون فراغات.rar _BEN ALYAهشام_عماد.rar

تحفة كودية ودروس كثيرة فى درس واحد من استاذنا الموهوب الكبير اووووووووى ياسر خليل ولى رجاء تم تعديل الملف ليحاكى الملف الاصلى للتيسيير وطبعاً اخوك عبقرى اكواد وكل حرف انا فهمة كويس بس عايز اشوف شرحك العبقرى على الكود بعد التعديل على الملف المرفق اتاكد من تطابق المعلومات البحث عن القيم المتعددة بعد التعديل3.rar

استاذ / ياسر اخليل أولاً أشكرك على الوصول الى الحل المطلوب و أدعو الله أن يوفقك أنت و كافة الإخوة و الأخوات في هذا المنتدى الذي يسعدني أن أتواجد به في ظل وجود أساتذة كبار فيه ثانيا يسعدني أن التزم بقوانين المنتدى و سوف أقوم بتغيير إسم العرض و أخيرا أقول لك شكرا مرة أخرى على وضع الحل الذي كنت أريد الوصل اليه أسال الله أن يوفقك في حياتك أنت و كافة الزملاء في هذا المنتدى أخوك / ابو بسمة

الاخ احمد ديدو تم عمل المطلوب وفي انتظار اكتشاف الاخطاء شاهد المرفق Omar_3.rar قبل البدء في قاعدة بيانات جديدة يجب حذف الدتا الموجدة بالاوراق التالية كود الصنف اضافة صنف صرف صنف حركة_المخزن في ورقة حركة_المخزن احظر حذف الخلايا التي بها معادلات ذات اللون اللبنى اما اوراق المخازن الخمسة لا تخذف شئ منها سوف يحدثها البرنامج تلقائيا ملحوظة في الموديول Module3 يوجد ماكر بأسم Copier اذا كان عندك بيانات جاهزة تم نسخها الي ورقة كود الصنف ولم يتم ادخالها عن طريق الفورم الخاص بتكويد الاصناف نفذ هذا الماكرو ليعمل علي ترحيلها الي ورقة حركة_المخزن تسهيلا لك يستخد هذا الكود مرة واحدة فقط تحياتي لك كل سنه انت طيب وكل اعضاء المنتدي الكرام طيبين وبخير اعادة الله علي الامة الاسلامية بالخير واليمن والبركات عيد سعيد

أخي الكريم أهلاً بك في المنتدى ونورت بين إخوانك وأسرتك وكل عام وأنت بخير يرجى تغيير اسم الظهور للغة العربية ، والإطلاع على التوجيهات في الموضوعات المثبتة في صدر المنتدى قم بتغيير النص الموجود في الخلية G22 إلى النص SV SKED ثم ضع المعادلة التالية في الخلية H22 =SUMPRODUCT((Table2[FLIGHT STATUS]=G22)*(Table2[GPU NO]<>"")) أرجو أن تفي بالغرض إن شاء المولى تقبل تحياتي

السلام عليكم الاستاذ الفاضل ابو حنين ارى ان الشرط الثانى الذى تم وضعة يتعامل مع ان الصنف لا يكون فارغ وهذا غير المطلوب بمعنى اذا تم وضع امام المندوب احمد فى السطر الاخير صنف اى فون6 ستظهر المعادلة 4 وهذا غير صحيح لانه تعامل مع 3 اصناف فقط وكل عام والاسرة الكريمة بكامل الصحة والعافية والستر

رغم انه لا يمكن الدخول في المنطقة التي يتواجد بها أخي سليم عندما يتعلق الامر بالدوال لكن جرب هذه الطريقة خفية قبل ان يكتشفنا 11.rar

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

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة زر ترحيل واحد بدلا من 4 ازارير ترحيل تم ارفاق كود الحل من الفاضل _ رحمه الله/ الحسامي و لا تنسونا من صالح الدعاء تحياتى 333-معدل (2).rar

ياسر خليل أبو البراء اخى الفاضل بارك الله فيك و اتمنى من الله لك مزيدا من الصحة و العافيه تحياتى

بارك الله فيك أخي الكريم جلال وجزيت خيراً صراحة الأعمال التي قدمها العمالقة أمثال الحسامي رحمه الله تحتاج لدراسة وفي بعض الأحيان تنقيح بسيط .. جربت الملف إذ أنني لا أحب أن أحمل الملف وحسب بل أقوم بالإطلاع عليه ودراسته دراسة متأنية للاستفادة منه قبل نقده وإذا تطلب الأمر تعديل أذكره لكي يستفيد الجميع هناك شرط إدخال البيانات غير سليم في الكود المقدم .. راجع الملف مرة أخرى وستتأكد من ذلك ولذا يجب التعديل على الشرط بالشكل التالي If (([U1] = 1 Or [U1] = 2) And a1 = "") Or (([U1] = 3 Or [U1] = 4) And (a1 = "" Or a2 = "")) Then MsgBox prompt:="تأكد من إدخال كافة البيانات", Title:="خطأ" Exit Sub End If تقبل تحياتي

السلام عليكم ورحمة الله وبركاته كنت اضافت مشاركة سابقا ولكن لا اعرف لماذا لم يتم اضافتها .. ما علينا سوف اكتبها مرة اخرى بداية انت تعرف ان الموظف طبقا للقانون يستحق خلال العام الاول فى الخدمة يستحق 15 يوم اعتيادى و7 عارضة ثم اجازة سنوية 21 يوم اعتيادى و 7 عارضة لاول 10 سنوات خدمة ثم يستحق 30 يوم اعتيادى و7 عارضة لاكثر من 10 سنوات خدمة ثم يستحق 45 يوم اعتيادى و7 عارضة بعد سن الخمسين .. تمام ما رأيك يا اباجودى لو اضفنا فى بيانات الموظف حقل يسمى تاريخ ميلاد الموظف او العامل وحقل تاريخ الالتحاق بالعمل وبناءً عليها بشكل اتوماتيك يتم منحها الاجازة التى يستحقها هذه مجرد بداية .. وانا معك اذا ارات التنفيذ تحياتى وهناك بعض الاضافات الاخري سوف ياتى وقتها

بارك الله فيك اخي العزيز محمد ابا جودي علي ماتقدمه وكل عام وانت بخير

وعسى الجنة مثواكم

الف مبروك اخى سليم وفقكم الله لما يحبه ويرضاه تمنياتى لك وللجميع بالتوفيق

تهنئة قلبية بقرب حلول عيد الأضحى المبارك إلى كل عضو كريم في منتدانا العريق أوفيسنا نرجو الله أن يعيده على الأمة الإسلامية جمعاء بالخير واليمن والبركة

ابو حنين تقبل تحياتى على هذا العمل الرائع قفمن اليوم اسمحلى ان اطلق عليك لقب "قاهر الفلترة فى الاكسل " تقبل تحياتى

تم عمل المطلوب 5555.rar

كل عام وانت بخير اخي الكريم جلال وكل عام وجميع الامة الاسلامية بخير

مبارك - نحسبه على خير - سباق بالاجابة - عالم بالمعادلات نسال الله له العفو والعافية والى الامام

الف مبروك اخي الاستاذ سليم وفقكم الله لكل خير ولمزيد من التقدم تقبل تحياتي

مرحبا هل بهذه الطريقة 4444.rar

تمام استاذ Shivan Rekany ان شاء الله بنوصل ل نتيجه او حل شكرا جدا

تمام اخي المهم ان توصل الى النتيجة

الف الف شكر استاذي الغالي سليم حاصبيا جعله الله في ميزان حسناتك هو دا المطلوب ذادك الله علما

الف الف مبروك للاستاذ المحترم سليم حاصبيا جدير بالترقية

تم رفع هذا الكود فى مشاركة منفصله حتى لا ننسى هذه المشاركة ترحيل بيانات تم ارفاق كود الحل من الفاضل ا / رحمه الله_ الحسامي _ هشام شلبى و لا تنسونا من صالح الدعاء تحياتى كود1-معدل (2).rar كود1-معدل (3).rar كود1-معدل (4).rar كود1 (HISHAM).rar

السلام عليكم اخي العزيز ياسر المسكلة ليست في الاوامر ولكن عند الاختيار من القائمة لا يتم الفلترة ويتم استدعاء جميع البيانات علما باني استخدم اكسيل 2003 دمت بكل خير تحياتي

بعد تحويل النصوص الى تاريخ حسب المغادلة المذكورة في مشاركة سابقة =--(MID(TRIM(G2),(FIND("/",TRIM(G2),4)+1),4)&"/"&LEFT(TRIM(G2),2)&"/"&MID(TRIM(G2),FIND("/",TRIM(G2))+1,2)&" "&MID(TRIM(G2),(FIND(":",TRIM(G2))-2),2)&":"&RIGHT(TRIM(G2),2)) استعمل المعادلات المذكورة في العامودين D & E in sheet1 (النطاق الاصفر و ستفرج ان شاء الله) و حتى نهاية النطاقين calculation-SALIM.rar

مبارك الترقية أستااذي ومعلمي @سليم حاصبيا وفعلا أنت تستحق الترقية عن جدااااارة

كل عام و انتم بخير

جزاكم الله كل الخيـــر انا حاولت فى الكود وما راضى يشتغل والان سبحان الله كنت اجرب مرة اخرى وهذا ما عمل معى واشتغل الان على اكمل وجه Private Sub ShowPassword_AfterUpdate() If Me.ShowPassword.Value = True Then Me.txtPassword.InputMask = "" Else Me.txtPassword.InputMask = "password" End If End Sub

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

العفو استاذ عبدالله وهذه فكرة اخرى sumdebit2: DSum("[debit]","entry","left([code]," & Len([code]) & ")=" & [code]) بالتوفيق

وعليكم السلام أخي الكريم محمد أبو عبد الله 1 - قم بالدخول للرابط التالي لنسخ الكود بالكامل 2- افتح المصنف الخاص بك واضغط Alt + F11 للدخول لمحرر الأكواد 3- من قائمة Insert أدرج موديول جديد والصق فيه ما قمت بنسخه من أكواد 4- آخر جزء في الكود سيتم نقله إلى حدث ورقة العمل "ورقة2" .. لذا قم بتحديد آخر جزء في الكود ثم اضغط Ctrl + X لقص هذا الجزء ووضعه في مكان آخر 5- من نافذة المشروع انقر دبل كليك على ورقة العمل "ورقة2" لتضع الكود الذي تم قصه إلى هذا الموديول 6- اذهب لورقة العمل المسماة "ورقة2" واختر الفصل المطلوب إعداد قائمة له .. من الخلية J1 رابط الكود من هنا

الحمد لله الذى تتم بنعمته الصالحات

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

إليك الملف التالي حسب ما فهمت من طلبك Saving Workbook Counter.rar