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

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

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

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

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

وعليكم السلام ورحمة الله وبركاته ,,, بعد عدة محاولات من خلال المعادلات ، وجدت أنه من الصعب عدم تحديث الخلايا الغير معنية بالإدراج ، لذا توجهت الى استخدام الماكرو التالي :- 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

بسيطة أخي الكريم ، الآن حسب ملفك المرفق ، جرب هذا التعديل :- 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

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا 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

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

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

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

السبب هو أنه يوجد خلايا مدمجة ، فكيف سيتم تمييز في اي خلية سيتم ادراج التاريخ و الوقت !!!!! قمت بتعديل مواضع الـ 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

الأستاذ الفاضل Foksh ماشاء الله تبارك الله عليك بالفعل هذا هو المطلوب كل الشكر والتقدير لك جزاك الله خير

نعم صحيح ، هي كفكرة حلوة وتتيح لك التوسع في طريقة وتنسيق عرض الساعة ، حتى أني استخدمتها في برنامج نظام الطابور لعرض الساعة باللغتين ( عربي و انجليزي ) من خلال النقر على الساعة نفسها 😅

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

عمل رائع وجميل وحدات نمطية وأكواد متعوب عليها في اعمالي اقتصر غالبا قدر استطاعتي على الادوات التي يملكها اكسس .. فالساعة مثلا لا اخرج عن هذا السطر: Private Sub Form_Timer() Me.Label2.Caption = Format(Now, "hh:nn:ss AM/PM") End Sub ولكني وظفت العداد في عملية مهمة لضبط الإدخال في عملية الحضور وقد جعلت الفورم يملأ الشاشة .. فكانت فكرة اظهار الساعة مستحسن ومناسب الفكرة التي راودتني حين طرحت الموضوع هي .. هل يمكنني جلب ساعة وندز الى الفورم بسطر واحد ؟ مثل سطر جلب مستخدم وندوز : CreateObject("WScript.Network").UserName او رقم المعالج : Environ("NUMBER_OF_PROCESSORS") واشياء اخرى يمكن جلبها او تشغيلها ومناداتها بسطر

السلام عليكم ورحمة الله وبركاته هذا ملف للملاحظة اشتغلت عليه به اكواد من ملفات بعض الزملاء بهذا الموقع وغيره ( لم اقم بنسبتها لنفسى ) ايضا الكود الخاص بتوزيع الملاحظة ( تم توليده بالذكاء الاصطناعى ) قمت بتجربته يعمل بشكل جيد قمت بتنسيق الملف وضبطه واضافة بعد الخصائص البسيطة والجمالية له الملف يتسع لـ ( 50 ) لجنة موزعة على كشفان عدد ايام امتحان ( 30 يوم ) به ايضا كشاف اللجان لكنه لا يوجد به حفظ الملف PDF ايضا كتابة التاريخ واليوم واسم المادة والزمن يدوى بعد الطباعة ( او قبل الطباعة ) اتمنى ان يقدم لك ما تريد الملف توزيع الملاحظين على اللجان2025_جديد.rar

استاذى الجليل و معلمى القدير و والدى الحبيب دوال api لا يتم الاعلان عنها داخل النماذج او بشكل ادق وأصح : AddressOf لابد ان يكون داخل وحده نمطيه عامة

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

