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

بارك الله بك اخي علي ولاثراء الموضوع هذا الكود (بعمل في حال وجود فواصل عشرية "." ولا يتعاطى مع ما يوجد بين الارفام / +/ - /نصوص الخ....) Option Explicit Sub Extract_Number() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, x%, Ro%, My_Sum# Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Sheet1") Ro = ws.Cells(Rows.Count, "F").End(3).Row ws.Range("D4").Resize(15, 2).ClearContents With rgx .Global = True: .Pattern = "(\d+\.?\d+)" For i = 4 To Ro My_Sum = 0 If .test(ws.Cells(i, "F")) Then Set My_Number = .Execute(ws.Cells(i, "F")) ws.Cells(i, 5) = My_Number.Count For x = 0 To My_Number.Count - 1 My_Sum = My_Sum + Val(My_Number.Item(x)) Next x End If Cells(i, 4) = My_Sum Next i End With End Sub الملف مرفق Taswiyat.xlsm

اتفضل هذا التعديل Dim reportName As String Dim fileName As String Dim criteria As String reportName = "اسم التقرير" criteria = "[Image No] = 1 " ' هنا الفلتر DoCmd.OpenReport reportName, acViewPreview, , criteria, "" DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, fileName DoCmd.Close acReport, reportName, acSaveNo

تفضل اخي الكريم مع مراعاة تعديل ما يلزم Dim reportName As String Dim fileName As String Dim criteria As String reportName = "اسم التقرير" fileName = CurrentProject.Path & "\" & " اسم التقرير " & ".pdf" criteria = "[Image No] = 1 " ' هنا الفلتر DoCmd.OpenReport reportName, acViewPreview, , criteria, acHidden DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, fileName DoCmd.Close acReport, reportName, acSaveNo

تفضل التعديل ارجو ان يكون طلبك block-1.rar

وعليكم السلام 🙂 رجاء وضع عنوان يدل على الموضوع ، شكرا 🙂 فكرة اخوي حسام هي الافضل ، ولكن ولإثراء الموضوع ، يمكننا استخدام كائن صورة واحد في النموذج الرئيسي (المكان المكتوب عليه "اختر نوع الرقبة") ، ولنسميه img_main والموجود في النموذج الرئيسي "نموذج1" ، . وعند النقر في النموذج الفرعي على الصورة المطلوبة ، على حدث "النقر" يمكننا كتابة الكود التالي : Forms![نموذج1]!img_Main.PictureData = me.t4.PictureData او عمل وحدة نمطية ، وارسال اسم الكائن اليها في المتغير prev_img Forms![نموذج1]!img_Main.PictureData = Forms![نموذج1].PictureData . الفكرة هنا ، انه اذا عندنا شعار المؤسسة في النموذج الرئيسي ، واردنا في كل تقرير نطبعه ، ان نضع هذا الشعار ، فلا يوجد داعي الى الرجوع الى المجلد/الجدول الذي به هذه الصورة وجلبها من هناك ، وانما يمكننا استخدام الامر PictureData (اي نسخ الصورة) لإظهار هذا الشعار في التقارير/النماذج التي نريدها 🙂 جعفر تجربةالصور.zip

عليكم السلام الفكرة جميلة جدا عاشت ايديك تفضلالتعديل ارجو ان يكون طلبك ملاحظة : تم استخدام صور غير صورك للضرورة يمكنك تعديلها ووضع الصور التي تريد في جدول tblImages 512563393_-2.rar

اعتذر منك استاذي العزيز استاذ jjafferr وهذا هو التعديل حسب موافقة استاذ جعفر جزاه الله كل خير استاذ Ahmed_J يرجى التاكد اكثر من مرة من صحة النتائج قبل اعتماد التعديل B2.rar

