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

طيب كفكرة ممكن تعمل الساعة لحالها في نموذج فرعي وتعمل الحدث في النموذج الفرعي بدون ما يأثر على أحداث النموذج الرئيسي 🙂 Clock In Sub Form.accdb

أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي المشاكل عند اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . WhatsApp Sender 2025.zip

بعد اذن اخي فادي تفضل من عمل اخونا صالح حمادي جربته وأستخدمه دوما في الشاشات التي تفتح على كامل الشاشة .. يعمل 100% ملائمة النموذج حسب حجم الشاشة صالح حمادي.rar

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

تفضل أخي الكريم ، محاولتي البسيطة . حيث في الورقة الثانية = موقف الغياب اليومي ، قمت بإضافة زر للتحديث ، وتم استدعاءه للدالة التي تم انشاؤها في مديول عام :- Sub ExtractAbsentEmployees() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim targetDate As Date Dim dayNum As Integer Dim targetCol As Integer Dim lastRow As Long Dim i As Long Dim reportRow As Long Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب اليومي") wsReport.Range("A5:D" & wsReport.Rows.Count).ClearContents targetDate = wsReport.Range("C2").Value dayNum = Day(targetDate) targetCol = 3 + dayNum If targetCol < 4 Or targetCol > 34 Then MsgBox ".تاريخ غير صالح يجب أن يكون اليوم بين 1 و 31", vbExclamation Exit Sub End If lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 5 For i = 4 To lastRow If wsMain.Cells(i, targetCol).Value = "غ" Then wsReport.Cells(reportRow, 1).Value = wsMain.Cells(i, 1).Value wsReport.Cells(reportRow, 2).Value = wsMain.Cells(i, 2).Value wsReport.Cells(reportRow, 3).Value = wsMain.Cells(i, 3).Value wsReport.Cells(reportRow, 4).Value = targetDate reportRow = reportRow + 1 End If Next i If reportRow = 5 Then MsgBox "لا يوجد موظفين متغيبين في هذا التاريخ", vbInformation End If End Sub وفي الورقة الثالثة "موقف الغياب الشهري" ، أيضاً تم انشاء زر لاستدعاءه الدالة التالية من نفس المديول :- Sub GenerateMonthlyAbsenceReport() Dim wsMain As Worksheet Dim wsReport As Worksheet Dim startDate As Date, endDate As Date Dim currentDate As Date Dim dayNum As Integer, targetCol As Integer Dim lastRow As Long, reportRow As Long, i As Long Dim empName As String, empJob As String Dim dateList As String, dayList As String Dim dateCount As Integer Dim dayName As String Set wsMain = ThisWorkbook.Sheets("MainSheet") Set wsReport = ThisWorkbook.Sheets("موقف الغياب الشهري") If Not IsDate(wsReport.Range("C2").Value) Or Not IsDate(wsReport.Range("C3").Value) Then MsgBox "الرجاء إدخال تاريخين صالحين في الخلايا C2 و C3", vbExclamation + vbMsgBoxRight, "" Exit Sub End If startDate = wsReport.Range("C2").Value endDate = wsReport.Range("C3").Value If startDate > endDate Then MsgBox "خطأ: تاريخ البداية يجب أن يكون قبل تاريخ النهاية", vbExclamation + vbMsgBoxRight, "" Exit Sub End If Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With wsReport .Range("A6:F" & .Rows.Count).ClearContents .Range("6:" & .Rows.Count).RowHeight = 15 End With lastRow = wsMain.Cells(wsMain.Rows.Count, "B").End(xlUp).Row reportRow = 6 For i = 4 To lastRow empName = wsMain.Cells(i, 2).Value empJob = wsMain.Cells(i, 3).Value If empName = "" Then GoTo NextEmployee dateList = "" dayList = "" dateCount = 0 currentDate = startDate Do While currentDate <= endDate dayNum = Day(currentDate) targetCol = 3 + dayNum If targetCol >= 4 And targetCol <= 34 Then If wsMain.Cells(i, targetCol).Value = "غ" Then dayName = wsMain.Cells(2, targetCol).Value If dateList <> "" Then dateList = dateList & vbLf & Format(currentDate, "yyyy-mm-dd") dayList = dayList & vbLf & dayName Else dateList = Format(currentDate, "yyyy-mm-dd") dayList = dayName End If dateCount = dateCount + 1 End If End If currentDate = DateAdd("d", 1, currentDate) Loop If dateCount > 0 Then With wsReport .Cells(reportRow, 1).Value = reportRow - 5 .Cells(reportRow, 2).Value = empName .Cells(reportRow, 3).Value = empJob .Cells(reportRow, 4).Value = dateCount .Cells(reportRow, 5).Value = dateList .Cells(reportRow, 6).Value = dayList .Cells(reportRow, 5).WrapText = True .Cells(reportRow, 6).WrapText = True If dateCount > 1 Then .Rows(reportRow).RowHeight = 15 * dateCount End If End With reportRow = reportRow + 1 End If NextEmployee: Next i Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic If reportRow > 6 Then ' MsgBox "تم إنشاء التقرير بنجاح", vbInformation + vbMsgBoxRight, "" Else MsgBox "لا توجد أيام غياب في الفترة المحددة", vbInformation + vbMsgBoxRight, "" End If End Sub وتركت لك التعديل متاحاً من خلال تحديد الصف أو العمود ... إلخ . وهذا ملفك بعد التعديل . راجعه وأخبرنا بالنتيجة .. موقف غياب موظفين.zip

وعليكم السلام ورحمة الله وبركاته ,, حاولت فهم المطلوب بشكل واضح ، وخرجت بهذه الفكرة . حيث انشأت زر للتنفيذ ، يحتوي الكود التالي :- Private Sub Btn_1_Click() Dim wsMain As Worksheet Dim wsTarget As Worksheet Dim lastRow As Long Dim i As Long Dim targetCol1 As String, targetCol2 As String Dim sourceCol1 As String, sourceCol2 As String Set wsMain = ThisWorkbook.Sheets("F") Dim targetSheetName As String targetSheetName = wsMain.Range("F6").Value On Error Resume Next Set wsTarget = ThisWorkbook.Sheets(targetSheetName) On Error GoTo 0 If wsTarget Is Nothing Then MsgBox " : الورقة المحددة غير موجودة" & targetSheetName, vbExclamation + vbMsgBoxRight, "" Exit Sub End If If wsMain.Range("G6").Value = "قوى" Then sourceCol1 = "L" sourceCol2 = "M" targetCol1 = "H" targetCol2 = "I" ElseIf wsMain.Range("G6").Value = "تامين" Then sourceCol1 = "O" sourceCol2 = "P" targetCol1 = "H" targetCol2 = "I" Else MsgBox "يجب اختيار 'قوى' أو 'تامين' في الخلية G6", vbExclamation + vbMsgBoxRight, "" Exit Sub End If wsMain.Range("H6:I" & wsMain.Rows.Count).ClearContents lastRow = wsTarget.Cells(wsTarget.Rows.Count, sourceCol1).End(xlUp).Row lastRow = Application.WorksheetFunction.Max(lastRow, wsTarget.Cells(wsTarget.Rows.Count, sourceCol2).End(xlUp).Row) For i = 6 To lastRow If wsTarget.Range(sourceCol1 & i).Value <> "" Then wsMain.Range(targetCol1 & (i - 0)).Value = wsTarget.Range(sourceCol1 & i).Value End If If wsTarget.Range(sourceCol2 & i).Value <> "" Then wsMain.Range(targetCol2 & (i - 0)).Value = wsTarget.Range(sourceCol2 & i).Value End If Next i MsgBox "تم نقل البيانات بنجاح", vbInformation + vbMsgBoxRight, "" End Sub جرب المرفق وأخبرنا بالنتيجة .. BB.zip

رغم أن معظم الأكواد تحتاج الى إعادة هيكلة وتصحيح ، ولكن جرب هذا المقترح ، بعد ما تمت تجربته على ملفك السابق :- Private Function GetDateColumn(ByVal searchDate As Date) As Long Dim cell As Range Dim searchRange As Range Set searchRange = wsData.Range(wsData.Cells(HEADER_ROW, DATE_COL_START), _ wsData.Cells(HEADER_ROW, wsData.Columns.Count)) For Each cell In searchRange If IsDate(cell.Value) Then If CDate(cell.Value) = searchDate Then GetDateColumn = cell.Column Exit Function End If End If Next cell GetDateColumn = 0 End Function جرب الملف التالي وشوف النتيجة Book5.zip

بعد إذن الاستاذ/ هشام جرب كود الأستاذ/هشام بعد تعديل بسيط Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String Dim f As Long, i As Long, j As Long Dim linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim lastRow As Long Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") ' التحقق من وجود التاريخ xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation Exit Sub End If ' البحث عن العمود المطابق للتاريخ في الصف 3 With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation Exit Sub End If End With ' تحديد آخر صف يحتوي أكواد في العمود C من Sheet2 lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).Row xCode = False: c = False ' البدء من الصف 11 حتى يشمل أول طالب For i = 11 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).Row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True ' مسح الصف الخاص بالكود الحالي فقط For ColArr = 0 To 4 Data.Cells(n + 5, f + ColArr).ClearContents Next ColArr ' نقل القيم For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i ' رسائل النهاية If Not xCode Then MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation ElseIf c Then MsgBox "تم ترحيل البيانات بنجاح", vbInformation Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End If End Sub غياب3.xlsm

اعرض الملف ⭐ هدية ~ مرسال الواتس أب الجديد 2025⭐ أخواني وأساتذتي ومعلمينا ( دون استثناء ) أعتقد أنه ومن خلال العنوان سيتسائل البعض عن أن المحاولات كانت كثيرة لبناء هذه الفكرة ولكنها مع التحديثات الجديدة تفشل !! وهذا الإعتقاد منطقي 😁 . إلا انه وبهذه التحديثات - واتمنى - أنه قد تم التعامل مع هذه الأخطاء بهذه النسخة المطورة والمحسنة . الإضافات التي تم تأمينها في هذه النسخة :- التعامل مع المرفقات بسلاسة وسهولة من خلال فكرة نسخ المرفق ولصقه في تطبيق الواتس اب ( سطح المكتب ) ، وليس من خلال المسار 😁 . إمكانية الإرسال لأكثر من رقم دفعة واحدة . افصل بين الرقمين بإشارة / فقط . إمكانية إضافة التعبيرات Emoji وإرسالها ضمن الرسائل في الواتس أب . من خلال زر زر لمسح محتوى الرسالة تهيئةً لإرسال جديد . من خلال الزر تضمين محدد لحجم الملفات والمرفقات المرسلة . ( خاص بأصحاب التطويرات الذين يريدون تقييد وإلزام المستخدم بحجم محدد ) . استخدام تايمر متغير للتعامل مع الإرسالات المتعددة لأكثر من رقم . واجهة محاكية وجذابة للبرنامج . لا تحتاج جداول أو مكتبات خارجية .... إلخ . تم كتابة الدوال والأكواد بطريقة تسهل على المطورين إعادة الهيكلة والتصميم حسب حاجتهم في برامجهم . واجهة البرنامج :- :- ضرورة تثبيت برنامج واتس اب سطح المكتب من متجر ويندوز . التأكد من فتح تطبيق الواتس أب سطح المكتب لديك ، لتلافي اختلاف سرعة إستجابة الكمبيوتر من مستخدم لآخر . صاحب الملف Foksh تمت الاضافه 07/03/25 الاقسام قسم الأكسيس  

في المعايير النصية لبعض الاستعلامات نستخدم WHERE U_UserName = '" & strUser & "' AND U_Password = '" & strPass & "'") وكذلك الحال في دوال تجميع المجال "[U_FullName]='" & [tx3] & "'") ايضا عندما نضع معيار نصي لفتح فورم من خلال فورم اخر DoCmd.OpenForm "frm2", , , "[U_UserName]='" & [tx2] & "'" وكذلك الحال عند الفلترة بمعيار نصي DoCmd.ApplyFilter , "[U_UserName]='" & [tx9] & "'" وحيث ان الحقول النصية تقبل كتابة أي احرف أو أرقام أو رموز خاصة وبالتي يمكن توظيفها بطريقة معينة لتنفيذ اجراء غير شرعي الحقيقة التي يعلمها اي شخص لديه خبرة في الحماية أن الرموز الخاصة ورسائل الخطأ غير المعالجة تمثل الطريق الأسهل للاختراق في الحالة الاولى معيار نصي في استعلام يمكن تسجيل دخول غير شرعي بكافة صلاحيات مستخدم رقم 1 ويمكن تنفيذ استعلام حذف او الحاق او او ... الخ في حالة رقم 2 مع دوال تجميع المجال يمكن تنفيذ الدالة دون معرفة المعيار وتعود باول او اخر او اكبر سجل وفقا لنوع الدالة في الحالة الثالثة نحتاج أحيانا لفتح فورم وإحضار بيانات محددة للعرض و يمكن من خلال توظيف الرمز فتح الفور مع اول سجل او كافة السجلات ويمكن استعراضها والتنقل بينها هنا لا داعي لمعرفة المعيار فقط رموز ونجوم يتم كتابتها بطريقة معينة وكذلك في الحالة الرابعة الفلترة يمكن فلترة كافة البيانات والتنقل بدون الحاجة لمعرفة المعيار والسؤال هل هذا هو الرمز الوحيد الذي يمكن استغلاله (') الاجابة لا ولكن ركزنا عليه لكونه الأكثر استخدام في قاعدة البيانات اخيرا هل يمكن انهاء المشكلة وخصوصا ان الرمز مطلوب للمعايير النصية نعم يمكن بتتبع المدخلات للحقول النصية المرتبطة باجراء ومن اسهل الطرق استخدام دالة Replace strPass = Replace(Me.U_Password, "'", "_") ايضا استخدام رسائل معالجة الاخطاء وتحديد الاجراء عند حدوث خطأ ونكتفي بهذا القدر عن الرمز (') وقد نتحدث غن رمز اخر لايقل خطورة والله الموفق الشايب