وعليكم السلام ورحمة الله و بركاته Sub PrintOrExportPDF_CustomRanges() Dim ws As Worksheet Dim rngAddress As String Dim sheetNames As Variant Dim printableSheetNames() As String Dim i As Integer, count As Integer Dim printChoice As VbMsgBoxResult Dim savePath As String Dim fileName As String ' أسماء الأوراق (عدّل حسب أوراقك) sheetNames = Array("Sheet1", "Sheet2", "Sheet3", "Sheet4") count = 0 ' سؤال المستخدم: طباعة أم PDF؟ printChoice = MsgBox("هل ترغب في طباعة الأوراق؟" & vbCrLf & "اضغط 'نعم' للطباعة، 'لا' لحفظ كـ PDF.", vbYesNoCancel + vbQuestion, "اختيار نوع الإخراج") If printChoice = vbCancel Then MsgBox "تم إلغاء العملية.", vbExclamation Exit Sub End If Application.ScreenUpdating = False ' تحديد النطاقات For i = LBound(sheetNames) To UBound(sheetNames) Set ws = ThisWorkbook.Sheets(sheetNames(i)) rngAddress = InputBox("أدخل النطاق المطلوب طباعته من الورقة: " & sheetNames(i), "تحديد نطاق الطباعة") If rngAddress <> "" Then On Error Resume Next ws.PageSetup.PrintArea = rngAddress If Err.Number = 0 Then count = count + 1 ReDim Preserve printableSheetNames(1 To count) printableSheetNames(count) = ws.Name End If On Error GoTo 0 Else MsgBox "تم تخطي الورقة: " & sheetNames(i), vbInformation End If Next i ' تنفيذ العملية حسب الاختيار If count > 0 Then If printChoice = vbYes Then ' ? طباعة مباشرة Sheets(printableSheetNames).PrintOut MsgBox "تمت طباعة الأوراق المحددة بنجاح.", vbInformation ElseIf printChoice = vbNo Then ' ? تصدير كـ PDF (بمصنف مؤقت) With Application.FileDialog(msoFileDialogFolderPicker) .Title = "اختر المجلد لحفظ ملف PDF" If .Show <> -1 Then MsgBox "لم يتم اختيار مجلد.", vbExclamation Exit Sub End If savePath = .SelectedItems(1) End With fileName = InputBox("أدخل اسم ملف PDF بدون .pdf", "اسم الملف") If fileName = "" Then MsgBox "لم يتم إدخال اسم الملف.", vbExclamation Exit Sub End If ' إنشاء مصنف مؤقت Dim tempBook As Workbook Set tempBook = Workbooks.Add ' نسخ الأوراق للمصنف المؤقت For i = 1 To count ThisWorkbook.Sheets(printableSheetNames(i)).Copy After:=tempBook.Sheets(tempBook.Sheets.count) Next i ' حذف الورقة الافتراضية الفارغة Application.DisplayAlerts = False Do While tempBook.Sheets.count > count tempBook.Sheets(1).Delete Loop Application.DisplayAlerts = True ' حفظ كـ PDF tempBook.ExportAsFixedFormat _ Type:=xlTypePDF, _ fileName:=savePath & "\" & fileName & ".pdf", _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=True ' إغلاق المصنف المؤقت بدون حفظ tempBook.Close SaveChanges:=False MsgBox "تم حفظ ملف PDF بنجاح.", vbInformation End If Else MsgBox "لم يتم تحديد أي ورقة للطباعة أو التصدير.", vbExclamation End If Application.ScreenUpdating = True End Sub

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

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

وعليكم السلام ورحمة الله تعالى وبركاته الخلية C2 عدد المعدات : =COUNTIFS(بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2) الخلية D2 عدد الساعات : =SUMIFS(بينات!$AN$3:$AN$500, بينات!$D$3:$D$500, $A$2, بينات!$AS$3:$AS$500, $B$2) التنسيق الشرطي إذا كانت الساعات أقل من 500 حدد الخلية D2 ثم ===== > Conditional Formatting ==> New Rule ==> Use a formula to determine which cells to format واكتب الصيغة التالية: =D2<500 المعدات v2.xlsx

مداخلة فيما يتعلق بإعدادات اللغة الإقليمية في الويندوز ,, اذا كان الويندوز لديك إصدار 10 أو 11 ، فجرب اقرأ ها الموضوع ، عله يكون مفيداً لك .. الإصدار الأخير من الأداة في هذه المشاركة هنا ..

و عليكم السلام الكود التالي يحقق المطلوب فقط تأكد من أن الملفين في نفس المسار Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String WSname = "إدخال بيانات أساسية" ' تأكد من أن الاسم مطابق تمامًا On Error GoTo ErrorHandler Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False ' تحديد مسار الملف FilePath = ThisWorkbook.Path & "\Book2.xlsb" ' تأكد من امتداد الملف ' التحقق من وجود الملف If Dir(FilePath) = "" Then MsgBox "ملف Book2 غير موجود في المسار: " & vbCrLf & FilePath, vbExclamation Exit Sub End If ' فتح الملف بكلمة المرور Set Wb1 = Workbooks.Open(FilePath, Password:="123") ' تأكد من كلمة المرور Set Wb2 = ThisWorkbook ' التحقق من وجود ورقة العمل Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "ورقة العمل '" & WSname & "' غير موجودة في أحد الملفين", vbCritical Wb1.Close False Exit Sub End If ' نسخ البيانات Set OnRng = WSdata.UsedRange If OnRng.Cells.CountLarge = 1 And IsEmpty(OnRng.Value) Then MsgBox "لا توجد بيانات في الورقة المصدر", vbExclamation Wb1.Close False Exit Sub End If WSdest.Cells.UnMerge WSdest.Cells.ClearContents OnRng.Copy With WSdest.Range("A1") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Wb1.Close False MsgBox "تم نسخ البيانات بنجاح", vbInformation ExitHandler: Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Exit Sub ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical Resume ExitHandler End Sub