وعليكم السلام 🙂 طريقة العمل: 1. انا بعمل حقل جديد ، ونوعه لازم يكون رقم . 2. في النموذج ، نختار نعمل "اختيار مجموعة" . نعمل مربع ، ونلغي بقية العملية . وعندك الاختيار في اختيار احد هذه الاشكال . نلاحظ انه لما يجي الماوس على المربع ، تلقائيا لونه يتغير للأسود ، مما يعني ان المربع تعرف على ان هذا الكائن الجديد هو تابع للمربع . ونعمل تغيير في اسم الكائن ، ونجعله مرتبط بالحقل Paid . الشيء الاخير اللي لازم نعمله هو ، نعطي لكل اختيار رقمه ، والاختيار الثاني ممكن يكون 2 ، والثالث 3 ، والرابع 4 ، ولا يكون لإختيارين نفس الرقم ، ولا يهم الاسم Option36 . نلاحظ الآن عند الاختيار ، فتلقائيا يعطينا اختيار واحد فقط : . وبما اننا في النهاية اخترنا الاختيار الثالث ، نرى في الجدول انه تم حفظ الرقم 3 : . هذه الطريقة تُغنينا عن مجموعة من الحقول 🙂 جعفر 1284.officna_q.accdb.zip

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

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

جرب هذا الكود هذا الكود يلغي الخطا ويعيد ترقيم الفاتورة ويقوم بالحفظ Private Sub Form_Error(DataErr As Integer, Response As Integer) If DataErr = 3022 Then Me.InvoiceNum = Next_Seq("A") DoCmd.RunCommand acCmdSaveRecord Response = 0 DoCmd.Close End If End Sub

السلام عليكم اعتذر منك استاذي العزيز qathi ومن استاذنا الغالي استاذ jjafferr حيث ان الحل الذي قدمته مشابه لحل استاذ جعفر لكن لم الاحظ ذلك ارجو المعذرة اساتذتي الكرام

مشاركة مع اساتذتي الاجلاء قم بتاخير رقم الفاتورة بعد اختيار اسم العميل Private Sub CustomerNum_AfterUpdate() Me.InvoiceNum = Next_Seq("A") DoCmd.RunCommand acCmdSaveRecord Me.OutNum = Me.InvoiceNum End Sub استخدم هذا الكود مع حذف القيمة الافتراضية لرقم الفاتورة

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

الخطوات اللي اتبعتها : 1. إلغاء اخذ القيمة الافتراضية من اعدادات الحقل : . 2. عملنا وحدة نمطية لعمل التسلسل ، ونناديها كلما احتجنا الى اضافة رقم جديد : . 3. والسر في نجاح هذه العملية ، هي حفظ السجل مباشرة بعد اخذ رقم التسلسل الجديد : . جعفر 1282.InvoiceSale_6.accdb.zip

وعليكم السلام 🙂 الحل بأن تضع هذا الكود في حدث ، وبعد اخذ الرقم التالي مباشرة تحفظ السجل ، وعلى افتراض ان اسم الحقل هو Sinf ، يصبح الكود هكذا : بدلا عن =IIf(IsNull(DMax("[id]";"items")+1);1;DMax("[id]";"items")+1) استخدم if len(me.Sinf & "")=0 then me.Sinf = nz(DMax("[id]","items"),0) +1 docmd.runcommand accmdsaverecord end if . جعفر

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

السلام عليكم ورحمته الله وبركاته اخوني خبراء منتدى اوفيسنا العريق نظراً لطلباتي الكثيرة وطبعاً اشكركم على الرد السريع و المشاركة المستمرة لكن لاني مبتدأ جداً في هذا المجال المهم ايها السادة طلبي هو عندي ملف مرفق مثلاً لدي 10 اسماء وتسلسلاتهم من 1 الى 10 اريد عند اضافة موظف جديد مثلا اريد تسلسل هذا الموظف يصبح رقم 3 ورقم 3 يصبح 4 والخ هلي يوجد كود يعمل هذا الشي لان تسلسلات الموظف اريدها حسب القدم بالتسلسل وليس بالخدمة مثلا وشكرا تجربه‌.accdb