طيب و بمناسبة الرفع والشوط والله مش هزعلك اتفضل 1- Show And Hdie لاخفاء واظهار الامر الخاص باخفاء واظهار الملفات والمجلدات بعد الاخفاء سوف تكون بهذا الشكل طبعا اى مجلدات او ملفات مخفيه لن يستطيع المستخدم الذى يريد العبث اعادة اظهارها والاطلاع عليها لان أمر اظهار الملفات او المجلدات المخفيه اساسا اختفى 2- usb Open And Lock تفعيل / عدم تفعيل قراءة اى شئ من منفذ USB عند استخدام : USB LOOK لو عندك الف منفذ Usb ادخل بهم اى فلاشة او هردات محمولة لن يتم قرائتها مطلقا usb Open And Lock.zip Show And Hdie.zip

ما شاء الله ، مبدع فيما طرحت . أثار الموضوع اهتمامي سابقاً في مناقشة سابقة ومداخلة قوية لك ، مما جعلني أتحرى عن موضوع الحقن بشكل عميق وأحاول تنفيذه في مشاريعي تالياً .. ومن سياق الحديث الذي طرحته ، اعتقد أن استخدام المعلمات بدلاً من سلاسل نصية سيكون من خطوات الأمان التي قد يجب تنفيذها . أيضاً على ما أعتقد استخدامنا لمطهرات النصوص قد يأتي بنتيجة جيدة ومساعدة ,, على سبيل المثال ، هذه فكرة بسيطة أيضاً وقد تكون قابلة للتطوير والتحديث بشمولية ,, If InStr(Me.txtUser, "'") > 0 Or InStr(Me.txtUser, ";") > 0 Then MsgBox "تم استخدام رموز غير مسموح بها في اسم المستخدم", vbExclamation Exit Sub End If ولهذا السبب كنت قد استخدمت محاولة لم أقم بتجربتها بعد ، على أحد المشاريع باستخدام هذه الدالة :- Public Function Sanitizer(ByVal userInput As String, Optional ByVal context As String = "sql") As String Dim sanitized As String sanitized = Trim(userInput) Select Case LCase(context) Case "sql" sanitized = Replace(sanitized, "'", "''") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "--", "") Case "name" sanitized = Replace(sanitized, "'", "") sanitized = Replace(sanitized, ";", "") sanitized = Replace(sanitized, "*", "") sanitized = Replace(sanitized, "=", "") Case "pure" Case Else sanitized = Replace(sanitized, "'", "''") End Select Sanitizer = sanitized End Function وعلى سبيل المثال كإستخدام في الاستعلامات :- Dim filter As String filter = "[U_UserName]='" & Sanitizer(Me.txtUser, "sql") & "' AND [U_Password]='" & Sanitizer(Me.txtPass, "sql") & "'" DoCmd.OpenForm "frmDashboard", , , filter وكمثال على ما طرحته سابقاً لفتح نموذج بفلترة .. DoCmd.ApplyFilter , "[U_UserName]='" & Sanitizer(Me.txtSearch, "sql") & "'" أو حتى في نموذج تسجيل الدخول لاسم المستخدم ، كانت المحاولة :- Dim newUser As String newUser = Sanitizer(Me.txtNewUser, "name") هذه كانت الفكرة التي خطرت لي ، ولكن لاحقاً قمت بتحديثها لإظهار رسالة تحذيرية تلقائية إذا تم رصد مدخل خطير أو محاولات حقن نصية 😁

