محمد طاهر عرفه

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

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

برنامج كفالة اليتيم - هيئة الاغاثة بالجبيل نشره سابقا الاخ فيصل الحربي فى الفريق العربي اضغط بالزر الايمن و اختار حفظ باسم من هنا

Private Sub Worksheet_Change(ByVal Target As Range) If Range("B" & Target.Row).Value > 0 And Range("A" & Target.Row).Value > 0 Then MsgBox "لا يمكن الإيداع والسحب في نفس العملية", , "عفوا" Target.Value = "" Exit Sub End If If Target.Value <> "" Then If Target.Column = 1 Then MsgBox "تمت أضافة المبلغ", , "تهانينا" End If If Target.Column = 2 Then MsgBox "تم خصم المبلغ ", , "أحسن الله عزاك" End If End If End Sub ملاحظة : الكود مجمع للأخ أبو أحمد مشكورا

الملف يعمل علي أوفيس 2000 و اكس بي و الملف المرفق مضغوط ببرنامج وين رار وهو نظير افضل للوين زيب و يتعامل مع الامتدادين rar ,zip و لتحميله علي الجهاز http://www.rarlabs.com/download.htm وبه تفك الملفات ذات الامتداد rar

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

بالكود التالي يمكن تبديل النموذج الفرعي Me.SubForm.SourceObject = "Subform1" حيث SubForm هو اسم كائن انوذج الفرعي وSubform1 هو اسم النموذج الفرعي المراد ادراجه بدل الموجود مرفق مثال للتبديل بين نموذجين فرعيين بالكود ChangeSubForm.rar

بالنسبة لتنسيق التارخ للتنسيق الهجري و الميلادي استعمل B2DD/MM//YY D/MM/YY علي التوالي و بالنسبة للغة استخدم الايقونات فى الصورة (اوفيس اكس بي ) بالمناسبة : يعني ايه راعي الاولة ؟؟

هو يدخل الي الكائن المفتوح جرب فتح تقرير ثم ضغط زر التصميم بالمحرر ، سيدخل هل تقصد أنك جربت علي مثال آخر ام علي المثال الذي حاولت انا حمايته ؟؟

جرب ادخال قيمة فى نفس السطر فى العمودين a,b فى الملف المرفق PreventinsameRaw.rar

اذا فحل المتغير لا يناسبك و لابد من تخزين القيمة فى جدول و للاسترجاع من الجدول نستخدم دالة Dlookup و بناء علي القيمة التي ستسترجعها تنفذ الكود و هنا لن نعرف متغير عام DIM Mycheck AS INTEGER Mycheck = DLookUp("[FieldName]","TableName") if Mycheck = 0 then If DCount("txtnum", "Table2") > 5 Then MsgBox "عــفواً ... هذه النسخة للعرض فقط .. للحصول على نسخة كاملة من البرنامج " & vbCrLf & _ " الــرجــاء الأتــصــال على المبــرمــج " _ & vbCrLf & _ vbCrLf & " AMOTAIB@HOTMAIL.COM ", 0, "أنتهاء مدة العرض" Me.Undo Cancel = True DoCmd.Quit Else DoCmd.Maximize End If end if و لتسجيل القيمة بالجدول أو تحديثها استخدم استعلام تحديث أو ما يناظره بالكود مع تحياتي

من Tools security set database password و لكي تكون مفعلة لابد من فتح الملف فى وضع exclusive و بالنسبة لاخفاء الجداول و باقي الكائنات يمكن اختيارها من اكار قاعدة البيانات ، و من ثم اختيار خصائصصها بالزر الايمن و اخفاؤها و عن الاخفاء و الاظهار بالكود يوجد مثال وافي للأخ حارث فى قسم الحماية داخل قسم خلاصة المشاركات مع تحياتي

اذا كنت تسجلها فى كل السجلات فلماذا لا تجعل مصدر بياناتها هو مربع النص فى النموج الرئيسي أي في مصدر بيانات مربع النص فى النموذج الفرعي تضع مصدر البيانات =Forms!mainformname!t و فى حدث بعد التحديث لمربع النص t فى النموذج الرئيسي تضع Private Sub t_AfterUpdate() Forms![fa]![Contacts subform].Form.Requery End Sub

