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

تفضل هذا الحل بالإمكان تغيير وقت الإنصراف من خلال الكود نهاية الدوام الساعة 8 صباحا و بعدها سيتم حساب يوم جديد Public Function Overtime(RealCheckoutTime As Date, CheckoutTime As Date) Select Case CheckoutTime Case #1:00:00 AM# To #8:00:00 AM# Overtime = DateDiff("h", DateAdd("d", -1, RealCheckoutTime), CheckoutTime) Case Is > RealCheckoutTime Overtime = DateDiff("h", RealCheckoutTime, CheckoutTime) Case lese Overtime = 0 End Select End Function New Microsoft Access Database.accdb

انظر للمرفق..هل هذا ماتريده؟ AB.mdb

يعني قصدك في كل دورية تريد تحديث للمبلغ 17950 حسب الدفعات الجديدة .... صحيح .. اليس كذلك..

طيب ... ركز معي اخي الكريم هذا المرفق يعمل كالتالي :::: عند فتح نموذج التسليم .... اذا كانت الجمعية جديد يقوم البرنامج تلقائيا بتهيئة البيانات المطلوب وذلك بعد ظهور الرسالة التى تؤكد بدايتها اما اذا كان البرنامج به جمعية سابقة لم تنتهي فيعمل مباشرة دون اي رسائل واذا كان البرنامج به جمعية سابقة ولكن دورتها منتهية أي تم تسليم الجميع مستحقاتهم ... يقوم البرنامج تلقائيا بتجديد دورة اخر جديدة ======================================== ملاحظة هامة الاشخاص الذين تم استلامهم لاشهر سابقة لن تظهر اسمائهم في نموذج التسليم مرة اخرى ... حتى تستكمل الدورة للجميع ... ثم تعاد اسمائهم في الدورة الجديدة ======================================== امور فنية : الجدول المسمى distribution هو جدول لترحيل بيانات التسليم مع كل ضغطت زر للتسليم الجدول المسمى Kan_distribution هو جدول لوضع علامة امام كل مستلم حتى لايظهر اسمه قبل نهاية الدورة ..... ومع الدورة الجديد تزال تلك العلامات ========================================= انظر الصور .... مع تجربة المرفق .... وأعلمنا بالنتيجة الجمعية.accdb

اضافة المثال سهل الاجابة ..... بارك الله فيك أخي @Eng.Qassim

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

إن شاء الله يكون هذا هو المطلوب تم إخراج الترحيل لشيت حجوزات من شرط عدم فراغ txt3 ' ليدجر - حجوزات ترحيل Application.ScreenUpdating = FALSE Dim answer As Integer answer = MsgBox("ترغب فى ادخال هذه البيانات", vbQuestion + vbYesNo + vbDefaultButton2, "Confirmation") If answer = vbYes Then If Txt3 <> "" Then Dim rng1 As Range Dim str_search As String str_search = Txt3.Value Set rng1 = Sheets("ليدجر").Range("E:E").Find(str_search, , xlValues, xlWhole) Dim row_number As Long row_number = rng1.Row Dim lastcolumn As Long lastcolumn = IIf(Sheets("ليدجر").Range("lu" & row_number) = "", 333, Sheets("ليدجر").Range("lu" & row_number).End(xlToRight).Column + 1) Sheets("ليدجر").Cells(row_number, lastcolumn).Value = C3.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 1).Value = CDate(C4) Sheets("ليدجر").Cells(row_number, lastcolumn + 2).Value = C5.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 3).Value = C6.Value Sheets("ليدجر").Cells(row_number, lastcolumn + 4).Value = C7.Value 'Sheets("ليدجر").Select Cells(row_number, lastcolumn).Select End If Dim lastrow As Long lastrow = ThisWorkbook.Sheets("حجوزات").Range("D100000").End(xlUp).Row lastrow = lastrow + 1 With ThisWorkbook.Sheets("حجوزات") .Range("H" & lastrow).Value = Txt50.Value .Range("I" & lastrow).Value = Txt3.Value .Range("D" & lastrow).Value = TXT1.Value .Range("G" & lastrow).Value = CDate(TXT2) .Range("F" & lastrow).Value = Txt8.Value .Range("K" & lastrow).Value = Txt18.Value .Range("M" & lastrow).Value = Txt28.Value .Range("N" & lastrow).Value = Txt31.Value 'كود مسح البيانات Me.Txt50.Value = "" Me.Txt3.Value = "" Me.TXT1.Value = "" Me.TXT2.Value = "" Me.Txt8.Value = "" Me.Txt18.Value = "" Me.Txt28.Value = "" Me.Txt31.Value = "" End With End If Application.ScreenUpdating = True MsgBox "تم الترحيل بنجاح" بالتوفيق