مشاركه مع اخى واستاذى العزيز @husamwahab جزاه الله خيرا حاجه بسيطه على قدى ع حسب ما فهمت قمت بعمل استعلام تحديث وتصفيه القيم على حسب التسلسل الذى تكتبه بالنموذج ثم نقوم باضافه 1 لهذه القيم المصفاه بعد كتابه القيمه بالتسلسل قم بالضغط على زر تحديث لتشغيل الاستعلام UPDATE Home SET Home.تسلسل = [تسلسل]+1 WHERE (((Home.تسلسل)>=[Forms]![نموذج1]![تسلسل])); قمت بالتجربه على جعل جرب ووافنا بالنتيجه بالتوفيق تجربه‌(2).accdb

السلام عليكم 🙂 اعتقد بأني توصلت لحل ، وبعد عدة محاولات على الشبكة ، على كمبيوترين 🙂 1. النموذج ، تم حذف الجدول CustomersT من استعلام النموذج : . 2. الكومبوبوكس يقوم بإعطاء قيمة اسم الزبون CustomerName ، 3. تم حذف امر حفظ السجلات من الوحدة النمطية ، لأنها لم تكن على سجل النموذج ، فإنها لا تحفظ السجل المطلوب ، 4. تم استعمال هذا الكود لحفظ الترقيم : Private Sub New_Invoice() On Error GoTo err_New_Invoice Try_Again: If Me.NewRecord Then Me.InvoiceNum = Next_Seq("A") DoCmd.RunCommand acCmdSaveRecord End If Exit_New_Invoice: Exit Sub err_New_Invoice: If Err.Number = 3022 Then Dim PauseTime, Start PauseTime = 0.5 ' Set duration. Start = Timer ' Set start time. Do While Timer < Start + PauseTime DoEvents ' Yield to other processes. Loop Resume Try_Again Else MsgBox Err.Number & vbCrLf & Err.Description End If Resume Exit_New_Invoice End Sub . ولما البرنامج يلاحظ وجود تكرار في الرقم ، فإنه يذهب الى رقم الخطأ (3022 كما ذكره اخونا حسام) ، وهنا ينتظر 0.5 (نصف ثانية ، ويمكنك تقليلها ، وبالتجربة ستعرف الرقم الاصح ، والافضل ان تتركه كما هو) ، ثم يعاود المحاوله في الحصول على ترقيم جديد غير مكرر (وهذا الكود وضعته في حدثين) ، وتم تجربته عدة مرات واثبت جدارته 🙂 البرنامج بعده طازه وطالع من الشبكة ، فلازم تعمل له ربط للجداول قبل تشغيله ، فهو بدون جداول 🙂 جعفر 1282.1.InvoiceSale_6_FE.accdb.zip

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

اذا اتفضل هذا التعديل مع مراعاة اضافة اسم التقرير و الفلتر Dim ShellApp As Object Set ShellApp = CreateObject("Shell.Application"). _ BrowseForFolder(0, "Please choose a folder", 0, OpenAt) On Error Resume Next BrowseForFolder = ShellApp.self.path On Error GoTo 0 Set ShellApp = Nothing Select Case Mid(BrowseForFolder, 2, 1) Case Is = ":" If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid Case Is = "\" If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid Case Else GoTo Invalid End Select Dim reportName As String Dim fileName As String Dim criteria As String reportName = "اسم التقرير" fileName = BrowseForFolder & "\" & reportName & ".pdf" criteria = "فلتر SQL" DoCmd.OpenReport reportName, acViewPreview, , criteria, acHidden DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, fileName DoCmd.Close acReport, reportName, acSaveNo Exit Sub Invalid: BrowseForFolder = False