قم بتعيين متغيير عام اسمه مثلا Mycheck و اجعل زر التفعيل يغبر قيمته الي . و زر الابطال يغيرها الي 1 وعدل الكود الي if Mycheck = 0 then If DCount("txtnum", "Table2") > 5 Then MsgBox "عــفواً ... هذه النسخة للعرض فقط .. للحصول على نسخة كاملة من البرنامج " & vbCrLf & _ " الــرجــاء الأتــصــال على المبــرمــج " _ & vbCrLf & _ vbCrLf & " AMOTAIB@HOTMAIL.COM ", 0, "أنتهاء مدة العرض" Me.Undo Cancel = True DoCmd.Quit Else DoCmd.Maximize End If end if ملاحظة غيرت اسم الجدول حتي لا تنقلب الجملة أو تجعله يسالك عن رقم سري مثلا بدل صفر وواحد فاذا أدخلت الرقم ازال الشرط و اذا لم يكن يفعله أو حل آخر أن تخزن القيمة فى حقل فى جدول بدل متغير عام و تغيرها من الزر و في النهاية تختبر القيمة فى الجدول أو فى المتغير العام قبل تنفيذ الكود الذي ذكرته مع تحياتي

أي كود ؟؟ لم أفهم السؤال ، أرجو التوضيح

نسختها من المنتدي الي خلية فى ورقة عمل و جربتها و لم يأتني رسالة خطأ و جاءات النتيجة سليمة كما طلبتها ربما تكون الفواصل لديك فى لوحة تحكم الويندوز مختلفة فاستبدل مثلا الفاصلة المنقوطة بفاصلة عادية (عدد 2 فاصلة ) و يوجد فى قسم خلاصة المشاركات أكثر من مثال علي استخدام ال IF

من هنا مرفق المثال Q6.rar

أهلا بك =+IF(B3<5000;B3*0.00125;(B3-50000)*0.001+50000*0.00125)

مثلا اذا أردت تنفيذ نقل القيمة مع ضغط Ctr+Q فضع الكود التالي عند حدث الضغط علي زر للنموذج مع تعديل خاصية Key Preview الي نعم و هذه الخاصية تعني أن تنفيذ الاكواد الخاصة بالضغط علي زر الخاصة بالنموذج تتم قبل مثيلتها الخاصة بعناصر التحكم فى النموذج مثل مربعات النص و هنا مع ضغط Ctr+Q فقط ستظهر رسالة تأكيدية و يتم تنفيذ نقل القيمة و لا يحدث أي شيء مع أي زر آخر Private Sub Form_KeyPress(KeyAscii As Integer) If KeyAscii = 17 Then MsgBox "Officena.com , you Pressed Ctr+Q" Me.d = Me.t End If End Sub

هذا ما نحاول فيه من عدة أشهر سواء هنا أو منذ بداية المناقشة فى الفريق العربي و قد بائت جميع المحاولات السابقة بالفشل ( لكن مازالت التعديلات الممكنة شكلية فقط ، فالكود محمي ) و هذه هي أحدث محاولة و أتنمي أن تنجح ) و بعد ترك فترة لمحاولات الاخوة للتعديل كالعادة ، ساشرح الطريقة باذن الله سواء نجحت أم لا مع تحياتي

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

حفظ المعلومات في الريجستي يكون باستخدام 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, "مجلد جديد" علماً أنني نقلته من أحد المواقع . وللجميع التحية

الضغط علي f2 يؤدي الي وضع المؤشر فى حالة التحرير و لعمل ذلك بالكود sendkeys "{F2}" و يوجد عليه مثال هنا و لتشغيل الاوامر المختلفة من أي مكان بالمفاتيح راجع هذا الموضوع و هو شرح للطريقة التي ذكرها مشكورا الأخ سمير و يمكن تخصيص استخدام الزر فى نموذج معين باستخدام حدث Onkey press للنموذج و سيفيد هذا المثال فى معرفة أكواد ال asci للتعامل مع هذا الحدث من هنا

هذا المثال لمعرفة ال ASCI كود للازرار المختلفة و العكس ، أي معرفة الزر المناظر ل ASCI كود محدد و يفيد لمعرفة الاكواد حيث أن بعض الدوال و التي تتعلق بضغط الازرار مثل Form_KeyPress تستلزم معرفة هذه الاكواد للتعامل معها فى المثال اكتب الحرف ثم اضغط Enter لتري الكود المناظر chr_Asc2000.rar

بشرة خير :) هذا خبر جميل فى انتظار محاولات باقي الأخوة ملاحظة : تم تعديل رابط التنزيل أعلاه الي http://www.officena.net/Tips/MasterFormat.php