انظر هنا لاستاذنا القدير محمد صالح وايضا هنا مع مثال عملي للاستاذ احمد سليم

اذن كيف تريد منع التكرار في الجدول ...... اذن هناك لبس في الموضوع .... لو ارفقت مثال لعرفنا وانتهى الموضوع ..... لان تفسيراتنا الغيبية انت تتحدث في جانب ونحن في جانب .... لن نصل ونضيع الوقت !!

وبارك فيك ...

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

اخي الكريم ليس بالضرورة وجود مفتاح رئيسي في الجدول ........ انظر هذا الجدول ....

اجعل احد حقول الجدول حسب الصورة ....

اين الحروف في المثال ؟؟؟؟ على كل حال انظر المرفق .... مثال.rar

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

طيب اخي الكريم جرب المرفق ووافينا بالنتيجة .... علما اننا اضفنا حقل نعم / لا في الجدول A AB.mdb

مشاركة مع استاذ قاسم تفضل التعديل ارجو ان يكون طلبك برنامج الديون-1.rar

يفضل البدء بموضوع جديد بعنوان جديد مادام المطلوب مختلف هذا الموضوع يحتوي على ثلاثة مطلوبات أو أربعة على كل حال ضع قبل نهاية الإجراء مباشرة Me.TextBox2 = i2 بالتوفيق

بالضبط كده الحمد لله جزاكم الله الف خير

بما ان الضرب في 24 يجلب التاريخ مع الوقت وليس الوقت فقط نجرب استعمال دالة hour الاضافي: hour(000) حيث 000 هي المعادلة القديمة بالتوفيق

شكرا لك استاذي العزيز @kanory فمنكم نتعلم

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

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

وعليكم السلام-لا يمكن العمل على التخمين ... ارفع من فضلك ملف مدعوم بشرح كافى عن المطلوب مع وضع شكل النتائج المرجوة وشكراً !!!!

شكرا استاذ محمد الكود يعمل بنجاح جزاك الله خيرا

If Txt3 <> "" Then --------- --------- Else GoTo NXT End If NXT: Dim lastrow As Long

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

نظام اللمس يصلح للمطاعم والكافيهات اما البقالات والمتاجر فالذي يصلح لها هو نظام قارىء الباركود

رائع جدا جدا،، سلمت رعاك الله،،

company LTD.xlsx

لا أعتقد أن هذا هو المطلوب @د.كاف يار لأن النتيجة المطلوبة على. ترتيب السجلات هي 5 0 0 8 4 والحمد لله تم تحققها في معادلتي

الشكر لله أخي الكريم يبدو أنك ما لاحظت أن المسلسل بعد 1009 هو 1010 وليس 10010 أو ربما يكون التسلسل الصحيح يقفز من 1009 إلى 10010 وحضرتك نسيت وكتبت التسلسل كما بالصورة المأخوذة من ملفك بنيت فكرتي في الحل على مسلسل الرقم والكود وليس على الفكرة الموجودة في الملف وهي دمج الرقم مع 100 نظرا لعدم موافقتها للتسلسل خالص دعواتي بالتوفيق