كان عليك تنفيذ نصيحة استاذنا الكبير سليم .. ولكن بعد اذن استاذ سليم طبعاً يمكنك استخدام هذه الدالة المعرفة لذلك لعد الأرقام داخل الخلية الواحدة Function Mylen(Z As Range) Dim C As Long, Y As Long, A As Long, B As Variant A = 0 For C = 1 To Len(Z) B = Mid(Z, C, 1) For Y = 0 To 9 If Y = B Then A = A + 1 End If Next Next Mylen = A End Function ووضع هذه المعادلة بداية من الخلية D4 سحباً للأسفل =Mylen(F4) أو يمكنك بهذه المعادلة العادية .. وتلك الطريقتين موجودة بالملف =SUM(LEN(F4)-LEN(SUBSTITUTE(F4,{1,2,3,4,5,6,7,8,9,0},))) تسويات - 1.xlsm

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

حياك الله استاذي الحبيب استاذ الفلاحجى والله مشتاقين

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

السلام عليكم استاذ @husamwahab شكرا لك كثيرا وبارك الله فيك حللت لي اكبر مشكلة يارب يجعلها في ميزان حسناتك السلام عليكم @jjafferr آسف لم انتبه لذلك تحياتي للجميع ولهذا المنتدى الرائع

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

1-لقد تم تنبيهك الى وجوب رفع ملف فيه الشرح الكافي 2- حبث انك عضو جدبد في المنتدى فأهلاً وسهلاً بك 3-لكن في المرة المقبلة سوف تحذف اي مشاركة بدون ملف مرفق جرب هذا الكود Option Explicit Rem code for Extact Number_From_Text Rem Created By Salim Hasbaya On 14/11/2020 Sub Extract_Number_From_Text() Dim rgx As Object Dim My_Number As Object Dim ws As Worksheet Dim i%, m%, k%, x%, Ro% Set rgx = CreateObject("VBScript.RegExp") Set ws = Worksheets("Salim") Ro = ws.Cells(Rows.Count, 1).End(3).Row With ws.Range("C1").Resize(Ro, 20) .ClearContents .Interior.ColorIndex = xlNone End With m = 1: k = 4 With rgx .Global = True: .Pattern = "(\d+)" For i = 1 To Ro If .test(ws.Cells(i, 1)) Then Set My_Number = .Execute(ws.Cells(i, 1)) ws.Cells(m, 3) = My_Number.Count & " Numbers" ws.Cells(m, 3).Interior.ColorIndex = 6 For x = 0 To My_Number.Count - 1 ws.Cells(m, k).Offset(, x) = Val(My_Number.Item(x)) Next x End If m = m + 1 Next i End With End Sub الملف مرفق فقط اضغط الزر Run Please Extract_Number_From_Text.xlsm

السلام عليكم اخي احمد 🙂 رجاء الالتزام بقوانين المنتدى ، وعمل موضوع منفصل لكل سؤال 🙂 تمت الاجابة على السؤال اصل الموضوع ، لذلك ، رجاء فتح موضوع جديد لبقية اسئلتك ، ولا مانع من ان يرد الاخ حسام على آخر حيثية من سؤالك 🙂 جعفر

بما انك لم تقم برفع ملف فكان عليك لزاماً استخدام خاصية البحث بالمنتدى فبه طلبك - تفضل معادلة جمع مبالغ (10+20+30)=60

تفضل اخي الكريم مع تعديل ما يلزم Dim msg1, msg2 As String msg2 = "يجب عدم ترك حقول فارغة للاستمرار" Dim ctl As Control For Each ctl In [اسم النموذج الفرعي].Controls If TypeName(ctl) = "TextBox" Then If IsNull(ctl) Or ctl = "" Or ctl = 0 Then If msg1 = "" Then msg1 = ctl.Name Else msg1 = msg1 & vbNewLine & ctl.Name End If End If End If Next ctl If msg1 = "" Then DoCmd.RunCommand acCmdSaveRecord MsgBox "تم الحفظ بنجاح", vbInformation, "تأكيد" Else MsgBox msg2 & vbNewLine & msg1, vbCritical + vbMsgBoxRight, "تنبيه بوجود حقول فارغة" End If