السلام عليكم ورحمة الله وبركاته الكود المرفق في طلبك الاول لا يتناسب مع وافع الملف وخصوصا النطاقات K13:KJ - H14:H فهي ليس لها اهمية خسب ملفك المرفق اليك التعديل حسب فهمى لفكرة عمل ملفك يتم ما تم ترخيله باللون الاصفر ويمكن الغائها من الكود بحذف السطر w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) الكود Sub dahmour() Dim w As Workbook Dim L As Variant Dim r1 As Long, r2 As Long, c As Long Dim cell As Range, cell2 As Range Dim colNum As Long Dim matched As Boolean Dim rng As Range, cellDate As Range Set w = ActiveWorkbook L = w.Sheets("Sheet2").Range("D2").Value If L = "" Then MsgBox "يرجى اختيار التاريخ من الخلية D2!", vbExclamation Exit Sub End If r1 = w.Sheets("Sheet2").Cells(w.Sheets("Sheet2").Rows.Count, 1).End(xlUp).Row r2 = w.Sheets("Galal").Cells(w.Sheets("Galal").Rows.Count, 1).End(xlUp).Row Set rng = w.Sheets("Galal").Range("E7:Z7") c = 0 For Each cellDate In rng If IsDate(cellDate.Value) And IsDate(L) Then If CDate(cellDate.Value) = CDate(L) Then c = cellDate.Column Exit For End If End If Next cellDate If c = 0 Then MsgBox "لم يتم العثور على التاريخ '" & L & "' في الصف 7 من ورقة Galal", vbCritical Exit Sub End If If IsNumeric(w.Sheets("Sheet2").Range("K4").Value) Then colNum = w.Sheets("Sheet2").Range("K4").Value Else MsgBox "الخانة K4 يجب أن تحتوي على رقم العمود المراد ترحيله!", vbExclamation Exit Sub End If matched = False For Each cell In w.Sheets("Sheet2").Range("A11:A" & r1) If Trim(cell.Value) <> "" Then For Each cell2 In w.Sheets("Galal").Range("A8:A" & r2) If Trim(cell.Value) = Trim(cell2.Value) Then w.Sheets("Galal").Cells(cell2.Row, c).Value = w.Sheets("Sheet2").Cells(cell.Row, colNum).Value w.Sheets("Galal").Cells(cell2.Row, c).Interior.Color = RGB(255, 255, 153) matched = True Exit For End If Next cell2 End If Next cell If matched Then MsgBox "تم الترحيل بنجاح!", vbInformation Else MsgBox "لم يتم العثور على أي رقم جلوس مطابق!", vbExclamation End If End Sub الملف غياب1.xlsm

و أنتم بخير . جرب الكود التالي في الملف الأول Sub Button1_Click() Dim Wb1 As Workbook, Wb2 As Workbook, FilePath As String, OnRng As Range Dim WSdata As Worksheet, WSdest As Worksheet, WSname As String: WSname = "ملف 1" Application.ScreenUpdating = False Application.Calculation = xlCalculationManual With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر ملف Excel كمصدر للبيانات" .Filters.Clear: .Filters.Add "Excel Files", "*.xls; *.xlsx; *.xlsb" If .Show <> -1 Then MsgBox "لم يتم اختيار أي ملف", vbExclamation: Exit Sub FilePath = .SelectedItems(1) End With Set Wb1 = Workbooks.Open(FilePath) Set Wb2 = ThisWorkbook On Error Resume Next Set WSdata = Wb1.Sheets(WSname) Set WSdest = Wb2.Sheets(WSname) On Error GoTo 0 If WSdata Is Nothing Or WSdest Is Nothing Then MsgBox "لم يتم العثور على ورقة العمل", vbCritical Wb1.Close False Exit Sub End If ' تحديد النطاق من F9 إلى S609 Set OnRng = WSdata.Range("F9:S609") WSdest.Cells.UnMerge WSdest.Range("F9:S609").ClearContents ' مسح النطاق المحدد فقط OnRng.Copy With WSdest.Range("F9") .PasteSpecial xlPasteFormulas .PasteSpecial xlPasteFormats End With Application.CutCopyMode = False Application.Goto WSdest.Range("F9"), True Wb1.Close False Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True MsgBox "تم نسخ البيانات بنجاح", vbInformation End Sub