بعد إذن صديقي العزيز @Ali Mohamed Ali هذه الحيلة لن تفيد مع دمج الرقم 100 مع 10 لأن الناتج سيكون 10010 عشرة آلاف وعشرة وليس 1010 لذا أقترح وضع هذه المعادلة في C1 =SUM(1000,A1) وفي هذه الحالة يمكن الاستغناء عن العمود B مرفق الملف بعد التعديل ليتناسب مع الأرقام بعد 9 بالتوفيق TEST.xlsx

بارك الله فيك ابا الحسن .... تقريرك المصدر هو بالانجليزي ... كيف تبغاه بالعربي ؟؟؟؟؟؟؟ ثانيا :::: لا تتوقع عند تصدير التقرير الى الاكسل يكون بنفس التنسيق .... اذا تبقاة بنفس التنسيق صدرة PDF فقط ...

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

طيب اخي الكريم انت تقول غير اسم التقرير في الكود ..... وتريد ان معالج اختيار مكان الحفظ استخدم هذا الكود ...... DoCmd.OutputTo acOutputQuery, "rpt_Items_Dates_3", "ExcelWorkbook(*.xlsx)", "", False, "", , acExportQualityPrint

اظن الحالة الاولى .... معروفة وسهلة هذا مثال للحالة الثانية ...... Bar_te.accdb

هل تريد ذلك عن طريق المبرمج أم المستخدم هو من يتحكم ؟؟؟؟ اذا كان كمبرمج ..... فيمكن ذلك عن طريق عمل استعلام للجدول المطلوب وتحديد الحقول المطلوبة للتصدير .... ثم تصدير الاستعلام بدل الجدول ... وإذا كان كمستخدم ..... فيمكن ذلك عن طريق عمل فورم يجلب الجداول في كمبوبكس ... ثم اظهار الحقول الخاصة بالجدول بعد اختياره .... ثم تصدير الحقول المختارة فقط ... ماذا تريد انت ؟؟؟؟؟؟؟؟؟

تلميذك ..... منك نتعلم

تفضل ...... Output_Path = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\" & Format(Date, "dd-mm-yyyy") & ".xlsx" DoCmd.OutputTo acOutputQuery, "qry_Query", "ExcelWorkbook(*.xlsx)", Output_Path, False, "", , acExportQualityPrint

مادام التقرير يخص موظفا في شهر معين فلا داعي للتقرير ويمكن الاعتماد على عملية التصفية (فلتر) في نفس شيت الشهر مع تعديل المعادلات لتتناسب مع المطلوب . تم ضبط مجموعة المعادلات في خلايا التأخير وما بعدها والتنسيق الشرطي ووضع معادلة ( إجمالي وعدد) الموظف المختار أو الكل حسب الفلتر ويمكن الاستغناء عن صف المجموع أسفل البيانات بالتوفيق حضور وانصراف الموظفين 111.xlsx

No way without using VBA

اخى الكريم omaryoseeg بعد السلام عليكم ارجو ان يفى الملف التالى بالغرض وحده الطباعه2016.rar

السلام عليكم ورحمة الله وبركاته . وهذا كود اخر لا علاقه له بالتاريخ , وانما يعتمد على عدد مرات فتح البرنامج وبعد انتهاء العدد المسموح به تخرج رساله تنبهك بشراء البرنامج . بالضبط كالبرامج التي تباع بالانترنيت تستطيع فتحها لمدة مرتين فقط . لكن هنا في الكود جعلت عدد مرات فتح البرنامج 100 مرة . Private Sub Form_Current() retvalue = GetSetting("A", "0", "Runcount") GD$ = Val(retvalue) + 1 SaveSetting "A", "0", "RunCount", GD$ If GD$ > 100 Then MsgBox ("انتهت مدة تشغيل البرنامج عليك بشراء البرنامج او الاتصال بالمطور"), , ("AZHAR ALIraqy") DoCmd.Quit End If End Sub

اخى عيسى جرب الكود الاتى TextBox5 = Me.ListBox1.ListCount