تفضل --------->>>>>> copy_kan.accdb

هناك طريقة قد تكون مفيدة لك وهي ان نجعل القيمة الافتراضية لرقم الفاتورة رقم غريب وغير مستعمل وكذلك نوع الحركة وهذه القيم متغيرة من حاسبة لاخرى في الحاسبة الاولة مثلا رقم الفاتورة A1 ونوع الحركة B1 وفي الحاسبة الثانية A2 ونوع الحركة B2 وهكذا ثم نقوم بادخال البيانات بالطريقة المتبعة وفي اخر اجراء او حركة كان يكون زر حفظ نضع كود يجعل نوع الحركة النوع المطلوب ورقم الفاتورة هو كود الترقيم وبهذه الطريقة ستظمن عدم تكرر رقم الفاتورة

وعليكم السلام 🙂 اخي الفاضل ، في المرات القادمة ، رجاء مراعاة قوانين المنتدى بوضع عنوان يدل على محتوى السؤال 🙂 اما سؤالك : خطأ Over Flow معناه ان القيمة اكبر من حجم المتغير ، المتغير x و i عندك integer ، فيجب تكبير هم الى Long . جعفر

تفضل التعديل تعريف الاعداد الكبيرة يكون ب Long بدل Integer Database2.rar تفضل التعديل تعريف الاعداد الكبيرة يكون ب Long بدل Integer

لا عليك أخي حسام اتيت بما خطر ببالك اشكرك على ردك

وعليكم السلام 🙂 ممكن تشرح لي كيف عملت التجربة ، خليني اقوم بمثلها ، واجرب 🙂 جعفر

تفضل التعديل اخي الكريم يجب فك الضغط عن الملفات اولاً تصدير البيانات.zip

تفضل هذه المشاركة اخي الكريم لعلها تحل المشكلة فقط نسخ هذا الكود الصقه في حدث ازرار الحفظ Dim rs As DAO.Recordset Set rs = CurrentDb.OpenRecordset("SELECT Max(InvoiceNum) FROM InvoiceHT;") InvoiceNum = "A" & Format(Nz(rs.Fields(0), 0) + 1, "1000") rs.Close Set rs = Nothing

وعليكم السلام 🙂 نعم ممكن ، ولكن ليس الطباعة من الاكسس ، ولكن بتصدير البيانات الى ملف pdf او اكسل ، وهناك تستطيع ان تطبع على صفحة واحدة 🙂 جعفر

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

وعليكم السلام 🙂 هذا الرابط في التصدير الى الوورد . اما التصدير الى الاكسل . او . جعفر

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

بعد اذن الاخ علي معادلة احرى (تنسيق الخلايا Percent) =CHOOSE((S3="")+1,CHOOSE(OR(S3="وليد ",S3="سعيد")+1,0.14,0.1),"")

وعليكم السلام- يمكنك استخدام هذه المعادلة =IF(S3="","",IF(OR($S3="وليد",$S3="سعيد"),10%,14%)) Test1.xlsx

تفضل client11.rar

اتفضل غيرت حقل التاريخ من تيكست الى تاريخ وتم استخدام هذا الكود للفتح التقرير استعلام بين تاريخين.rar