تفضل Sub FormatUniqueCellsInRow() Dim ws As Worksheet Dim lastRow As Long, startRow As Long Dim r As Long, i As Long, j As Long Dim values(1 To 7) As Variant Dim count As Long Dim data As Variant On Error GoTo ErrorHandler Set ws = ThisWorkbook.Sheets("Sheet1") ' تأكد من تغيير "Sheet1" إلى اسم الورقة الفعلي startRow = 3 ' الصف الذي تبدأ منه البيانات lastRow = ws.Range("C3:I" & ws.Rows.Count).Find(What:="*", _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row ' تنظيف التنسيقات السابقة من الأعمدة C:I و O With ws.Range("C" & startRow & ":I" & lastRow & ",O" & startRow & ":O" & lastRow) .Interior.ColorIndex = xlNone .Font.ColorIndex = xlAutomatic .Font.Bold = False End With ' تحميل النطاق إلى مصفوفة data = ws.Range("C" & startRow & ":I" & lastRow).Value ' المرور على كل صف For r = 1 To lastRow - startRow + 1 ' تخزين قيم الصف الحالي For i = 1 To 7 values(i) = data(r, i) Next i ' فحص القيم الفريدة For i = 1 To 7 count = 0 If Not IsEmpty(values(i)) Then For j = 1 To 7 If CStr(values(j)) = CStr(values(i)) Then count = count + 1 End If Next j ' إذا كانت القيمة فريدة If count = 1 Then ' تطبيق التنسيق على الخلية في C:I With ws.Cells(r + startRow - 1, i + 2) .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With ' تطبيق نفس التنسيق على الخلية في العمود O في نفس الصف With ws.Cells(r + startRow - 1, "O") .Interior.Color = RGB(255, 255, 0) ' تعبئة صفراء .Font.Color = RGB(255, 0, 0) ' خط أحمر .Font.Bold = True ' خط عريض End With End If End If Next i Next r MsgBox "تمت معالجة البيانات بنجاح!", vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Sub

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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا الخلية G2 ضع المعادلة التالية مع سحبها للأسفل =IFERROR(IF(G$6="قوى", IF(INDIRECT("'"&F$6&"'!L"&ROW()) <>"", INDIRECT("'"&F$6&"'!L"&ROW()), ""), IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!O"&ROW())<>"", INDIRECT("'"&F$6&"'!O"&ROW()), ""), "")),"") الخلية G2 =IFERROR(IF(G$6="قوى",IF(INDIRECT("'"&F$6&"'!M"&ROW()) <>"", INDIRECT("'"&F$6&"'!M"&ROW()), ""),IF(G$6="تامين", IF(INDIRECT("'"&F$6&"'!P"&ROW())<>"", INDIRECT("'"&F$6&"'!P"&ROW()), ""),"")),"") وفي خلية F6 ====> أسماء أوراق العمل يمكنك إتباع الخطوات التالية لجلب أسماء أوراق العمل للقائمة المنسدلة بشكل ديناميكي =OFFSET(F!$B$6, 0, 0, COUNTIF(F!$B$6:$B$10000, "<>"), 1) =NameWS BB.xlsx

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

بسيطة أخي الكريم ، الآن حسب ملفك المرفق ، جرب هذا التعديل :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long, colNum As Long Dim targetCell As Range On Error GoTo SafeExit Set chk = ActiveSheet.CheckBoxes(Application.Caller) If chk.TopLeftCell Is Nothing Then GoTo SafeExit Set rng = chk.TopLeftCell rowNum = rng.Row colNum = rng.Column Set targetCell = Cells(rowNum, colNum - 1) ' عدّل هنا : لتحديث الخلية اليمين = + 1 If chk.Value = xlOn Then If IsEmpty(targetCell.Value) Then targetCell.Value = Now End If ElseIf chk.Value = xlOff Then targetCell.ClearContents End If SafeExit: End Sub والتأكد من عدم وجود عناصر متشابهة في الإسم من الـ CheckBox ، وقم باستدعاء الماكرو لكل عنصر منهم .. * ملاحظة ، تستطيع التبديل بين الخلية اليمين أو اليسار التي سيتم عرض التاريخ و والوقت فيها على الملف كاملاً من خلال استبدال -1 بـ +1 فقط ، كما هو موضح في الكود . 222مربع اختيار يضيف التاريخ والوقت عند الاختيار.zip

هلا والله ... والله اشتقنا للأسف انا لم أكن اعرف المطلوب وضعت الإجابة بناء على السؤال حلوه النماذج الجميله اللى بتغير الوانها دى👍 بس فكرتى احلى 🤪 هو كده غلاسه 😆🫣

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

وعليكم السلام ورحمة الله وبركاته ,,, بعد عدة محاولات من خلال المعادلات ، وجدت أنه من الصعب عدم تحديث الخلايا الغير معنية بالإدراج ، لذا توجهت الى استخدام الماكرو التالي :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long For Each chk In ActiveSheet.CheckBoxes Set rng = chk.TopLeftCell rowNum = rng.Row If chk.Value = xlOn Then If IsEmpty(Cells(rowNum, "A").Value) Then Cells(rowNum, "A").Value = Now End If ElseIf chk.Value = xlOff Then Cells(rowNum, "A").ClearContents End If Next chk End Sub وعليه ، فيتم استدعائه في جميع الـ CheckBoxes التي لديك فقط ، دون ربط العناصر ببعضها .. ملفك بعد التعديل ، جرب وأخبرنا بالنتيجة مربع اختيار يضيف التاريخ والوقت عند الاختيار.zip

وعليكم السلام ورحمة الله تعالى وبركاته استاذى الجليل و معلمى القدير و والدى الحبيب الكود التالى فى وحده نمطية عامة Option Compare Database Option Explicit #If VBA7 Then 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 #Else 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 #End If Private lngTimerID As LongPtr Private frmTargetClock As Form Public Sub StartSystemClock(frm As Form) Set frmTargetClock = frm lngTimerID = SetTimer(0, 0, 1000, AddressOf TimerProc) End Sub Public Sub StopSystemClock() If lngTimerID <> 0 Then KillTimer 0, lngTimerID lngTimerID = 0 End If End Sub Private Sub TimerProc(ByVal hWnd As LongPtr, ByVal uMsg As Long, ByVal idEvent As LongPtr, ByVal dwTime As Long) If Not frmTargetClock Is Nothing Then frmTargetClock!lblClock.Caption = Format(Now, "hh:nn:ss AM/PM") Else StopSystemClock End If End Sub الاحدات فى النموذج Option Compare Database Option Explicit Private Sub Form_Load() Call StartSystemClock(Me) End Sub Private Sub Form_Unload(Cancel As Integer) Call StopSystemClock End Sub المرفق Clock Without Timer Event.accdb

تمام أخي الكريم ،، نستطيع تلافي المشكلة بإخفاء النموذج بشكل مؤقت أثناء المعاينة !! استخدم الكود التالي في زر المعاينة ، وجرب Private Sub btnPrint_Click() If lstResults.ListCount = 0 Then MsgBox "لا توجد نتائج لطباعتها", vbExclamation: Exit Sub End If Dim sh As Worksheet, nextRow As Long, i As Long, j As Long Const REPORT_SHEET As String = "تقرير الغياب" Me.Hide On Error Resume Next: Application.DisplayAlerts = False Worksheets(REPORT_SHEET).Delete Application.DisplayAlerts = True: On Error GoTo 0 Set sh = Worksheets.Add(After:=Worksheets(Worksheets.Count)) sh.Name = REPORT_SHEET For j = 0 To lstResults.ColumnCount - 1 sh.Cells(1, j + 1).Value = "العمود " & j + 1 Next j sh.Range("A1:" & sh.Cells(1, lstResults.ColumnCount).Address).Font.Bold = True nextRow = 2 For i = 0 To lstResults.ListCount - 1 For j = 0 To lstResults.ColumnCount - 1 sh.Cells(nextRow, j + 1).Value = lstResults.List(i, j) Next j nextRow = nextRow + 1 Next i sh.Columns.AutoFit sh.PageSetup.Orientation = xlPortrait sh.PageSetup.Zoom = False sh.PageSetup.FitToPagesWide = 1 sh.PageSetup.FitToPagesTall = 1 sh.PrintPreview Me.Show End Sub

كنت عامل موضوع بهذا الخصوص ولكن لتصفير و حذف بيانات أكثر من جدول ان اردت التوسع هذا رابط الموضوع https://www.officena.net/ib/topic/106503-حذف-بيانات-جداول-منضمة-ومرتبطه-دفعة-واحدة-على-حسب-اختيارك/#comment-642632

تفضل أخي عبدالعزيز @Abdelaziz Osman 🙂 هذا الاستعلام لو بتشغله في ال VBA : ' DELETE statement | جملة DELETE Dim sqlDelete As String sqlDelete = "DELETE FROM [TABINDX]" sqlDelete = sqlDelete & " WHERE [ID] = " & var_ID ' Execute The Query | تنفيذ الاستعلام CurrentDb.Execute sqlDelete وهذ لو بتشغله كاستعلام أكسس : DELETE FROM [TABINDX] WHERE [ID] = var_ID ولا تنسى أن تضع قيمة ال ID المطلوب حذفه مكان الـمتغير : var_ID ولو بتحذف كافة محتويات الجدول تكتب كذا : CurrentDb.Execute "DELETE FROM TABINDX"

احسنت وبارك الله فيك شكرا لتجاوبك تمت التجربة مع بعض التعديلات البسيطه وكانت فعاله Dim ctrl As Control For Each ctrl In Me.Controls If (ctrl.ControlType = acTextBox Or ctrl.ControlType = acComboBox) Then If (Nz(ctrl.Value, "") = "") Then MsgBox "يرجى تعبئة جميع الحقول قبل الحفظ." & vbCrLf & _ "الحقل الفارغ: " & ctrl.Name, vbExclamation ctrl.SetFocus Exit Sub End If End If Next ctrl ' إذا جميع الحقول تم تعبئتها، يتم الحفظ DoCmd.RunCommand acCmdSaveRecord MsgBox "تم الحفظ بنجاح بنجاح", 0 + 64 + 1048576, "مؤكد" DoCmd.Close

كثيرون استفسروا عن كيفية اختيار اسم مخزن في الجدول ، بدلاً من كتابة الرقم بشكل يدوي . ولذا قد صورت هذا الفيديو كفكرة سريعة على الخطوات - وصولاً إلى النتيجة ,, طبعاً كلمة كثيرون = في مجموعة الواتس أب الخاصة بقسم آكسيس وليس في المنتدى 🤣

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

تسلم .. بل صقر .. عندي برنامج صغير جدا يحذف حماية ميكروسوف نفسها من جذورها مع مجلداتها اقصد ببرنامج حماية اوفيس اللي هو microsoft Defender بترجع تقول اعمل حماية ما تقدر تدخل فلاشة ونستمر هكذا انا ارفع وانت تشوت ...

اتفضل الطريقة نعم بدون حبة الملح : Salt ولحالة آمن ولكن حبة الملح هذه تزيد من قوة التأمين فى فى التشفير جدا جدا جدا

لمنع موضوع الحق انا استخدم الداله Public Function SafeSql(strValue As String) As String If IsNull(strValue) Or strValue = "" Then SafeSql = "NULL" Else SafeSql = "'" & Replace(strValue, "'", "''") & "'" End If End Function وامرر لها اسم المستخدم وكلمة المرور strUserName = SafeSql(strUserName)

بعد إذن أساتذتي حل بالمعادلات بشكل مبسط BB (3).xlsx

و عليكم السلام ورحمة الله وبركاته أسهل شيء استخدام التنسيق الشرطي (2)2025 اسم التوكيل.xlsm

السبب هو أنه يوجد خلايا مدمجة ، فكيف سيتم تمييز في اي خلية سيتم ادراج التاريخ و الوقت !!!!! قمت بتعديل مواضع الـ CheckBox في ملفك ، وتعديل الدالة بحيث تتعامل مع الخلايا المدمجة ، لتصبح كالتالي :- Sub FokshCheckBox() Dim chk As CheckBox Dim rng As Range Dim rowNum As Long, colNum As Long Dim targetCell As Range Dim cbValue As Long On Error GoTo SafeExit Set chk = ActiveSheet.CheckBoxes(Application.Caller) cbValue = chk.Value If chk.TopLeftCell Is Nothing Then Exit Sub Set rng = chk.TopLeftCell rowNum = rng.Row colNum = rng.Column Set targetCell = Cells(rowNum, colNum + 1) If targetCell.MergeCells Then Set targetCell = targetCell.MergeArea.Cells(1, 1) End If If cbValue = xlOn Then If IsEmpty(targetCell.Value) Then targetCell.Value = Now End If ElseIf cbValue = xlOff Then targetCell.MergeArea.ClearContents End If SafeExit: End Sub اختيار التاريخ.xlsm

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

حسب ما فهمت انك عاوز تضيف كلمة الكل فى كل قائمة وهذا ما تم عموما قمت بتعديل على استعلام النموذج لتطبيق الفلتره ABDatabase.rar

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Sub Transfer() Dim code As Variant, c As Boolean Dim tmp(0 To 4) As Boolean, xDate As String, f As Long, i As Long, j As Long Dim lr As Long, lastRow As Long, linge As Long, xCode As Boolean, Irow As Range Dim ColArr As Long, xName As String, n As Variant, val As Variant Dim CrWS As Worksheet: Set CrWS = Sheets("Sheet2") Dim Data As Worksheet: Set Data = Sheets("Sheet3") xDate = Format(CrWS.Range("D2").Value, "dd/mm/yyyy") If xDate = "" Then MsgBox "المرجوا تحديد التاريخ", vbInformation: Exit Sub With Data For ColArr = .Columns("E").Column To .Cells(3, .Columns.Count).End(xlToLeft).Column If Format(.Cells(3, ColArr).Value, "dd/mm/yyyy") = xDate Then f = ColArr: Exit For End If Next ColArr If f = 0 Then MsgBox "لم يتم العثور على التاريخ", vbExclamation: Exit Sub Set Irow = .Columns("E:P").Find(What:="*", SearchDirection:=xlPrevious, SearchOrder:=xlByRows) lr = IIf(Not Irow Is Nothing And Irow.row >= 5, Irow.row, 5) .Range(.Cells(5, f), .Cells(lr, f + 4)).ClearContents End With lastRow = CrWS.Cells(CrWS.Rows.Count, "C").End(xlUp).row xCode = False: c = False For i = 12 To lastRow code = CrWS.Cells(i, "C").Value If code <> "" Then linge = Data.Cells(Data.Rows.Count, "D").End(xlUp).row n = Application.Match(code, Data.Range("D6:D" & linge), 0) If Not IsError(n) Then xCode = True For j = 0 To 4 xName = CrWS.Cells(10, 4 + j).Value For ColArr = 0 To 4 If Data.Cells(4, f + ColArr).Value = xName Then val = CrWS.Cells(i, 4 + j).Value If Not IsEmpty(val) Then Data.Cells(n + 5, f + ColArr).Value = val c = True If Not tmp(j) Then Data.Cells(5, f + ColArr).Value = CrWS.Cells(11, 4 + j).Value tmp(j) = True End If End If Exit For End If Next ColArr Next j End If End If Next i Select Case True Case c MsgBox "تم ترحيل البيانات بنجاح", vbInformation Case Not xCode MsgBox "لم يتم العثور على أي أكواد مطابقة", vbExclamation Case Else MsgBox "لا توجد بيانات لترحيلها", vbInformation End Select End Sub Book3.xlsb

استاذى الجليل و معلمى القدير و والدى الحبيب الاستاذ @ابوخليل أهديكم هذا المرفق يحتوى على الساعتين الرقمية والعقارب وبدون حدث الوقت وبه هديه لتغيير ثيم النموذج كذلك AnalogClock Without Timer Event.zip

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

جربت كلها تعمل ويبدو ان الثاني افضل كونه يعمل بالخفاء ................................. ولكن الاخير شامل كامل .. فقط من رؤيته وقبل ان اجرب بارك الله فيك وزادك علما .. الف شكر

يتم عمل الحماية للمجلد كما اشرت يتم فتح قاعدة البيانات الامامية من خلال قاعدة مشفرة accde ولا ننسى توفيرها مره للنواة 32 بت ومرة أخرى للنواة 64 بت ويمكن للمبرمج الاحتفاظ بالقاعدة قبل التشفير واستخدامها مع كل تطبيقاته لو استخدم نفس تشفير القواعد الامامية بنفس كلمة المرور وظيفتها تمرير كلمة المرور للقاعدة الامامية المشفرة لفتحها وطبعا القاعدة الخلفية للجداول سوف تكون مشفرة بكلمة مرور كذلك ربط الجداول من القاعدة الامامية سوف يمرر كلمة المرور للارتباط او اعاادة الاتصال بالقاعدة الخلفية القاعدتان الامامية والخلفية وكذلك القاعدة الوسيطة والتى وظيفتها فتح القاعدة الاماميه نستخدم معهم اخفاء الاطار نهائيا ايقاف مفاتيح الهوت كى لمنع فتح المحرر ايقاف عمل مفتاح الشيفت ولو اردتم اضافة معالجة لتحديد صلاحيات المستخدمين او مجموعات العمل للقاعدة الامامية تلكم الافكار مجتمعة معا تكون حماية لن أقول يستحيل كسرها او تخطيها بل سوف أكتفى بالقول بأنها سوف تكون قوية قوية فوية فوية قوية جدا جدا جدا جدا لا بأس بها ويصعب تجاوزها وكسرها وممكن احفاء كلمة مرور الاتصال لجهاز السيرفر عن المستخدمين اساسا وتتم عملية الاتصال مبدئيا بجهاز السيرفر من خلال حفظ معلومات الاتصال (حفظ بيانات الاعتماد ) من خلال اول نموذج وكل ما سبق موجود فى المنتدى

تعملها ويطلع منك

ما هو لو حد رخم زى حلاتى ممكن يكون عامل حماية للمجلد من حذف ما فيه

تحويل الدالة الى دالة عامة ، يتم استدعائها في أي نموذج ، توسيع الفكرة اختيار التاريخ لا يعمل بشيت b-c-d.xlsm ملاحظة مهمة ، يجب ان يكون الـ CheckBox بجانب الخلية المستهدف إدرا الوقت والتاريخ فيها . أي على يسار الخلية وإذا كانت الخلية المستهدفة على اليسار ، نقوم باستبدال الجزء +1 الى -1 في الدالة داخل المديول

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

اللهم اغفر له وارحمه واجعله مثواه الجنة والهم أهله وذويه الصبر والسلوان

انت الأستاذ وانت المعلم وانت الأبن الحبيب ينتهي المقال عند عرض المثال الف شكر باشمهند وفيت وكفيت هذا الكود او بالاصح قريبا منه كان عندي وحاولت التعامل معه داخل النموذج ولم افلح

طيب تمام ، جرب هذه الفكرة السريعة ، وباعتقادي قد تجد أفكار أفضل 100% من الأخوة والأساتذة والمعلمين هنا .. الجمعية 29.zip

السلام عليكم ورحمة الله تعالى وبركاته بعد مرورى على موضوع استاذى الجليل واخى الحبيب الاستاذ @Foksh والموضوع هو فى هذه >---->> المشاركة من هنا طلبت منه العب شويه بعد الاطلاع والتجربه على افكاره النيره وتطبيقه الاكثر من رائع وبجد الاول فى عرض فكرته تقريبا ولكن لن يكون الأخير فنحن هنا وحتما ولابد أن نضع بصمتنا زعق لى وقالى اجرى العب بعيد ياض من هنا لحسن ارش ميه 😡 قلت اجى العب هنا لحالى ولوحدى - وظيفة المرفق هى : ضبط وتعديل اللغة المستخدمة في البرامج غير الموحدة ( language for non-Unicode programs ) بس خلاص واترككم واتمنى لكم تجربة ممتعه شيقة مع المرفق الذى يحتوى على نموذجين الاول بالعربى لمن يريد , والثانى بالانجليزية لمن يريد فى انتظار أرائكم يا سادة ونحن لا نقيد أحد بل نضع الافكار بأكبر قدر ممكن من المرونة التى يمكن الحصول عليها والتعامل على هذا الاساس الاكود المستخدمة للنموذج الانجليزى ' Define constant messages to be used in the program Private Const MSG_RESTART_SOON As String = "The computer will restart in 15 seconds" Private Const MSG_SAVE_FILES As String = "Please save all open files" Private Const MSG_CANT_RUN As String = "Your project cannot run without changing the system locale to Arabic" ' Define API functions based on the VBA version #If VBA7 Then ' 64-bit version Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As LongPtr, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As LongPtr) As Long Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As LongPtr, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As LongPtr) As Long Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32" () As Long #Else ' 32-bit version Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As Long) As Long Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long #End If ' Constants for use with Windows API Private Const HKEY_LOCAL_MACHINE As Long = &H80000002 Private Const KEY_QUERY_VALUE As Long = &H1 Private Const KEY_WOW64_64KEY As Long = &H100 Private Const KEY_WOW64_32KEY As Long = &H200 Private Const REG_SZ As Long = 1 ' Define a custom type "country" to store country information Private Type country countryCode As String ' Country code (e.g., "EG") countryName As String ' Country name (e.g., "Egypt") fullCountryName As String ' Full country name (e.g., "Arab Republic of Egypt") localeName As String ' Locale name (e.g., "ar-EG") localeID As String ' Locale ID (e.g., "00000C01") code As String ' Country calling code (e.g., "20") nativeLanguage As String ' Native language with country (e.g., "Arabic (Egypt)") End Type ' Define an array to store country settings Private countries() As country ' Define a variable to store the current country settings Private countrySettings As country Private Sub SetCountryData(countryCode As String, countryName As String, fullCountryName As String, localeName As String, localeID As String, code As String, nativeLanguage As String) ' Define a variable of type "country" to store the current country data Dim currentCountry As country ' Assign data values to the currentCountry variable currentCountry.countryCode = countryCode ' Country code currentCountry.countryName = countryName ' Country name currentCountry.fullCountryName = fullCountryName ' Full country name currentCountry.localeName = localeName ' Locale name currentCountry.localeID = localeID ' Locale ID currentCountry.code = code ' Country calling code currentCountry.nativeLanguage = nativeLanguage ' Native language with country ' Increase the size of the "countries" array while preserving existing data (ReDim Preserve) ReDim Preserve countries(UBound(countries) + 1) ' Add the current country data to the array countries(UBound(countries)) = currentCountry End Sub ' Function to check the current system language Private Function IsSystemLanguage(ByVal targetLocaleName As String, ByVal targetLocaleID As String) As Boolean ' Define variables Dim wshShell As Object ' WScript.Shell object to access the system registry Dim currentLocaleName As String ' To store the current system LocaleName Dim currentLocaleID As String ' To store the current system LocaleID ' Create a WScript.Shell object Set wshShell = CreateObject("WScript.Shell") ' Temporarily ignore errors to avoid program stoppage if registry keys are missing On Error Resume Next ' Read the LocaleName value from the system registry currentLocaleName = wshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\LocaleName") ' Read the LocaleID value from the system registry currentLocaleID = wshShell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Language\Default") ' Re-enable normal error handling On Error GoTo 0 ' Compare the current LocaleName and LocaleID with the target values If currentLocaleName = targetLocaleName And currentLocaleID = targetLocaleID Then ' If the values match, return True IsSystemLanguage = True Else ' If the values do not match, return False IsSystemLanguage = False End If End Function Private Sub CheckSystemLanguage() ' Define variables Dim targetLocaleName As String ' To store the target LocaleName Dim targetLocaleID As String ' To store the target LocaleID Dim isLanguageMatch As Boolean ' To store the result of the language check ' Set the target values targetLocaleName = "en-US" ' Target language: English - United States targetLocaleID = "0409" ' Target language ID: English - United States ' Call the IsSystemLanguage function to check if the language matches isLanguageMatch = IsSystemLanguage(targetLocaleName, targetLocaleID) ' Display the result based on the function's return value If isLanguageMatch Then ' If the language matches, show a confirmation message MsgBox "The system language matches the target language: " & targetLocaleName, vbInformation, "Language Check" Else ' If the language does not match, show a warning message with details MsgBox "The system language does NOT match the target language: " & targetLocaleName & vbNewLine & _ "Current Locale Name: " & targetLocaleName & vbNewLine & _ "Current Locale ID: " & targetLocaleID, vbExclamation, "Language Check" End If End Sub Private Sub LogError(ByVal errorMessage As String) ' Temporarily ignore errors to avoid program stoppage if an error occurs during logging On Error Resume Next ' Define variables Dim fso As Object ' FileSystemObject to handle files Dim logFile As Object ' TextStream object to write data to the file Dim desktopPath As String ' Desktop path Dim logFilePath As String ' Full path to the error log file ' Get the desktop path using WScript.Shell desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") ' Define the full path to the error log file logFilePath = desktopPath & "\ChangeLanguageErrorLog.txt" ' Create a FileSystemObject to handle files Set fso = CreateObject("Scripting.FileSystemObject") ' Open the error log file for writing (8 means append, True means create the file if it doesn't exist) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' Write the error message and timestamp to the file logFile.WriteLine "Error: " & errorMessage & vbCrLf & "Timestamp: " & Now ' Close the file after writing logFile.Close ' Re-enable normal error handling On Error GoTo 0 End Sub Private Sub ChangeSystemLanguage(Optional restartDelay As Integer = 15) ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Define variables Dim fso As Object ' FileSystemObject to handle files Dim batFile As Object ' TextStream object to write the batch file Dim logFile As Object ' TextStream object to write the log file Dim desktopPath As String ' Desktop path Dim batFilePath As String ' Full path to the batch file Dim logFilePath As String ' Full path to the log file Dim newLanguage As String ' New language (not used in the current code) Dim countryCode As String ' Country code Dim localeID As String ' Locale ID Dim localeName As String ' Locale name Dim countryName As String ' Country name ' Get the details of the selected country countryCode = countrySettings.countryCode localeID = countrySettings.localeID localeName = countrySettings.localeName countryName = countrySettings.countryName ' Get the desktop path desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") batFilePath = desktopPath & "\ChangeLanguage.bat" logFilePath = desktopPath & "\ChangeLanguageLog.txt" ' Create a FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' Create the batch file Set batFile = fso.CreateTextFile(batFilePath, True) ' Open the log file for appending Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' Write commands to the batch file With batFile .WriteLine "@echo off" ' Disable command display in the command window .WriteLine "chcp 1256" ' Change the code page to 1256 (for Arabic support) .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & localeName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & countryName & " /f" .WriteLine "shutdown /r /f /t " & restartDelay ' Restart the computer after a specified delay .Close ' Close the batch file End With ' Execute the batch file to change the language and restart Shell batFilePath, vbNormalFocus ' Notify the user about the language change and restart MsgBox "Language change is in progress. Your computer will restart in " & restartDelay & " seconds.", vbInformation, "Changing Language" ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Log the error in the log file LogError "Error in ChangeSystemLanguage: " & Err.Description ' Show an error message to the user MsgBox "An error occurred while changing the system language.", vbCritical End Sub Private Function IsArabicLanguage() As Boolean ' Define a variable to store the current system code page Dim CodePage As Long ' Get the current code page using the GetACP function CodePage = GetACP() ' Check if the code page is 1256 (Arabic) IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As country ' Search for the country in the array based on the country code Dim i As Integer For i = 0 To UBound(countries) If UCase(countries(i).countryName) = UCase(countryCode) Then ' If the country is found, return its details GetArabicCountrySettings = countries(i) Exit Function End If Next i ' If the country is not found, return Saudi Arabia as the default GetArabicCountrySettings = countries(4) ' Saudi Arabia End Function Sub LoadCountries() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Initialize the size of the countries array ReDim countries(0) ' Add country data to the array using the SetCountryData function ' Arabic Countries SetCountryData "AE", "UAE", "United Arab Emirates", "ar-AE", "00003801", "971", "Arabic (UAE)" SetCountryData "BH", "Bahrain", "Bahrain", "ar-BH", "00003C01", "973", "Arabic (Bahrain)" SetCountryData "DZ", "Algeria", "Algeria", "ar-DZ", "00001401", "213", "Arabic (Algeria)" SetCountryData "EG", "Egypt", "Egypt", "ar-EG", "00000C01", "20", "Arabic (Egypt)" SetCountryData "IQ", "Iraq", "Iraq", "ar-IQ", "00000801", "964", "Arabic (Iraq)" SetCountryData "JO", "Jordan", "Jordan", "ar-JO", "00000409", "962", "Arabic (Jordan)" SetCountryData "KW", "Kuwait", "Kuwait", "ar-KW", "00003401", "965", "Arabic (Kuwait)" SetCountryData "LB", "Lebanon", "Lebanon", "ar-LB", "00003001", "961", "Arabic (Lebanon)" SetCountryData "LY", "Libya", "Libya", "ar-LY", "00001001", "218", "Arabic (Libya)" SetCountryData "MA", "Morocco", "Morocco", "ar-MA", "00001801", "212", "Arabic (Morocco)" SetCountryData "MR", "Mauritania", "Mauritania", "ar-MR", "00001801", "222", "Arabic (Mauritania)" SetCountryData "OM", "Oman", "Oman", "ar-OM", "00002001", "968", "Arabic (Oman)" SetCountryData "PS", "Palestine", "Palestine", "ar-PS", "00000401", "970", "Arabic (Palestine)" SetCountryData "QA", "Qatar", "Qatar", "ar-QA", "00004001", "974", "Arabic (Qatar)" SetCountryData "SA", "Saudi Arabia", "Saudi Arabia", "ar-SA", "00000401", "966", "Arabic (Saudi Arabia)" SetCountryData "SD", "Sudan", "Sudan", "ar-SD", "00002C01", "249", "Arabic (Sudan)" SetCountryData "SO", "Somalia", "Somalia", "ar-SO", "00000401", "252", "Arabic (Somalia)" SetCountryData "SY", "Syria", "Syria", "ar-SY", "00002801", "963", "Arabic (Syria)" SetCountryData "TN", "Tunisia", "Tunisia", "ar-TN", "00001C01", "216", "Arabic (Tunisia)" SetCountryData "YE", "Yemen", "Yemen", "ar-YE", "00002401", "967", "Arabic (Yemen)" ' Chinese Countries SetCountryData "CN", "China", "China", "zh-CN", "00000804", "86", "Chinese (China)" SetCountryData "TW", "Taiwan", "Taiwan", "zh-TW", "00000404", "886", "Chinese (Taiwan)" SetCountryData "HK", "Hong Kong", "Hong Kong", "zh-HK", "00000C04", "852", "Chinese (Hong Kong)" SetCountryData "SG", "Singapore", "Singapore", "zh-SG", "00001004", "65", "Chinese (Singapore)" ' English Countries SetCountryData "AU", "Australia", "Australia", "en-AU", "00000C09", "61", "English (Australia)" SetCountryData "CA", "Canada", "Canada", "en-CA", "00001009", "1", "English (Canada)" SetCountryData "GB", "UK", "United Kingdom", "en-GB", "00000809", "44", "English (UK)" SetCountryData "IE", "Ireland", "Ireland", "en-IE", "00001809", "353", "English (Ireland)" SetCountryData "IN", "India", "India", "en-IN", "00000409", "91", "English (India)" SetCountryData "NG", "Nigeria", "Nigeria", "en-NG", "00000409", "234", "English (Nigeria)" SetCountryData "NZ", "New Zealand", "New Zealand", "en-NZ", "00001409", "64", "English (New Zealand)" SetCountryData "PH", "Philippines", "Philippines", "en-PH", "00000409", "63", "English (Philippines)" SetCountryData "US", "USA", "United States of America", "en-US", "00000409", "1", "English (US)" SetCountryData "ZA", "South Africa", "South Africa", "en-ZA", "00000409", "27", "English (South Africa)" ' French Countries SetCountryData "BE", "Belgium", "Belgium", "fr-BE", "0000080C", "32", "French (Belgium)" SetCountryData "CA", "Canada", "Canada", "fr-CA", "00000C0C", "1", "French (Canada)" SetCountryData "CH", "Switzerland", "Switzerland", "fr-CH", "0000100C", "41", "French (Switzerland)" SetCountryData "FR", "France", "France", "fr-FR", "0000040C", "33", "French (France)" SetCountryData "LU", "Luxembourg", "Luxembourg", "fr-LU", "0000140C", "352", "French (Luxembourg)" SetCountryData "SN", "Senegal", "Senegal", "fr-SN", "0000040C", "221", "French (Senegal)" ' German Countries SetCountryData "AT", "Austria", "Austria", "de-AT", "00000407", "43", "German (Austria)" SetCountryData "CH", "Switzerland", "Switzerland", "de-CH", "00000807", "41", "German (Switzerland)" SetCountryData "DE", "Germany", "Germany", "de-DE", "00000407", "49", "German (Germany)" SetCountryData "LI", "Liechtenstein", "Liechtenstein", "de-LI", "00001007", "423", "German (Liechtenstein)" ' Hindi Countries SetCountryData "IN", "India", "India", "hi-IN", "00000439", "91", "Hindi (India)" ' Indonesian Countries SetCountryData "ID", "Indonesia", "Indonesia", "id-ID", "00000421", "62", "Indonesian (Indonesia)" ' Italian Countries SetCountryData "IT", "Italy", "Italy", "it-IT", "00000410", "39", "Italian (Italy)" SetCountryData "SM", "San Marino", "San Marino", "it-SM", "00000410", "378", "Italian (San Marino)" SetCountryData "VA", "Vatican City", "Vatican City", "it-VA", "00000410", "379", "Italian (Vatican City)" ' Japanese Countries SetCountryData "JP", "Japan", "Japan", "ja-JP", "00000411", "81", "Japanese (Japan)" ' Korean Countries SetCountryData "KR", "South Korea", "South Korea", "ko-KR", "00000412", "82", "Korean (South Korea)" SetCountryData "KP", "North Korea", "North Korea", "ko-KP", "00000412", "850", "Korean (North Korea)" ' Portuguese Countries SetCountryData "BR", "Brazil", "Brazil", "pt-BR", "00000416", "55", "Portuguese (Brazil)" SetCountryData "PT", "Portugal", "Portugal", "pt-PT", "00000816", "351", "Portuguese (Portugal)" SetCountryData "AO", "Angola", "Angola", "pt-AO", "00000416", "244", "Portuguese (Angola)" SetCountryData "MZ", "Mozambique", "Mozambique", "pt-MZ", "00000416", "258", "Portuguese (Mozambique)" ' Russian Countries SetCountryData "RU", "Russia", "Russia", "ru-RU", "00000419", "7", "Russian (Russia)" SetCountryData "BY", "Belarus", "Belarus", "ru-BY", "00000419", "375", "Russian (Belarus)" SetCountryData "KZ", "Kazakhstan", "Kazakhstan", "ru-KZ", "00000419", "7", "Russian (Kazakhstan)" SetCountryData "KG", "Kyrgyzstan", "Kyrgyzstan", "ru-KG", "00000419", "996", "Russian (Kyrgyzstan)" ' Spanish Countries SetCountryData "AR", "Argentina", "Argentina", "es-AR", "00002C0A", "54", "Spanish (Argentina)" SetCountryData "BO", "Bolivia", "Bolivia", "es-BO", "00002C0A", "591", "Spanish (Bolivia)" SetCountryData "CL", "Chile", "Chile", "es-CL", "00002C0A", "56", "Spanish (Chile)" SetCountryData "CO", "Colombia", "Colombia", "es-CO", "00002C0A", "57", "Spanish (Colombia)" SetCountryData "CR", "Costa Rica", "Costa Rica", "es-CR", "00002C0A", "506", "Spanish (Costa Rica)" SetCountryData "CU", "Cuba", "Cuba", "es-CU", "00002C0A", "53", "Spanish (Cuba)" SetCountryData "DO", "Dominican Republic", "Dominican Republic", "es-DO", "00002C0A", "1", "Spanish (Dominican Republic)" SetCountryData "EC", "Ecuador", "Ecuador", "es-EC", "00002C0A", "593", "Spanish (Ecuador)" SetCountryData "ES", "Spain", "Spain", "es-ES", "0000040A", "34", "Spanish (Spain)" SetCountryData "GT", "Guatemala", "Guatemala", "es-GT", "00002C0A", "502", "Spanish (Guatemala)" SetCountryData "HN", "Honduras", "Honduras", "es-HN", "00002C0A", "504", "Spanish (Honduras)" SetCountryData "MX", "Mexico", "Mexico", "es-MX", "0000080A", "52", "Spanish (Mexico)" SetCountryData "NI", "Nicaragua", "Nicaragua", "es-NI", "00002C0A", "505", "Spanish (Nicaragua)" SetCountryData "PA", "Panama", "Panama", "es-PA", "00002C0A", "507", "Spanish (Panama)" SetCountryData "PE", "Peru", "Peru", "es-PE", "00002C0A", "51", "Spanish (Peru)" SetCountryData "PR", "Puerto Rico", "Puerto Rico", "es-PR", "00002C0A", "1", "Spanish (Puerto Rico)" SetCountryData "PY", "Paraguay", "Paraguay", "es-PY", "00002C0A", "595", "Spanish (Paraguay)" SetCountryData "SV", "El Salvador", "El Salvador", "es-SV", "00002C0A", "503", "Spanish (El Salvador)" SetCountryData "UY", "Uruguay", "Uruguay", "es-UY", "00002C0A", "598", "Spanish (Uruguay)" SetCountryData "VE", "Venezuela", "Venezuela", "es-VE", "00002C0A", "58", "Spanish (Venezuela)" ' Turkish Countries SetCountryData "TR", "Turkey", "Turkey", "tr-TR", "0000041F", "90", "Turkish (Turkey)" SetCountryData "CY", "Cyprus", "Cyprus", "tr-CY", "0000041F", "357", "Turkish (Cyprus)" ' Check if the cmbLanguage control exists in the form If Not Me.cmbLanguage Is Nothing Then ' Clear old items from the combo box Me.cmbLanguage = "" ' Populate the combo box with full country names from the array Dim i As Integer For i = 1 To UBound(countries) Me.cmbLanguage.AddItem countries(i).nativeLanguage Next i Else ' Show an error message if the combo box is not found MsgBox "The combo box 'cmbLanguage' could not be found.", vbCritical End If ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Log the error using the LogError function LogError "Error in LoadCountries: " & Err.Description ' Show an error message to the user MsgBox "An error occurred while loading countries.", vbCritical End Sub Private Sub Form_Load() ' Load country names into the combo box LoadCountries ' Set the default language (Egypt) in the combo box cmbLanguage.Value = "Arabic (Egypt)" ' Set the default country details (Egypt) countrySettings = GetArabicCountrySettings("EG") ' Display the country name in the text box txtConteryName.Value = GetNonUnicodeLanguage() End Sub Private Sub cmbLanguage_Change() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Get the selected country name from the combo box Dim selectedCountryName As String selectedCountryName = Me.cmbLanguage.Value ' Search for the selected country in the array Dim i As Integer For i = 1 To UBound(countries) If countries(i).nativeLanguage = selectedCountryName Then ' If the country is found, save its details countrySettings = countries(i) Exit For End If Next i ' Display a message based on the search result If i <= UBound(countries) Then MsgBox "Selected language: " & selectedCountryName, vbInformation, "Language Selected" Else MsgBox "The language was not found in the list.", vbExclamation, "Error" End If ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Show an error message if a problem occurs MsgBox "An error occurred while selecting the language.", vbCritical, "Error" End Sub Private Sub btnLanguage_Click() ' Error handling: If an error occurs, go to ErrorHandler On Error GoTo ErrorHandler ' Check if a language has been selected from the list If countrySettings.countryCode = "" Then MsgBox "Please select a language from the list.", vbExclamation, "Language Selection" Exit Sub End If ' Execute the language change with a 15-second delay before restarting Call ChangeSystemLanguage(15) ' Notify the user that the language change will occur and the system will restart soon MsgBox "The language has been successfully selected. The system will restart in 15 seconds.", vbInformation, "Language Change" ' Exit the procedure without executing the error handler code Exit Sub ErrorHandler: ' Show an error message if a problem occurs MsgBox "An error occurred while attempting to change the language.", vbCritical, "Error" End Sub Private Function GetRegistryValue(ByVal keyPath As String, ByVal valueName As String) As String #If VBA7 Then ' 64-bit version Dim hKey As LongPtr #Else ' 32-bit version Dim hKey As Long #End If Dim ret As Long Dim valueType As Long Dim valueData As String Dim dataLength As Long ' Open the registry key ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, keyPath, 0, KEY_QUERY_VALUE Or KEY_WOW64_64KEY, hKey) If ret = 0 Then ' Determine the data size ret = RegQueryValueEx(hKey, valueName, 0, valueType, vbNullString, dataLength) If ret = 0 And valueType = REG_SZ Then ' Read the data valueData = String(dataLength, Chr(0)) ret = RegQueryValueEx(hKey, valueName, 0, valueType, valueData, dataLength) If ret = 0 Then ' Remove trailing null characters GetRegistryValue = Left(valueData, dataLength - 1) End If End If ' Close the registry key RegCloseKey (hKey) End If End Function Private Function GetNonUnicodeLanguage() As String Dim localeID As String ' Read the registry value localeID = GetRegistryValue("SYSTEM\CurrentControlSet\Control\Nls\Language", "Default") ' Convert the value to Long Dim localeIDLong As Long localeIDLong = Val("&H" & localeID) ' Use Locale ID to determine the language Select Case localeIDLong ' Arabic Countries Case &H401: GetNonUnicodeLanguage = "Arabic (Saudi Arabia)" Case &H801: GetNonUnicodeLanguage = "Arabic (Iraq)" Case &HC01: GetNonUnicodeLanguage = "Arabic (Egypt)" Case &H1001: GetNonUnicodeLanguage = "Arabic (Libya)" Case &H1401: GetNonUnicodeLanguage = "Arabic (Algeria)" Case &H1801: GetNonUnicodeLanguage = "Arabic (Morocco)" Case &H1C01: GetNonUnicodeLanguage = "Arabic (Tunisia)" Case &H2001: GetNonUnicodeLanguage = "Arabic (Oman)" Case &H2401: GetNonUnicodeLanguage = "Arabic (Yemen)" Case &H2801: GetNonUnicodeLanguage = "Arabic (Syria)" Case &H2C01: GetNonUnicodeLanguage = "Arabic (Jordan)" Case &H3001: GetNonUnicodeLanguage = "Arabic (Lebanon)" Case &H3401: GetNonUnicodeLanguage = "Arabic (Kuwait)" Case &H3801: GetNonUnicodeLanguage = "Arabic (UAE)" Case &H3C01: GetNonUnicodeLanguage = "Arabic (Bahrain)" Case &H4001: GetNonUnicodeLanguage = "Arabic (Qatar)" ' English Countries Case &H409: GetNonUnicodeLanguage = "English (United States)" Case &H809: GetNonUnicodeLanguage = "English (United Kingdom)" Case &HC09: GetNonUnicodeLanguage = "English (Australia)" Case &H1009: GetNonUnicodeLanguage = "English (Canada)" Case &H1409: GetNonUnicodeLanguage = "English (New Zealand)" Case &H1809: GetNonUnicodeLanguage = "English (Ireland)" Case &H1C09: GetNonUnicodeLanguage = "English (South Africa)" Case &H2009: GetNonUnicodeLanguage = "English (Jamaica)" Case &H2409: GetNonUnicodeLanguage = "English (Caribbean)" Case &H2809: GetNonUnicodeLanguage = "English (Belize)" Case &H2C09: GetNonUnicodeLanguage = "English (Trinidad)" Case &H3009: GetNonUnicodeLanguage = "English (Zimbabwe)" Case &H3409: GetNonUnicodeLanguage = "English (Philippines)" Case &H3809: GetNonUnicodeLanguage = "English (India)" ' French Countries Case &H40C: GetNonUnicodeLanguage = "French (France)" Case &H80C: GetNonUnicodeLanguage = "French (Belgium)" Case &HC0C: GetNonUnicodeLanguage = "French (Canada)" Case &H100C: GetNonUnicodeLanguage = "French (Switzerland)" Case &H140C: GetNonUnicodeLanguage = "French (Luxembourg)" Case &H180C: GetNonUnicodeLanguage = "French (Monaco)" Case &H1C0C: GetNonUnicodeLanguage = "French (Senegal)" ' German Countries Case &H407: GetNonUnicodeLanguage = "German (Germany)" Case &H807: GetNonUnicodeLanguage = "German (Switzerland)" Case &HC07: GetNonUnicodeLanguage = "German (Austria)" Case &H1007: GetNonUnicodeLanguage = "German (Liechtenstein)" ' Hindi Countries Case &H439: GetNonUnicodeLanguage = "Hindi (India)" ' Indonesian Countries Case &H421: GetNonUnicodeLanguage = "Indonesian (Indonesia)" ' Italian Countries Case &H410: GetNonUnicodeLanguage = "Italian (Italy)" Case &H810: GetNonUnicodeLanguage = "Italian (Switzerland)" Case &HC10: GetNonUnicodeLanguage = "Italian (San Marino)" Case &H1010: GetNonUnicodeLanguage = "Italian (Vatican City)" ' Japanese Countries Case &H411: GetNonUnicodeLanguage = "Japanese (Japan)" ' Korean Countries Case &H412: GetNonUnicodeLanguage = "Korean (South Korea)" Case &H812: GetNonUnicodeLanguage = "Korean (North Korea)" ' Portuguese Countries Case &H416: GetNonUnicodeLanguage = "Portuguese (Brazil)" Case &H816: GetNonUnicodeLanguage = "Portuguese (Portugal)" Case &HC16: GetNonUnicodeLanguage = "Portuguese (Angola)" Case &H1016: GetNonUnicodeLanguage = "Portuguese (Mozambique)" ' Russian Countries Case &H419: GetNonUnicodeLanguage = "Russian (Russia)" Case &H819: GetNonUnicodeLanguage = "Russian (Belarus)" Case &HC19: GetNonUnicodeLanguage = "Russian (Kazakhstan)" Case &H1019: GetNonUnicodeLanguage = "Russian (Kyrgyzstan)" ' Spanish Countries Case &H40A: GetNonUnicodeLanguage = "Spanish (Spain)" Case &H80A: GetNonUnicodeLanguage = "Spanish (Mexico)" Case &HC0A: GetNonUnicodeLanguage = "Spanish (Argentina)" Case &H100A: GetNonUnicodeLanguage = "Spanish (Colombia)" Case &H140A: GetNonUnicodeLanguage = "Spanish (Peru)" Case &H180A: GetNonUnicodeLanguage = "Spanish (Venezuela)" Case &H1C0A: GetNonUnicodeLanguage = "Spanish (Chile)" Case &H200A: GetNonUnicodeLanguage = "Spanish (Ecuador)" Case &H240A: GetNonUnicodeLanguage = "Spanish (Guatemala)" Case &H280A: GetNonUnicodeLanguage = "Spanish (Cuba)" Case &H2C0A: GetNonUnicodeLanguage = "Spanish (Bolivia)" Case &H300A: GetNonUnicodeLanguage = "Spanish (Dominican Republic)" Case &H340A: GetNonUnicodeLanguage = "Spanish (Puerto Rico)" Case &H380A: GetNonUnicodeLanguage = "Spanish (Uruguay)" Case &H3C0A: GetNonUnicodeLanguage = "Spanish (Paraguay)" Case &H400A: GetNonUnicodeLanguage = "Spanish (Costa Rica)" Case &H440A: GetNonUnicodeLanguage = "Spanish (El Salvador)" Case &H480A: GetNonUnicodeLanguage = "Spanish (Honduras)" Case &H4C0A: GetNonUnicodeLanguage = "Spanish (Nicaragua)" Case &H500A: GetNonUnicodeLanguage = "Spanish (Panama)" ' Turkish Countries Case &H41F: GetNonUnicodeLanguage = "Turkish (Turkey)" Case &H81F: GetNonUnicodeLanguage = "Turkish (Cyprus)" ' Default Case Case Else: GetNonUnicodeLanguage = "Unknown (Locale ID: " & localeID & ")" End Select End Function الاكواد المستخدمة فى النموذج العربى Option Compare Database Option Explicit ' تعريف الرسائل الثابتة التي سيتم استخدامها في البرنامج Private Const MSG_RESTART_SOON As String = "سيتم إعادة تشغيل الكمبيوتر خلال 15 ثانية" Private Const MSG_SAVE_FILES As String = "يرجى حفظ جميع الملفات المفتوحة" Private Const MSG_CANT_RUN As String = "لا يمكن تشغيل المشروع دون تغيير لغة النظام إلى العربية" ' تعريف الدوال API بناءً على إصدار VBA #If VBA7 Then ' إصدار 64 بت Private Declare PtrSafe Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As LongPtr, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As LongPtr) As Long Private Declare PtrSafe Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As LongPtr, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare PtrSafe Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As LongPtr) As Long Private Declare PtrSafe Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare PtrSafe Function GetACP Lib "kernel32" () As Long Private Declare PtrSafe Function GetUserDefaultLCID Lib "kernel32" () As Long #Else ' إصدار 32 بت Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" ( _ ByVal hKey As Long, _ ByVal lpSubKey As String, _ ByVal ulOptions As Long, _ ByVal samDesired As Long, _ ByRef phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" ( _ ByVal hKey As Long, _ ByVal lpValueName As String, _ ByVal lpReserved As Long, _ ByRef lpType As Long, _ ByVal lpData As String, _ ByRef lpcbData As Long) As Long Private Declare Function RegCloseKey Lib "advapi32.dll" ( _ ByVal hKey As Long) As Long Private Declare Function GetUserDefaultUILanguage Lib "kernel32" () As Long Private Declare Function GetACP Lib "kernel32" () As Long Private Declare Function GetUserDefaultLCID Lib "kernel32" () As Long #End If ' ثوابت لاستخدامها مع Windows API Private Const HKEY_LOCAL_MACHINE As Long = &H80000002 Private Const KEY_QUERY_VALUE As Long = &H1 Private Const KEY_WOW64_64KEY As Long = &H100 Private Const KEY_WOW64_32KEY As Long = &H200 Private Const REG_SZ As Long = 1 ' تعريف نوع بيانات "country" لتخزين معلومات البلد Private Type country countryCode As String ' رمز البلد (مثال: "EG") countryName As String ' اسم البلد (مثال: "مصر") fullCountryName As String ' الاسم الكامل للبلد (مثال: "جمهورية مصر العربية") localeName As String ' اسم اللغة المحلية (مثال: "ar-EG") localeID As String ' معرف اللغة المحلية (مثال: "00000C01") code As String ' رمز الاتصال بالبلد (مثال: "20") nativeLanguage As String ' اللغة الأم مع البلد (مثال: "العربية (مصر)") End Type ' تعريف مصفوفة لتخزين إعدادات البلدان Private countries() As country ' تعريف متغير لتخزين إعدادات البلد الحالية Private countrySettings As country Private Sub LogError(ByVal errorMessage As String) ' تجاهل الأخطاء مؤقتًا لتجنب توقف البرنامج في حالة حدوث خطأ أثناء تسجيل الخطأ On Error Resume Next ' تعريف المتغيرات Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات Dim logFile As Object ' كائن TextStream لكتابة البيانات في الملف Dim desktopPath As String ' مسار سطح المكتب Dim logFilePath As String ' المسار الكامل لملف تسجيل الأخطاء ' الحصول على مسار سطح المكتب باستخدام WScript.Shell desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") ' تحديد المسار الكامل لملف تسجيل الأخطاء logFilePath = desktopPath & "\ChangeLanguageErrorLog.txt" ' إنشاء كائن FileSystemObject للتعامل مع الملفات Set fso = CreateObject("Scripting.FileSystemObject") ' فتح ملف تسجيل الأخطاء للكتابة (الرقم 8 يعني الإلحاق، True يعني إنشاء الملف إذا لم يكن موجودًا) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' كتابة رسالة الخطأ والطابع الزمني في الملف logFile.WriteLine "Error: " & errorMessage & vbCrLf & "Timestamp: " & Now ' إغلاق الملف بعد الانتهاء من الكتابة logFile.Close ' إعادة تفعيل معالجة الأخطاء العادية On Error GoTo 0 End Sub Private Sub SetCountryData(countryCode As String, countryName As String, fullCountryName As String, localeName As String, localeID As String, code As String, nativeLanguage As String) ' تعريف متغير من النوع "country" لتخزين بيانات البلد الحالي Dim currentCountry As country ' تعيين قيم البيانات إلى المتغير currentCountry currentCountry.countryCode = countryCode ' رمز البلد currentCountry.countryName = countryName ' اسم البلد currentCountry.fullCountryName = fullCountryName ' الاسم الكامل للبلد currentCountry.localeName = localeName ' اسم اللغة المحلية currentCountry.localeID = localeID ' معرف اللغة المحلية currentCountry.code = code ' رمز الاتصال بالبلد currentCountry.nativeLanguage = nativeLanguage ' اللغة الأم مع البلد ' زيادة حجم المصفوفة "countries" مع الاحتفاظ بالبيانات الموجودة (ReDim Preserve) ReDim Preserve countries(UBound(countries) + 1) ' إضافة بيانات البلد الحالي إلى المصفوفة countries(UBound(countries)) = currentCountry End Sub ' دالة للتحقق من لغة النظام الحالية Private Function IsSystemLanguage(ByVal targetLocaleName As String, ByVal targetLocaleID As String) As Boolean ' تعريف المتغيرات Dim wshShell As Object ' كائن WScript.Shell للوصول إلى سجل النظام Dim currentLocaleName As String ' لتخزين LocaleName الحالي للنظام Dim currentLocaleID As String ' لتخزين LocaleID الحالي للنظام ' إنشاء كائن WScript.Shell Set wshShell = CreateObject("WScript.Shell") ' تجاهل الأخطاء مؤقتًا لتجنب توقف البرنامج في حالة عدم وجود مفاتيح السجل On Error Resume Next ' قراءة قيمة LocaleName من سجل النظام currentLocaleName = wshShell.RegRead("HKEY_CURRENT_USER\Control Panel\International\LocaleName") ' قراءة قيمة LocaleID من سجل النظام currentLocaleID = wshShell.RegRead("HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Nls\Language\Default") ' إعادة تفعيل معالجة الأخطاء العادية On Error GoTo 0 ' مقارنة LocaleName و LocaleID الحاليين مع القيم المستهدفة If currentLocaleName = targetLocaleName And currentLocaleID = targetLocaleID Then ' إذا كانت القيم متطابقة، يتم إرجاع True IsSystemLanguage = True Else ' إذا كانت القيم غير متطابقة، يتم إرجاع False IsSystemLanguage = False End If End Function Private Sub CheckSystemLanguage() ' تعريف المتغيرات Dim targetLocaleName As String ' لتخزين LocaleName المستهدف Dim targetLocaleID As String ' لتخزين LocaleID المستهدف Dim isLanguageMatch As Boolean ' لتخزين نتيجة التحقق من تطابق اللغة ' تحديد القيم المستهدفة targetLocaleName = "en-US" ' اللغة المستهدفة: الإنجليزية - الولايات المتحدة targetLocaleID = "0409" ' معرف اللغة المستهدف: الإنجليزية - الولايات المتحدة ' استدعاء الدالة IsSystemLanguage للتحقق من تطابق اللغة isLanguageMatch = IsSystemLanguage(targetLocaleName, targetLocaleID) ' عرض النتيجة بناءً على ما تعيده الدالة If isLanguageMatch Then ' إذا كانت اللغة مطابقة، يتم عرض رسالة تأكيد MsgBox "لغة النظام مطابقة للغة المستهدفة: " & targetLocaleName, vbInformation, "التحقق من اللغة" Else ' إذا كانت اللغة غير مطابقة، يتم عرض رسالة تحذير مع تفاصيل MsgBox "لغة النظام غير مطابقة للغة المستهدفة: " & targetLocaleName & vbNewLine & _ "اللغة الحالية: " & targetLocaleName & vbNewLine & _ "معرف اللغة الحالي: " & targetLocaleID, vbExclamation, "التحقق من اللغة" End If End Sub Private Sub ChangeSystemLanguage(Optional restartDelay As Integer = 15) ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' تعريف المتغيرات Dim fso As Object ' كائن FileSystemObject للتعامل مع الملفات Dim batFile As Object ' كائن TextStream لكتابة ملف الباتش Dim logFile As Object ' كائن TextStream لكتابة ملف السجل Dim desktopPath As String ' مسار سطح المكتب Dim batFilePath As String ' المسار الكامل لملف الباتش Dim logFilePath As String ' المسار الكامل لملف السجل Dim newLanguage As String ' اللغة الجديدة (غير مستخدمة في الكود الحالي) Dim countryCode As String ' رمز البلد Dim localeID As String ' معرف اللغة المحلية Dim localeName As String ' اسم اللغة المحلية Dim countryName As String ' اسم البلد ' الحصول على تفاصيل البلد المحدد countryCode = countrySettings.countryCode localeID = countrySettings.localeID localeName = countrySettings.localeName countryName = countrySettings.countryName ' الحصول على مسار سطح المكتب desktopPath = CreateObject("WScript.Shell").SpecialFolders("Desktop") batFilePath = desktopPath & "\ChangeLanguage.bat" logFilePath = desktopPath & "\ChangeLanguageLog.txt" ' إنشاء كائن FileSystemObject Set fso = CreateObject("Scripting.FileSystemObject") ' إنشاء ملف الباتش Set batFile = fso.CreateTextFile(batFilePath, True) ' فتح ملف السجل للإلحاق (Append) Set logFile = fso.OpenTextFile(logFilePath, 8, True) ' كتابة الأوامر في ملف الباتش With batFile .WriteLine "@echo off" ' إيقاف عرض الأوامر في نافذة الأوامر .WriteLine "chcp 1256" ' تغيير صفحة الترميز إلى 1256 (للدعم العربي) .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v Default /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKLM\SYSTEM\CurrentControlSet\Control\Nls\Language"" /v InstallLanguage /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v LocaleName /t REG_SZ /d " & localeName & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v Locale /t REG_SZ /d " & localeID & " /f" .WriteLine "reg add ""HKCU\Control Panel\International"" /v sCountry /t REG_SZ /d " & countryName & " /f" .WriteLine "shutdown /r /f /t " & restartDelay ' إعادة تشغيل الكمبيوتر بعد تأخير محدد .Close ' إغلاق ملف الباتش End With ' تنفيذ ملف الباتش لتغيير اللغة وإعادة التشغيل Shell batFilePath, vbNormalFocus ' إعلام المستخدم بتغيير اللغة وإعادة التشغيل MsgBox "جاري تغيير اللغة. سيتم إعادة تشغيل الكمبيوتر خلال " & restartDelay & " ثانية.", vbInformation, "تغيير اللغة" ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' تسجيل الخطأ في ملف السجل LogError "حدث خطأ في ChangeSystemLanguage: " & Err.Description ' إظهار رسالة خطأ للمستخدم MsgBox "حدث خطأ أثناء محاولة تغيير لغة النظام.", vbCritical End Sub Private Function IsArabicLanguage() As Boolean ' تعريف المتغير لتخزين صفحة الترميز الحالية للنظام Dim CodePage As Long ' الحصول على صفحة الترميز الحالية باستخدام الدالة GetACP CodePage = GetACP() ' التحقق مما إذا كانت صفحة الترميز هي 1256 (العربية) IsArabicLanguage = (CodePage = 1256) End Function Private Function GetArabicCountrySettings(ByVal countryCode As String) As country ' البحث عن البلد في المصفوفة بناءً على رمز البلد Dim i As Integer For i = 0 To UBound(countries) If UCase(countries(i).countryName) = UCase(countryCode) Then ' إذا تم العثور على البلد، يتم إرجاع تفاصيله GetArabicCountrySettings = countries(i) Exit Function End If Next i ' إذا لم يتم العثور على البلد، يتم إرجاع السعودية كإعداد افتراضي GetArabicCountrySettings = countries(4) ' السعودية End Function Sub LoadCountries() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' تهيئة الحجم الأولي للمصفوفة countries ReDim countries(0) ' إضافة بيانات البلدان إلى المصفوفة باستخدام الدالة SetCountryData ' البلدان العربية SetCountryData "AE", "UAE", "الإمارات العربية المتحدة", "ar-AE", "00003801", "971", "العربية (الإمارات)" SetCountryData "BH", "Bahrain", "البحرين", "ar-BH", "00003C01", "973", "العربية (البحرين)" SetCountryData "DZ", "Algeria", "الجزائر", "ar-DZ", "00001401", "213", "العربية (الجزائر)" SetCountryData "EG", "Egypt", "مصر", "ar-EG", "00000C01", "20", "العربية (مصر)" SetCountryData "IQ", "Iraq", "العراق", "ar-IQ", "00000801", "964", "العربية (العراق)" SetCountryData "JO", "Jordan", "الأردن", "ar-JO", "00000409", "962", "العربية (الأردن)" SetCountryData "KW", "Kuwait", "الكويت", "ar-KW", "00003401", "965", "العربية (الكويت)" SetCountryData "LB", "Lebanon", "لبنان", "ar-LB", "00003001", "961", "العربية (لبنان)" SetCountryData "LY", "Libya", "ليبيا", "ar-LY", "00001001", "218", "العربية (ليبيا)" SetCountryData "MA", "Morocco", "المغرب", "ar-MA", "00001801", "212", "العربية (المغرب)" SetCountryData "MR", "Mauritania", "موريتانيا", "ar-MR", "00001801", "222", "العربية (موريتانيا)" SetCountryData "OM", "Oman", "عُمان", "ar-OM", "00002001", "968", "العربية (عُمان)" SetCountryData "PS", "Palestine", "فلسطين", "ar-PS", "00000401", "970", "العربية (فلسطين)" SetCountryData "QA", "Qatar", "قطر", "ar-QA", "00004001", "974", "العربية (قطر)" SetCountryData "SA", "Saudi Arabia", "المملكة العربية السعودية", "ar-SA", "00000401", "966", "العربية (السعودية)" SetCountryData "SD", "Sudan", "السودان", "ar-SD", "00002C01", "249", "العربية (السودان)" SetCountryData "SO", "Somalia", "الصومال", "ar-SO", "00000401", "252", "العربية (الصومال)" SetCountryData "SY", "Syria", "سوريا", "ar-SY", "00002801", "963", "العربية (سوريا)" SetCountryData "TN", "Tunisia", "تونس", "ar-TN", "00001C01", "216", "العربية (تونس)" SetCountryData "YE", "Yemen", "اليمن", "ar-YE", "00002401", "967", "العربية (اليمن)" ' البلدان الصينية SetCountryData "CN", "China", "الصين", "zh-CN", "00000804", "86", "الصينية (الصين)" SetCountryData "TW", "Taiwan", "تايوان", "zh-TW", "00000404", "886", "الصينية (تايوان)" SetCountryData "HK", "Hong Kong", "هونغ كونغ", "zh-HK", "00000C04", "852", "الصينية (هونغ كونغ)" SetCountryData "SG", "Singapore", "سنغافورة", "zh-SG", "00001004", "65", "الصينية (سنغافورة)" ' البلدان الإنجليزية SetCountryData "AU", "Australia", "أستراليا", "en-AU", "00000C09", "61", "الإنجليزية (أستراليا)" SetCountryData "CA", "Canada", "كندا", "en-CA", "00001009", "1", "الإنجليزية (كندا)" SetCountryData "GB", "UK", "المملكة المتحدة", "en-GB", "00000809", "44", "الإنجليزية (المملكة المتحدة)" SetCountryData "IE", "Ireland", "أيرلندا", "en-IE", "00001809", "353", "الإنجليزية (أيرلندا)" SetCountryData "IN", "India", "الهند", "en-IN", "00000409", "91", "الإنجليزية (الهند)" SetCountryData "NG", "Nigeria", "نيجيريا", "en-NG", "00000409", "234", "الإنجليزية (نيجيريا)" SetCountryData "NZ", "New Zealand", "نيوزيلندا", "en-NZ", "00001409", "64", "الإنجليزية (نيوزيلندا)" SetCountryData "PH", "Philippines", "الفلبين", "en-PH", "00000409", "63", "الإنجليزية (الفلبين)" SetCountryData "US", "USA", "الولايات المتحدة الأمريكية", "en-US", "00000409", "1", "الإنجليزية (الولايات المتحدة)" SetCountryData "ZA", "South Africa", "جنوب أفريقيا", "en-ZA", "00000409", "27", "الإنجليزية (جنوب أفريقيا)" ' البلدان الفرنسية SetCountryData "BE", "Belgium", "بلجيكا", "fr-BE", "0000080C", "32", "الفرنسية (بلجيكا)" SetCountryData "CA", "Canada", "كندا", "fr-CA", "00000C0C", "1", "الفرنسية (كندا)" SetCountryData "CH", "Switzerland", "سويسرا", "fr-CH", "0000100C", "41", "الفرنسية (سويسرا)" SetCountryData "FR", "France", "فرنسا", "fr-FR", "0000040C", "33", "الفرنسية (فرنسا)" SetCountryData "LU", "Luxembourg", "لوكسمبورغ", "fr-LU", "0000140C", "352", "الفرنسية (لوكسمبورغ)" SetCountryData "SN", "Senegal", "السنغال", "fr-SN", "0000040C", "221", "الفرنسية (السنغال)" ' البلدان الألمانية SetCountryData "AT", "Austria", "النمسا", "de-AT", "00000407", "43", "الألمانية (النمسا)" SetCountryData "CH", "Switzerland", "سويسرا", "de-CH", "00000807", "41", "الألمانية (سويسرا)" SetCountryData "DE", "Germany", "ألمانيا", "de-DE", "00000407", "49", "الألمانية (ألمانيا)" SetCountryData "LI", "Liechtenstein", "ليختنشتاين", "de-LI", "00001007", "423", "الألمانية (ليختنشتاين)" ' البلدان الهندية SetCountryData "IN", "India", "الهند", "hi-IN", "00000439", "91", "الهندية (الهند)" ' البلدان الإندونيسية SetCountryData "ID", "Indonesia", "إندونيسيا", "id-ID", "00000421", "62", "الإندونيسية (إندونيسيا)" ' البلدان الإيطالية SetCountryData "IT", "Italy", "إيطاليا", "it-IT", "00000410", "39", "الإيطالية (إيطاليا)" SetCountryData "SM", "San Marino", "سان مارينو", "it-SM", "00000410", "378", "الإيطالية (سان مارينو)" SetCountryData "VA", "Vatican City", "الفاتيكان", "it-VA", "00000410", "379", "الإيطالية (الفاتيكان)" ' البلدان اليابانية SetCountryData "JP", "Japan", "اليابان", "ja-JP", "00000411", "81", "اليابانية (اليابان)" ' البلدان الكورية SetCountryData "KR", "South Korea", "كوريا الجنوبية", "ko-KR", "00000412", "82", "الكورية (كوريا الجنوبية)" SetCountryData "KP", "North Korea", "كوريا الشمالية", "ko-KP", "00000412", "850", "الكورية (كوريا الشمالية)" ' البلدان البرتغالية SetCountryData "BR", "Brazil", "البرازيل", "pt-BR", "00000416", "55", "البرتغالية (البرازيل)" SetCountryData "PT", "Portugal", "البرتغال", "pt-PT", "00000816", "351", "البرتغالية (البرتغال)" SetCountryData "AO", "Angola", "أنغولا", "pt-AO", "00000416", "244", "البرتغالية (أنغولا)" SetCountryData "MZ", "Mozambique", "موزمبيق", "pt-MZ", "00000416", "258", "البرتغالية (موزمبيق)" ' البلدان الروسية SetCountryData "RU", "Russia", "روسيا", "ru-RU", "00000419", "7", "الروسية (روسيا)" SetCountryData "BY", "Belarus", "بيلاروسيا", "ru-BY", "00000419", "375", "الروسية (بيلاروسيا)" SetCountryData "KZ", "Kazakhstan", "كازاخستان", "ru-KZ", "00000419", "7", "الروسية (كازاخستان)" SetCountryData "KG", "Kyrgyzstan", "قيرغيزستان", "ru-KG", "00000419", "996", "الروسية (قيرغيزستان)" ' البلدان الإسبانية SetCountryData "AR", "Argentina", "الأرجنتين", "es-AR", "00002C0A", "54", "الإسبانية (الأرجنتين)" SetCountryData "BO", "Bolivia", "بوليفيا", "es-BO", "00002C0A", "591", "الإسبانية (بوليفيا)" SetCountryData "CL", "Chile", "تشيلي", "es-CL", "00002C0A", "56", "الإسبانية (تشيلي)" SetCountryData "CO", "Colombia", "كولومبيا", "es-CO", "00002C0A", "57", "الإسبانية (كولومبيا)" SetCountryData "CR", "Costa Rica", "كوستاريكا", "es-CR", "00002C0A", "506", "الإسبانية (كوستاريكا)" SetCountryData "CU", "Cuba", "كوبا", "es-CU", "00002C0A", "53", "الإسبانية (كوبا)" SetCountryData "DO", "Dominican Republic", "جمهورية الدومينيكان", "es-DO", "00002C0A", "1", "الإسبانية (جمهورية الدومينيكان)" SetCountryData "EC", "Ecuador", "الإكوادور", "es-EC", "00002C0A", "593", "الإسبانية (الإكوادور)" SetCountryData "ES", "Spain", "إسبانيا", "es-ES", "0000040A", "34", "الإسبانية (إسبانيا)" SetCountryData "GT", "Guatemala", "غواتيمالا", "es-GT", "00002C0A", "502", "الإسبانية (غواتيمالا)" SetCountryData "HN", "Honduras", "هندوراس", "es-HN", "00002C0A", "504", "الإسبانية (هندوراس)" SetCountryData "MX", "Mexico", "المكسيك", "es-MX", "0000080A", "52", "الإسبانية (المكسيك)" SetCountryData "NI", "Nicaragua", "نيكاراغوا", "es-NI", "00002C0A", "505", "الإسبانية (نيكاراغوا)" SetCountryData "PA", "Panama", "بنما", "es-PA", "00002C0A", "507", "الإسبانية (بنما)" SetCountryData "PE", "Peru", "بيرو", "es-PE", "00002C0A", "51", "الإسبانية (بيرو)" SetCountryData "PR", "Puerto Rico", "بورتوريكو", "es-PR", "00002C0A", "1", "الإسبانية (بورتوريكو)" SetCountryData "PY", "Paraguay", "باراغواي", "es-PY", "00002C0A", "595", "الإسبانية (باراغواي)" SetCountryData "SV", "El Salvador", "السلفادور", "es-SV", "00002C0A", "503", "الإسبانية (السلفادور)" SetCountryData "UY", "Uruguay", "أوروغواي", "es-UY", "00002C0A", "598", "الإسبانية (أوروغواي)" SetCountryData "VE", "Venezuela", "فنزويلا", "es-VE", "00002C0A", "58", "الإسبانية (فنزويلا)" ' البلدان التركية SetCountryData "TR", "Turkey", "تركيا", "tr-TR", "0000041F", "90", "التركية (تركيا)" SetCountryData "CY", "Cyprus", "قبرص", "tr-CY", "0000041F", "357", "التركية (قبرص)" ' التحقق من وجود عنصر cmbLanguage في النموذج If Not Me.cmbLanguage Is Nothing Then ' مسح العناصر القديمة من مربع السرد Me.cmbLanguage = "" ' ملء مربع السرد بأسماء البلدان الكاملة من المصفوفة Dim i As Integer For i = 1 To UBound(countries) Me.cmbLanguage.AddItem countries(i).nativeLanguage Next i Else ' إظهار رسالة خطأ إذا لم يتم العثور على مربع السرد MsgBox "لا يمكن العثور على مربع السرد 'cmbLanguage'.", vbCritical End If ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' تسجيل الخطأ في ملف السجل باستخدام الدالة LogError LogError "حدث خطأ في LoadCountries: " & Err.Description ' إظهار رسالة خطأ للمستخدم MsgBox "حدث خطأ أثناء تحميل البلدان", vbCritical End Sub Private Sub Form_Load() ' تحميل أسماء البلدان إلى مربع السرد LoadCountries ' تعيين اللغة الافتراضية (مصر) في مربع السرد cmbLanguage.Value = "العربية (مصر)" ' تعيين تفاصيل البلد الافتراضي (مصر) countrySettings = GetArabicCountrySettings("EG") ' عرض اسم البلد في مربع النص txtConteryName.Value = GetNonUnicodeLanguage() End Sub Private Sub cmbLanguage_Change() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' الحصول على اسم البلد المختار من مربع السرد Dim selectedCountryName As String selectedCountryName = Me.cmbLanguage.Value ' البحث عن البلد المختار في المصفوفة Dim i As Integer For i = 1 To UBound(countries) If countries(i).nativeLanguage = selectedCountryName Then ' إذا تم العثور على البلد، يتم حفظ تفاصيله countrySettings = countries(i) Exit For End If Next i ' إظهار رسالة بناءً على نتيجة البحث If i <= UBound(countries) Then MsgBox "تم تحديد اللغة: " & selectedCountryName, vbInformation, "لغة مختارة" Else MsgBox "لم يتم العثور على اللغة في القائمة.", vbExclamation, "خطأ" End If ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' إظهار رسالة خطأ في حالة حدوث مشكلة MsgBox "حدث خطأ أثناء تحديد اللغة.", vbCritical, "خطأ" End Sub Private Sub btnLanguage_Click() ' معالجة الأخطاء: في حالة حدوث خطأ، يتم الانتقال إلى ErrorHandler On Error GoTo ErrorHandler ' التحقق مما إذا تم اختيار لغة من القائمة If countrySettings.countryCode = "" Then MsgBox "يرجى اختيار لغة من القائمة.", vbExclamation, "اختيار اللغة" Exit Sub End If ' تنفيذ تغيير اللغة مع تأخير 15 ثانية قبل إعادة التشغيل Call ChangeSystemLanguage(15) ' إعلام المستخدم بأن تغيير اللغة سيتم وإعادة التشغيل قريبًا MsgBox "تم تحديد اللغة بنجاح، سيتم إعادة تشغيل النظام في غضون 15 ثانية.", vbInformation, "تغيير اللغة" ' الخروج من الإجراء دون تنفيذ كود معالج الأخطاء Exit Sub ErrorHandler: ' إظهار رسالة خطأ في حالة حدوث مشكلة MsgBox "حدث خطأ أثناء محاولة تغيير اللغة.", vbCritical, "خطأ" End Sub Private Function GetRegistryValue(ByVal keyPath As String, ByVal valueName As String) As String #If VBA7 Then ' إصدار 64 بت Dim hKey As LongPtr #Else ' إصدار 32 بت Dim hKey As Long #End If Dim ret As Long Dim valueType As Long Dim valueData As String Dim dataLength As Long ' فتح المفتاح ret = RegOpenKeyEx(HKEY_LOCAL_MACHINE, keyPath, 0, KEY_QUERY_VALUE Or KEY_WOW64_64KEY, hKey) If ret = 0 Then ' تحديد حجم البيانات ret = RegQueryValueEx(hKey, valueName, 0, valueType, vbNullString, dataLength) If ret = 0 And valueType = REG_SZ Then ' قراءة البيانات valueData = String(dataLength, Chr(0)) ret = RegQueryValueEx(hKey, valueName, 0, valueType, valueData, dataLength) If ret = 0 Then ' إزالة الأحرف الفارغة من النهاية GetRegistryValue = Left(valueData, dataLength - 1) End If End If ' إغلاق المفتاح RegCloseKey (hKey) End If End Function Private Function GetNonUnicodeLanguage() As String Dim localeID As String ' قراءة قيمة السجل localeID = GetRegistryValue("SYSTEM\CurrentControlSet\Control\Nls\Language", "Default") ' تحويل القيمة إلى Long Dim localeIDLong As Long localeIDLong = Val("&H" & localeID) ' استخدام Locale ID لتحديد اللغة Select Case localeIDLong ' البلدان العربية Case &H401: GetNonUnicodeLanguage = "العربية (السعودية)" Case &H801: GetNonUnicodeLanguage = "العربية (العراق)" Case &HC01: GetNonUnicodeLanguage = "العربية (مصر)" Case &H1001: GetNonUnicodeLanguage = "العربية (ليبيا)" Case &H1401: GetNonUnicodeLanguage = "العربية (الجزائر)" Case &H1801: GetNonUnicodeLanguage = "العربية (المغرب)" Case &H1C01: GetNonUnicodeLanguage = "العربية (تونس)" Case &H2001: GetNonUnicodeLanguage = "العربية (عُمان)" Case &H2401: GetNonUnicodeLanguage = "العربية (اليمن)" Case &H2801: GetNonUnicodeLanguage = "العربية (سوريا)" Case &H2C01: GetNonUnicodeLanguage = "العربية (الأردن)" Case &H3001: GetNonUnicodeLanguage = "العربية (لبنان)" Case &H3401: GetNonUnicodeLanguage = "العربية (الكويت)" Case &H3801: GetNonUnicodeLanguage = "العربية (الإمارات)" Case &H3C01: GetNonUnicodeLanguage = "العربية (البحرين)" Case &H4001: GetNonUnicodeLanguage = "العربية (قطر)" ' البلدان الإنجليزية Case &H409: GetNonUnicodeLanguage = "الإنجليزية (الولايات المتحدة)" Case &H809: GetNonUnicodeLanguage = "الإنجليزية (المملكة المتحدة)" Case &HC09: GetNonUnicodeLanguage = "الإنجليزية (أستراليا)" Case &H1009: GetNonUnicodeLanguage = "الإنجليزية (كندا)" Case &H1409: GetNonUnicodeLanguage = "الإنجليزية (نيوزيلندا)" Case &H1809: GetNonUnicodeLanguage = "الإنجليزية (أيرلندا)" Case &H1C09: GetNonUnicodeLanguage = "الإنجليزية (جنوب أفريقيا)" Case &H2009: GetNonUnicodeLanguage = "الإنجليزية (جامايكا)" Case &H2409: GetNonUnicodeLanguage = "الإنجليزية (الكاريبي)" Case &H2809: GetNonUnicodeLanguage = "الإنجليزية (بليز)" Case &H2C09: GetNonUnicodeLanguage = "الإنجليزية (ترينيداد)" Case &H3009: GetNonUnicodeLanguage = "الإنجليزية (زيمبابوي)" Case &H3409: GetNonUnicodeLanguage = "الإنجليزية (الفلبين)" Case &H3809: GetNonUnicodeLanguage = "الإنجليزية (الهند)" ' البلدان الفرنسية Case &H40C: GetNonUnicodeLanguage = "الفرنسية (فرنسا)" Case &H80C: GetNonUnicodeLanguage = "الفرنسية (بلجيكا)" Case &HC0C: GetNonUnicodeLanguage = "الفرنسية (كندا)" Case &H100C: GetNonUnicodeLanguage = "الفرنسية (سويسرا)" Case &H140C: GetNonUnicodeLanguage = "الفرنسية (لوكسمبورغ)" Case &H180C: GetNonUnicodeLanguage = "الفرنسية (موناكو)" Case &H1C0C: GetNonUnicodeLanguage = "الفرنسية (السنغال)" ' البلدان الألمانية Case &H407: GetNonUnicodeLanguage = "الألمانية (ألمانيا)" Case &H807: GetNonUnicodeLanguage = "الألمانية (سويسرا)" Case &HC07: GetNonUnicodeLanguage = "الألمانية (النمسا)" Case &H1007: GetNonUnicodeLanguage = "الألمانية (ليختنشتاين)" ' البلدان الهندية Case &H439: GetNonUnicodeLanguage = "الهندية (الهند)" ' البلدان الإندونيسية Case &H421: GetNonUnicodeLanguage = "الإندونيسية (إندونيسيا)" ' البلدان الإيطالية Case &H410: GetNonUnicodeLanguage = "الإيطالية (إيطاليا)" Case &H810: GetNonUnicodeLanguage = "الإيطالية (سويسرا)" Case &HC10: GetNonUnicodeLanguage = "الإيطالية (سان مارينو)" Case &H1010: GetNonUnicodeLanguage = "الإيطالية (الفاتيكان)" ' البلدان اليابانية Case &H411: GetNonUnicodeLanguage = "اليابانية (اليابان)" ' البلدان الكورية Case &H412: GetNonUnicodeLanguage = "الكورية (كوريا الجنوبية)" Case &H812: GetNonUnicodeLanguage = "الكورية (كوريا الشمالية)" ' البلدان البرتغالية Case &H416: GetNonUnicodeLanguage = "البرتغالية (البرازيل)" Case &H816: GetNonUnicodeLanguage = "البرتغالية (البرتغال)" Case &HC16: GetNonUnicodeLanguage = "البرتغالية (أنغولا)" Case &H1016: GetNonUnicodeLanguage = "البرتغالية (موزمبيق)" ' البلدان الروسية Case &H419: GetNonUnicodeLanguage = "الروسية (روسيا)" Case &H819: GetNonUnicodeLanguage = "الروسية (بيلاروسيا)" Case &HC19: GetNonUnicodeLanguage = "الروسية (كازاخستان)" Case &H1019: GetNonUnicodeLanguage = "الروسية (قيرغيزستان)" ' البلدان الإسبانية Case &H40A: GetNonUnicodeLanguage = "الإسبانية (إسبانيا)" Case &H80A: GetNonUnicodeLanguage = "الإسبانية (المكسيك)" Case &HC0A: GetNonUnicodeLanguage = "الإسبانية (الأرجنتين)" Case &H100A: GetNonUnicodeLanguage = "الإسبانية (كولومبيا)" Case &H140A: GetNonUnicodeLanguage = "الإسبانية (بيرو)" Case &H180A: GetNonUnicodeLanguage = "الإسبانية (فنزويلا)" Case &H1C0A: GetNonUnicodeLanguage = "الإسبانية (تشيلي)" Case &H200A: GetNonUnicodeLanguage = "الإسبانية (الإكوادور)" Case &H240A: GetNonUnicodeLanguage = "الإسبانية (غواتيمالا)" Case &H280A: GetNonUnicodeLanguage = "الإسبانية (كوبا)" Case &H2C0A: GetNonUnicodeLanguage = "الإسبانية (بوليفيا)" Case &H300A: GetNonUnicodeLanguage = "الإسبانية (جمهورية الدومينيكان)" Case &H340A: GetNonUnicodeLanguage = "الإسبانية (بورتوريكو)" Case &H380A: GetNonUnicodeLanguage = "الإسبانية (أوروغواي)" Case &H3C0A: GetNonUnicodeLanguage = "الإسبانية (باراغواي)" Case &H400A: GetNonUnicodeLanguage = "الإسبانية (كوستاريكا)" Case &H440A: GetNonUnicodeLanguage = "الإسبانية (السلفادور)" Case &H480A: GetNonUnicodeLanguage = "الإسبانية (هندوراس)" Case &H4C0A: GetNonUnicodeLanguage = "الإسبانية (نيكاراغوا)" Case &H500A: GetNonUnicodeLanguage = "الإسبانية (بنما)" ' البلدان التركية Case &H41F: GetNonUnicodeLanguage = "التركية (تركيا)" Case &H81F: GetNonUnicodeLanguage = "التركية (قبرص)" ' الحالة الافتراضية Case Else: GetNonUnicodeLanguage = "غير معروف (Locale ID: " & localeID & ")" End Select End Function بس خلاص واترككم فى حفظ الله ورعايته واتمنى لكم تجربة ممتعه شيقة مع المرفق الذى يحتوى على نموذجين طبعا لم اهتم كثيرا بالتفاصيل والرسائل بقدر اهتمامى باليه العمل الاول بالعربى لمن يريد , والثانى بالانجليزية لمن يريد فى انتظار أرائكم يا سادة ChangeLanguage V 1.0.zip