أخي apt عذرا، لكني حاولت أن أجد وسيلة لتطبيق الخط دون تنصيبه، ولكن لا توجد طريقة لذلك. فيجب تنصيب الخط لكي تتمكن من التحكم فيه. تجد مرفقا ملف الخط الذي اسميته circ. لتنصيب الخط، قم بتنزيله أولا إلى جهازك، إلى سطح المكتب مثلا. بعد ذلك افتح مجلد الخطوط بهذه الطريقة السريعة: اضغط Start (ابدأ) ثم Run (ما أظن أن ترجمته هي تشغيل...). اكتب كلمة fonts في المربع ثم اضغط على OK (موافق). سيفتح عندئذ مربع الخطوط. بعد ذلك اسحب الخط إلى داخل المربع، وعندئذ يقوم الويندوز بتنصيب الخط circ. افتح مستند الوورد وحدد القائمة التي تريد أن ترقم مندرجاتها بأرقام مدورة. من قائمة format (تنسيق) اختر Bullets and Numbering (تعداد نقطي وتعداد رقمي) ثم علامة التبويب Numbered (تعداد رقمي). اختر منها التعداد الأجنبي ABCD (الأحرف الكبيرة)، ثم اضغط على Customize (تخصيص). في خانة Number format (تنسيق الأرقام) احذف النقطة (إذا وُجدت) من أمام الحرف. ثم اضغط على زر Font (الخط). وتحت Latin text font (خط النص اللاتيني) اختر الخط circ ثم اضغط على موافق مرتين لإغلاق المربعين. وهكذا يتبع الوورد التعداد المستند على الخط circ الذي فيه ABC إلخ هي 1 و 2 و3... مدورة. ملاحظة هامة: لا ينفع هذا الخط إلا لهذا النوع من التعداد. فإذا أردت إجراء تعداد من نوع آخر، فعليك استعمال خط من الخطوط المنصبة أصلا على كمبيوترك. ملاحظة هامة ثانية: لسبب ما لم يسمح لي المنتدى برفع ملف الخط، لذلك قمتُ بتغيير امتداده إلى doc. بعد أن تقوم بالتنزيل، غير الامتداد من doc إلى ttf. وكما قلت، يفيدك هذا التعداد حتى الرقم 26. circ.doc

أخي الكريم : أبوعبدالله2 لنفترض أنك في برنامجك يلزم لك تخزين عدد مرات تشغيل برنامجك .. وأن الاسم الذي ترغب بإكلاقه على برنامجك هو "المعين لحل المعالات الرياضية" وأن اسم المتحول الذي ستستخدمه لتخزين عدد مرات تشغيل البرنامج هو repetition حسناً .. عند تشغيل البرنامج وعند فتح الفورم الرئيسي نكتب ما يلي : repetition = GetSetting "المعين لحل المعالات الرياضية","Var","Repet No",0 لا حظ أن : "Repet NO" هو اسم كيفي استخدمته للدلالة على هذه القيمة التي أقرؤها .. ويدعى هذا الاسم بـ ( مفتاح ) رقم 0 : هو القيمة الافتراضية التي سيعيدها هذا التابع في حال لم نكن قد خزنا من قبل قيمة لهذا المفتاح ، أي عند أول استخدام للبرنامج سيعيد لنا تابع GetSetting القيمة صفر ثم نكتب بعد سطر التعليمات السابق ما يلي : Repetition = Repetition + 1 SaveSetting "المعين لحل المعالات الرياضية","Var","Repet No",Repetion وبهذان السطران نكون قد زدنا على قيمة المتحول Repetition قيمة +1 ثم قمنا بتخزينه مكان القيمة السابقة له

تتطلب تعليمة saveSetting أربع ممرات : اسم التطبيق اسم مجموعة الخيارات اسم الشيء المطلوب تخزين قيمته (المفتاح) قيمته مثال : SaveSetting "MyApp","Startup", "Left", 50 ولقراءة القيمة نستخدم GetSetting بنفس الممرات السابقة الثلاث الأولى وتكون الممررة الرابعة(اختياراية) هي القيمة الافتراضية (في حال عدم وجود هذا المفتاح في الريجستري) مثال : MyLeftvalue = GetSetting "MyApp","Startup", "Left", 25