✨ ما الجديد في التحديث ؟.. 1️⃣ تم دعم إعدادات اللغة لكل دولة عربية على حدة :- تمت إضافة إعدادات خاصة لـ 17 دولة عربية ، تشمل : 🌐 اسم الإعدادات المحلية ( LocaleName ) . 🌐 معرّف اللغة ( LocaleID ) . 🌐 اسم الدولة باللغة الإنجليزية . 2️⃣ واجهة مستخدم محدثة ومحاكية لرسالة الويندوز :- تمت إضافة قائمة منسدلة ( ComboBox ) لتمكين المستخدم من اختيار الدولة العربية المراد ضبط الإعدادات لها . 3️⃣ مرونة في اختيار تخطيط لوحة المفاتيح :- يمكن للمستخدم اختيار / عدم اختيار إضافة و ضبط تخطيط لوحة المفاتيح وفقاً للدولة المحددة . ( تم حل المشكلة القديمة بعدم ظهور لوحة المفاتيح بعد استخدام الأداة 👍 ) 4️⃣ مرونة في اختيار واجهة عرض نظام التشغيل ( Display Language Of Windows ) . ‼ هذه الميزة تتطلب تحميل حزمة اللغة العربية مسبقاً 5️⃣ رسائل واضحة ومخصصة :- تظهر للمستخدم رسالة عند إعادة تشغيل النظام ، مع اسم الدولة المختارة لتطبيق الإعدادات . 6️⃣ تعامل احترافي مع الأخطاء . 7️⃣ تمت إتاحة الفرصة للمبرمج من الإستفادة من النموذج بحيث يكون هو النموذج الرئيسي الذي سيعمل به مشروعه ، بحيث عند اكتشاف النموذج ان لغة الترميز ( اللغة الإدارية - Unicode ) لديه في نسخة نظام التشغيل ( ويندوز ) تدعم اللغة العربية ، فسيتم الإنتقال الى النموذج الرئيسي دون ظهور أي مشكلة أو تعطل البرنامج وتوقفه . وإذا لم يتم اكتشاف أن اللغة في نظامه تدعم اللغة العربية ، فسيتم فتح النموذج لتمكينه من تفادي وتلافي وحل هذه المشكلة من خلال استبدال سطر الرسالة الموجود في حدث عند التحميل للنموذج . 8️⃣ في هذا التعديل تم تلافي أي تغيير في إعدادات النظام والتشغيل لدى المستخدم مثل ( تنسيق التاريخ والوقت ، والعملات ، أسماء الأشهر والأيام .. إلخ ) MsgBox "استبدل هذه الرسالة بكود فتح النموذج الرئيسي", , "عندما تكون اللغة الإدارية = العربية" 👁‍🗨 صورة من واجهة التطبيق :- ودمتم في رعاية الله وحفظه [ LanguageCheck V 2.5.accdb ]

السلام عليكم ورحمة الله تعالى وبركاته بعد مرورى على موضوع استاذى الجليل واخى الحبيب الاستاذ @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

ع العموم للتخلص نهائيا من هذه المشاكل قمت ببعض التعديلات تم عمل التالى ترتيب اللغات داخل مربع السرد مع ضمان ظهرها باللغة العربية بشكل صحيح بدون مشاكل الترميز و طبقا لترتيب ويندوز الابقاء فقط على اللغات العربيىة طبقا لرغبتك اذا المرفق الاول يجمع كل الافكار وكل الاكواد ليكون مرجعا شاملا اما هذا المرفق الاخيـر يختص بحل المشكلة الخاصة بالترميز ودعم اللغة العربية على وجه الخصوص arabic for non unicode programs.accdb