السلام عليكم دالة استخراج تاريخ الميلاد او النوع او المحافظة من الرقم القومي ثلاثة معطيات بدالة واحدة Option Explicit ' بسم الله الرحمن الرحيم ' ******************** ' دالـــــــــــــــة ' Kh_Date_Sex_Province ' ( استخراج تاريخ الميلاد او النوع (ذكر - انثى ' او المحافظة من الرقم القومي '============================================== ' MyTest ' اذا كانت = 1 تقوم باستخراج تاريخ الميلاد ' اذا كانت = 2 تقوم باستخراج النوع ' اذا كانت = 3 تقوم باستخراج المحافظة '---------------------------------------------- ' MyProvinces في متغير الجدول ' العمل لم يستكمل بعد ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ ' بنفس الطريقة الرقم اولا ثم "/" ثم اسم المحافظة ' : مثال على ذلك ' "01/القاهرة" '============================================== '----------------------------------------------------------------- Function Kh_Date_Sex_Province(MyNumber As Variant, MyTest As Byte) Dim MyProvinces As Variant Dim r As Integer Dim yy As String Dim ty As String * 1 Dim d As String * 2, m As String * 2, y As String * 2 _ , x As String * 2, xx As String * 2 '============================================== ' يمكنك إضافة المحافظات الاخرى الغير موجودة ' او تعديل الموجود في حالات الخطأ MyProvinces = Array("01/القاهرة", "02/الإسكندرية", "12/الدقهلية", "13/الشرقية" _ , "14/القليوبية", "15/كفر الشيخ", "16/الغربية", "17/المنوفية", "18/البحيرة" _ , "19/الإسماعيلية", "21/الجيزة", "22/بني سويف", "24/المنيا", "25/أسيوط" _ , "26/سوهاج", "27/قنا", "28/أسوان", "29/الأقصر", "33/مطروح") '============================================== Kh_Date_Sex_Province = "" On Error GoTo 1 If Len(Trim(MyNumber)) = 0 Then GoTo 1 End If If Not IsNumeric(MyNumber) Or Len(MyNumber) <> 14 Then Kh_Date_Sex_Province = "Error_MyNumber" GoTo 1 End If If MyTest = 1 Then d = Mid(MyNumber, 6, 2) m = Mid(MyNumber, 4, 2) y = Mid(MyNumber, 2, 2) ty = Left(MyNumber, 1) Select Case ty Case "2": yy = y Case "3": yy = "20" & y Case Else: yy = "" End Select If yy <> "" Then Kh_Date_Sex_Province = DateSerial(yy, m, d) ElseIf MyTest = 2 Then If Left(Right(MyNumber, 2), 1) Mod 2 = 1 Then _ yy = "ذكر" Else yy = "انثى" Kh_Date_Sex_Province = yy ElseIf MyTest = 3 Then x = Mid(MyNumber, 8, 2) For r = LBound(MyProvinces) To UBound(MyProvinces) xx = MyProvinces(r) If x = xx Then Kh_Date_Sex_Province = Right(MyProvinces(r), Len(MyProvinces(r)) - 3) Exit For End If Next End If 1: End Function بالنسبة لمعطيات المحافظات لم تستكمل بعد ويمكنك اضافة المحافظات المتبقية حسب ما شرحت بالكود خبور خير دالة استخلاص تاريخ الميلاد و النوع و المحافظة من الرقم القومي.rar

السلام عليكم الاخ الكريم / aburajai بارك الله فيك لتنفيذ ما تريده قم بوضع الاكواد التاليه باكواد الفورم واليك ملف مرفق به فورم مع الاكواد المذكورة لالغاء الشريط الازرق من الفورم ( ترويسه الفورم ) Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long Const GWL_STYLE = -16 Const WS_CAPTION = &HC00000 Const WS_SYSMENU = &H80000 Private Sub UserForm_Initialize() On Error Resume Next Dim lngWindow As Long, lFrmHdl As Long lFrmHdl = FindWindow(vbNullString, Me.Caption) lngWindow = GetWindowLong(lFrmHdl, GWL_STYLE) lngWindow = lngWindow And (Not WS_CAPTION) Call SetWindowLong(lFrmHdl, GWL_STYLE, lngWindow) Call DrawMenuBar(lFrmHdl) End Sub Private Sub CommandButton1_Click() End End Sub جزاك الله خيرا الغاء الترويسه من الفورم.rar