فى هذه الحالة لابد من حفظ القيمة فى حقل فى جدول و استدعاؤها باستخدام DLOOKUP للتعامل معها

حفظ المعلومات في الريجستي يكون باستخدام SaveSetting كالتالي : SaveSetting "اسم التطبيق","اسم القسم","المفتاح","القيمة" مثال : SaveSetting "برنامجي", "نموذج الخيارات", "إظهار حقل", مربع_التدقيق_الأول والإستعادة أو القراءة تكون باستخدام GetSetting كالتالي : متغير= GetSetting ("اسم التطبيق","اسم القسم","المفتاح") مثال : مربع_التدقيق_الأول= GetSetting("إظهار حقل", "نموذج الخيارات", "برنامجي") ولايوجد في هذه الطريقة أي مشاكل نهائياً ، وقد طبقت ذلك في عدة برامج واستخدمه خاصة في خيارات المستخدم في القاعدة . وبإمكانك وضع قيم افتراضيه حالما يتم تحميل النموذج عندما لايجد قيم مسجله في الريجستي وللتأكد من عدم وجود قيمة استخدم : If GetSetting("اسم التطبيق", "اسم القسم", "المفتاح") = "" Then وإذا استخدمت متغير فاجعل من نوع Variant أو String . فائدة : ولحذف إدخال في سجل (للمثال السابق) : 1- لكافة التطبيق : DeleteSetting "برنامجي" 2- لحذف قسم واحد فقط : DeleteSetting "برنامجي","نموذج الخيارات" 3- لحذف إدخال واحد فقط : DeleteSetting "إظهار حقل", "نموذج الخيارات", "برنامجي" فائدة : لفتح ملف التسجيل لمعاينة التغييرات ؛ انقر ابدأ ثم تشغيل واكتب RegEdit وانتقل إلى HKEY_CURRENT_USER\Software\VB and VBA Program Settings وستجد اسم التطبيق انقر عليه وستجد الأقسام التي وضعتها داخل اسم التطبيق . ملاحظة هامة جداً : كن حذراً جداً من أي تغيير في السجل لاتعرف تأثيره لأنه قد يؤدي إلى في أسوأ الأحوال إلى توقف الوندوز عن العمل وفي أقلها تعطل بعض البرامج أو الخيارات أو غيرها . ------------------ وهذا الكود يمكنك من القراءة والكتابة وحذف قيمة من مفتاح مع ملاحظة أنه يمكن تخزين القيم وإنشاء مفاتيح تحت أحد الجذور الأربعة التالية لملف الريجستي : HKeyClassesRoot HKeyCurrentUser HKeyLocalMachine HKeyUsers والان اليكم الكود : Private Type FILETIME dwLowDateTime As Long dwHighDateTime As Long End Type Private Declare Function RegCloseKey _ Lib "advapi32.dll" _ (ByVal lngHKey As Long) _ As Long Private Declare Function RegCreateKeyEx _ Lib "advapi32.dll" _ Alias "RegCreateKeyExA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String, _ ByVal Reserved As Long, _ ByVal lpClass As String, _ ByVal dwOptions As Long, _ ByVal samDesired As Long, _ ByVal lpSecurityAttributes As Long, _ phkResult As Long, _ lpdwDisposition As Long) _ As Long Private Declare Function RegOpenKeyEx _ Lib "advapi32.dll" _ Alias "RegOpenKeyExA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ phkResult As Long) _ As Long Private Declare Function RegQueryValueExString _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As String, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExLong _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExBinary _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegQueryValueExNULL _ Lib "advapi32.dll" _ Alias "RegQueryValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ lpType As Long, _ ByVal lpData As Long, _ lpcbData As Long) _ As Long Private Declare Function RegSetValueExString _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ ByVal lpValue As String, _ ByVal cbData As Long) _ As Long Private Declare Function RegSetValueExLong _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ lpValue As Long, _ ByVal cbData As Long) _ As Long Private Declare Function RegSetValueExBinary _ Lib "advapi32.dll" _ Alias "RegSetValueExA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String, _ ByVal Reserved As Long, _ ByVal dwType As Long, _ ByVal lpValue As Long, _ ByVal cbData As Long) _ As Long Private Declare Function RegEnumKey _ Lib "advapi32.dll" _ Alias "RegEnumKeyA" _ (ByVal lngHKey As Long, _ ByVal dwIndex As Long, _ ByVal lpName As String, _ ByVal cbName As Long) _ As Long Private Declare Function RegQueryInfoKey _ Lib "advapi32.dll" _ Alias "RegQueryInfoKeyA" _ (ByVal lngHKey As Long, _ ByVal lpClass As String, _ ByVal lpcbClass As Long, _ ByVal lpReserved As Long, _ lpcSubKeys As Long, _ lpcbMaxSubKeyLen As Long, _ ByVal lpcbMaxClassLen As Long, _ lpcValues As Long, _ lpcbMaxValueNameLen As Long, _ ByVal lpcbMaxValueLen As Long, _ ByVal lpcbSecurityDescriptor As Long, _ lpftLastWriteTime As FILETIME) _ As Long Private Declare Function RegEnumValue _ Lib "advapi32.dll" _ Alias "RegEnumValueA" _ (ByVal lngHKey As Long, _ ByVal dwIndex As Long, _ ByVal lpValueName As String, _ lpcbValueName As Long, _ ByVal lpReserved As Long, _ ByVal lpType As Long, _ ByVal lpData As Byte, _ ByVal lpcbData As Long) _ As Long Private Declare Function RegDeleteKey _ Lib "advapi32.dll" _ Alias "RegDeleteKeyA" _ (ByVal lngHKey As Long, _ ByVal lpSubKey As String) _ As Long Private Declare Function RegDeleteValue _ Lib "advapi32.dll" _ Alias "RegDeleteValueA" _ (ByVal lngHKey As Long, _ ByVal lpValueName As String) _ As Long Public Enum EnumRegistryRootKeys HKeyClassesRoot = &H80000000 HKeyCurrentUser = &H80000001 HKeyLocalMachine = &H80000002 HKeyUsers = &H80000003 End Enum Public Enum EnumRegistryValueType rrkRegSZ = 1 rrkregbinary = 3 rrkRegDWord = 4 End Enum Private Const mcregOptionNonVolatile = 0 Private Const mcregErrorNone = 0 Private Const mcregErrorBadDB = 1 Private Const mcregErrorBadKey = 2 Private Const mcregErrorCantOpen = 3 Private Const mcregErrorCantRead = 4 Private Const mcregErrorCantWrite = 5 Private Const mcregErrorOutOfMemory = 6 Private Const mcregErrorInvalidParameter = 7 Private Const mcregErrorAccessDenied = 8 Private Const mcregErrorInvalidParameterS = 87 Private Const mcregErrorNoMoreItems = 259 Private Const mcregKeyAllAccess = &H3F Private Const mcregKeyQueryValue = &H1 Public Sub RegistryCreateNewKey( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String) Dim lngRetVal As Long Dim lngHKey As Long On Error GoTo PROC_ERR lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _ mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&) If lngRetVal = mcregErrorNone Then RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryCreateNewKey" Resume PROC_EXIT End Sub Public Sub RegistryDeleteKey( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String) Dim lngRetVal As Long On Error GoTo PROC_ERR ' Delete the key lngRetVal = RegDeleteKey(eRootKey, strKeyName) PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryDeleteKey" Resume PROC_EXIT End Sub Public Sub RegistryDeleteValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String) Dim lngRetVal As Long Dim lngHKey As Long On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) ' If the key was opened successfully, then delete it If lngRetVal = mcregErrorNone Then lngRetVal = RegDeleteValue(lngHKey, strValueName) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryDeleteValue" Resume PROC_EXIT End Sub Public Sub RegistryEnumerateSubKeys( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ astrKeys() As String, _ lngKeyCount As Long) Dim lngRetVal As Long Dim lngHKey As Long Dim lngKeyIndex As Long Dim strSubKeyName As String Dim lngSubkeyCount As Long Dim lngMaxKeyLen As Long Dim typFT As FILETIME On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) If lngRetVal = mcregErrorNone Then 'find the number of subkeys, and redim the return string array lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, lngSubkeyCount, _ lngMaxKeyLen, 0, 0, 0, 0, 0, typFT) If mcregErrorNone = lngRetVal Then If lngSubkeyCount > 0 Then ReDim astrKeys(lngSubkeyCount - 1) As String 'set up the while loop lngKeyIndex = 0 ' Pad the string to the maximum length of a sub key, plus 1 for null ' termination lngMaxKeyLen = lngMaxKeyLen + 1 strSubKeyName = Space$(lngMaxKeyLen) Do While RegEnumKey(lngHKey, lngKeyIndex, strSubKeyName, lngMaxKeyLen + 1) = 0 ' Set the string array to the key name, removing null termination If InStr(1, strSubKeyName, vbNullChar) > 0 Then astrKeys(lngKeyIndex) = Left$(strSubKeyName, InStr(1, strSubKeyName, _ vbNullChar) - 1) End If ' Increment the key index for the return string array lngKeyIndex = lngKeyIndex + 1 Loop End If ' return the new dimension of the return string array lngKeyCount = lngSubkeyCount End If ' Close the key RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryEnumerateSubKeys" Resume PROC_EXIT End Sub Public Sub RegistryEnumerateValues( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ astrValues() As String, _ lngValueCount As Long) Dim lngRetVal As Long Dim lngHKey As Long Dim lngKeyIndex As Long Dim strValueName As String Dim lngTempValueCount As Long Dim lngMaxValueLen As Long Dim typFT As FILETIME On Error GoTo PROC_ERR ' Open the key lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0, mcregKeyAllAccess, _ lngHKey) If lngRetVal = mcregErrorNone Then 'find the number of subkeys, and redim the return string array lngRetVal = RegQueryInfoKey(lngHKey, vbNullString, 0, 0, 0, _ 0, 0, lngTempValueCount, lngMaxValueLen, 0, 0, typFT) If mcregErrorNone = lngRetVal Then If lngTempValueCount > 0 Then ReDim astrValues(lngTempValueCount - 1) As String 'set up the while loop lngKeyIndex = 0 ' Pad the string to the maximum length of a sub key, plus 1 for null ' termination lngMaxValueLen = lngMaxValueLen + 1 strValueName = Space$(lngMaxValueLen) Do While RegEnumValue(lngHKey, lngKeyIndex, strValueName, _ lngMaxValueLen + 1, 0, 0, 0, 0) = 0 ' Set the string array to the key name, removing null termination If InStr(1, strValueName, vbNullChar) > 0 Then astrValues(lngKeyIndex) = Left$(strValueName, InStr(1, strValueName, _ vbNullChar) - 1) End If ' Increment the key index for the return string array lngKeyIndex = lngKeyIndex + 1 Loop End If ' return the new dimension of the return string array lngValueCount = lngTempValueCount End If ' Close the key RegCloseKey (lngHKey) End If PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryEnumerateValues" Resume PROC_EXIT End Sub Public Function RegistryGetKeyValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String) _ As Variant Dim lngRetVal As Long Dim lngHKey As Long Dim varValue As Variant Dim strValueData As String Dim abytValueData() As Byte Dim lngValueData As Long Dim lngValueType As Long Dim lngDataSize As Long On Error GoTo PROC_ERR varValue = Empty lngRetVal = RegOpenKeyEx(eRootKey, strKeyName, 0&, mcregKeyQueryValue, _ lngHKey) If mcregErrorNone = lngRetVal Then lngRetVal = RegQueryValueExNULL(lngHKey, strValueName, 0&, lngValueType, _ 0&, lngDataSize) If lngRetVal = mcregErrorNone Then Select Case lngValueType ' String type Case rrkRegSZ: If lngDataSize > 0 Then strValueData = String(lngDataSize, 0) lngRetVal = RegQueryValueExString(lngHKey, strValueName, 0&, _ lngValueType, strValueData, lngDataSize) If InStr(strValueData, vbNullChar) > 0 Then strValueData = Mid$(strValueData, 1, InStr(strValueData, _ vbNullChar) - 1) End If End If If mcregErrorNone = lngRetVal Then varValue = Left$(strValueData, lngDataSize) Else varValue = Empty End If ' Long type Case rrkRegDWord: lngRetVal = RegQueryValueExLong(lngHKey, strValueName, 0&, _ lngValueType, lngValueData, lngDataSize) If mcregErrorNone = lngRetVal Then varValue = lngValueData End If ' Binary type Case rrkregbinary If lngDataSize > 0 Then ReDim abytValueData(lngDataSize) As Byte lngRetVal = RegQueryValueExBinary(lngHKey, strValueName, 0&, _ lngValueType, VarPtr(abytValueData(0)), lngDataSize) End If If mcregErrorNone = lngRetVal Then varValue = abytValueData Else varValue = Empty End If Case Else 'No other data types supported lngRetVal = -1 End Select End If RegCloseKey (lngHKey) End If 'Return varValue RegistryGetKeyValue = varValue PROC_EXIT: Exit Function PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistryGetKeyValue" Resume PROC_EXIT End Function Public Sub RegistrySetKeyValue( _ eRootKey As EnumRegistryRootKeys, _ strKeyName As String, _ strValueName As String, _ varData As Variant, _ eDataType As EnumRegistryValueType) Dim lngRetVal As Long Dim lngHKey As Long Dim strData As String Dim lngData As Long Dim abytData() As Byte On Error GoTo PROC_ERR ' Open the specified key, If it does not exist then create it lngRetVal = RegCreateKeyEx(eRootKey, strKeyName, 0&, vbNullString, _ mcregOptionNonVolatile, mcregKeyAllAccess, 0&, lngHKey, 0&) ' Determine the data type of the key Select Case eDataType Case rrkRegSZ strData = varData & vbNullChar lngRetVal = RegSetValueExString(lngHKey, strValueName, 0&, eDataType, _ strData, Len(strData)) Case rrkRegDWord lngData = varData lngRetVal = RegSetValueExLong(lngHKey, strValueName, 0&, eDataType, _ lngData, Len(lngData)) ' Binary type Case rrkregbinary abytData = varData lngRetVal = RegSetValueExBinary(lngHKey, strValueName, 0&, eDataType, _ VarPtr(abytData(0)), UBound(abytData) + 1) End Select RegCloseKey (lngHKey) PROC_EXIT: Exit Sub PROC_ERR: MsgBox "Error: " & Err.Number & ". " & Err.Description, , _ "RegistrySetKeyValue" Resume PROC_EXIT End Sub ' مثال لإنشاء مفتاح رئيس تحت الجذر [CODE]RegistryCreateNewKey HKeyUsers, "New Floder\Sub Floder" ' مثال على إسناد قيمة لمفتاح فرعي ' إذا لم يجد المفتاح الفرعي فإنه ينشئه RegistrySetKeyValue HKeyUsers, "New Floder\Sub Floder", "اسم كائن", True, rrkRegSZ MsgBox RegistryGetKeyValue(HKeyUsers, "New Floder\Sub Floder", "اسم كائن") ' حذف قيمة مسندة لمفتاح فرعي RegistryDeleteValue HKeyUsers, "New Floder\Sub Floder", "اسم كائن" ' مثال لحذف مفتاح رئيس تحت الجذر RegistryDeleteKey HKeyUsers, "مجلد جديد" علماً أنني نقلته من أحد المواقع . وللجميع التحية