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

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

السلام عليكم 🙂 الجوازات والبطاقات الشخصية والهويات الحكومية ، في اسفلها كود يسمى MRZ وفيه معلومات من الوثيقة ، الجواز ، وفي اسفله سطرين من كود MRZ : . والهوية ، وفي اسفلها 3 اسطر من كود MRZ : . وهناك عدة اجهزة (هي في الواقع سكانرات) التي يمكنها قراءة هذه الوثائق ، وتستعمل نظام OCR وتحول الصورة الى نص ، ومن ضمن هذه الاجهزة ، جهاز 3M CR100 https://www.gemalto.com/govt/document-readers/cr100 والظاهر ان هذا الجهاز معتمد من قِبل البوابة الالكترونية الموحدة لحجاج الخارج . . تنزيل وتنصيب برنامج التشغيل : http://www.3m.com/ssdcp/3M Swipe Readers/SDK/3M Swipe Reader SDK 1.2.1.2 Setup.exe خلونا نستعمل هذا الجهاز عن طريق الاكسس 🙂 بعد تنصيب برنامج تشغيل الجهاز ، يقوم برنامج الاكسس بتشغيل برنامج الجهاز في الكمبيوتر (فإذا ما عملت تنصيب للبرنامج ، اوقف عمل السطر : ) Private Sub Form_Load() On Error GoTo err_Form_Load 'turn ON the scanner xml program ' Call Restart_XML '<<< اوقفوا عمل هذا السطر . النموذج يكون جاهز على الحقل Line_0 ، والذي يبدا بأخذ نتيجة OCR ، . . وتكون النتيجة بهذه الطريقة (انا وضعت الارقام امام الاسطر) : 0'START 1'OCR Line 1: IDOMN1900000<<3<<<<<<<<<<<<<<< 2'OCR Line 2: 7008529M2018227OMN<<<<<<<<<<<6 3'OCR Line 3: ALI<MOHAMMED<HUSSAIN<<AL<MOOSA 4'MSR Track 1: 5'MSR Track 2: 6'MSR Track 3: 7'End . لعمل البرنامج ، اضطررت لعمل الاكواد بنفسي ، لأن SDK الجهاز كانت للغات اخرى غير VBA ، وهذه الوحدة النمطية التي تقوم بتفكيك الكود اعلاه ، سواء لجواز او بطاقة او فيزا : Public Function Parse_MRZ(frmN As String) On Error GoTo err_Parse_MRZ ' '08-06-2018 'by jjafferr ' Dim L1 As String Dim L2 As String Dim L3 As String Dim gDocType As String Dim Pass_Type As String Dim gLastName As String Dim gFirstName As String L1 = Replace(Forms(frmN)!Line_1, "OCR Line 1: ", "") L2 = Replace(Forms(frmN)!Line_2, "OCR Line 2: ", "") L3 = Replace(Forms(frmN)!Line_3, "OCR Line 3: ", "") gDocType = Mid(L1, 1, 1) Select Case gDocType Case "P", "V" 'passport , Visa Forms(frmN)!gDocType = gDocType 'LINE 1 Pass_Type = Mid(L1, 2, 1) 'Either < or Passport type Forms(frmN)!gIssuing = Mid(L1, 3, 3) gLastName = Mid(L1, 6, InStr(L1, "<<") - 6) gLastName = Replace(gLastName, "<", " ") Forms(frmN)!gLastName = Trim(gLastName) gFirstName = Mid(L1, InStr(L1, "<<") + 2, InStr(InStr(L1, "<<") + 1, L1, "<<") - InStr(L1, "<<") - 2) gFirstName = Replace(gFirstName, "<", " ") Forms(frmN)!gFirstName = Trim(gFirstName) Forms(frmN)!gDocNumber = Mid(L2, 1, 9) 'LINE 2 Forms(frmN)!gCountry = Mid(L2, 11, 3) Forms(frmN)!gDOB = DateSerial(Mid(L2, 14, 2), Mid(L2, 16, 2), Mid(L2, 18, 2)) Forms(frmN)!gGender = Mid(L2, 21, 1) Forms(frmN)!gDocExpiry = DateSerial(Mid(L2, 22, 2), Mid(L2, 24, 2), Mid(L2, 26, 2)) Forms(frmN)!gAddInfo = Mid(L2, 29, InStr(L2, "<<") - 29) Case "I", "A", "C" 'ID Forms(frmN)!gDocType = Mid(L1, 1, 2) Pass_Type = Mid(L1, 2, 1) 'Either < or completing the first letter Forms(frmN)!gIssuing = Mid(L1, 3, 3) Forms(frmN)!gDocNumber = Mid(L1, 6, InStr(L1, "<<") - 6) Forms(frmN)!gDOB = DateSerial(Mid(L2, 1, 2), Mid(L2, 3, 2), Mid(L2, 5, 2)) 'LINE 2 Forms(frmN)!gGender = Mid(L2, 8, 1) Forms(frmN)!gDocExpiry = DateSerial(Mid(L2, 9, 2), Mid(L2, 11, 2), Mid(L2, 13, 2)) Forms(frmN)!gCountry = Mid(L2, 16, 3) gFirstName = Mid(L3, 1, InStr(L3, "<<") - 1) 'LINE 3 gFirstName = Replace(gFirstName, "<", " ") Forms(frmN)!gFirstName = Trim(gFirstName) gLastName = Mid(L3, InStr(L3, "<<") + 2) gLastName = Replace(gLastName, "<", " ") Forms(frmN)!gLastName = Trim(gLastName) End Select Exit_Parse_MRZ: Exit Function err_Parse_MRZ: If Err.Number = 9 Then 'susbcription out of order, ignore Resume Next ElseIf Err.Number = 13 Then 'Type mismatch, ignore Resume Next Else MsgBox Err.Number & vbCrLf & Err.Description Resume Exit_Parse_MRZ End If End Function برنامجي الذي في الخدمة ، يقرأ بيانات الجوازات والهويات في اقل من 3 ثواني ، بالأضافة الى قراءة باركود بعض الهويات الاخرى ، وادخال يدوي لأنواع اخرى من الهويات ، لهذا السبب كان يتطلب مني استعمال هذه الاحداث🙂 Public Sub Line_0_BeforeUpdate(Cancel As Integer) Private Sub Line_0_KeyDown(KeyCode As Integer, Shift As Integer) Private Sub Line_0_AfterUpdate() Private Sub Line_7_AfterUpdate() . احد اهم الامور التي اخذت مني وقت طويل لمعرفتها هي ، يجب ان تكون لغة الكيبورد بالانجليزي ، وقت قراءة البطاقة ، وإلا فالنتائج تعطيك خطأ ، لهذا السبب فالبرنامج تلقائيا يحول اللغة الى انجليزي ، لما التركيز يكون في حقل Line_0 🙂 الجدول و الكود قد يكون فيه بقايا من برنامجي ، ولكن لن يضروكم ان شاء الله 🙂 جعفر CR100 card reader.zip

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

ممكن ذلك من خلال هذا التعديل على الكود Option Explicit Sub Find_Dupl_Rows_new() Dim I%, Ro, m% Dim REP As Range, My_Rg As Range Dim COl As Collection Dim Arr, n Set COl = New Collection Set My_Rg = Range("A1").CurrentRegion Ro = My_Rg.Rows.Count Set My_Rg = My_Rg.Offset(1).Resize(Ro - 1) My_Rg.Interior.ColorIndex = xlNone Range("E2").Resize(Ro - 1).ClearContents Range("G2:K2").Resize(Ro - 1).Clear For I = 2 To Ro Arr = Application.Transpose(Application.Transpose _ ((Cells(I, 2).Resize(, 3)))) Arr = Join(Arr, "*") On Error Resume Next COl.Add I, Arr If Err.Number <> 0 Then m = m + 1 Cells(I, 5) = "Duplicate" Cells(I, 5).Interior.ColorIndex = 40 If REP Is Nothing Then Set REP = Cells(I, 2).Resize(, 3) Else Set REP = Union(REP, Cells(I, 2).Resize(, 3)) End If 'REP End If 'Err Next I On Error GoTo 0 If Not REP Is Nothing Then REP.Interior.ColorIndex = 40 MsgBox "You have :" & m & " duplicate Rows" n = REP.Areas.Count m = 1 For I = 1 To n Range("G1").Offset(m).Resize(REP.Areas(I). _ Rows.Count, 3).Value = REP.Areas(I).Value Range("j1").Offset(m) = REP.Areas(I).Address Range("K1").Offset(m) = REP.Areas(I).Rows.Count m = m + REP.Areas(I).Rows.Count Next '================================= With Cells(2, "g").Resize(m - 1, 5) .Borders.LineStyle = 1: .Font.Size = 16 .Font.Bold = True: .Interior.ColorIndex = 28 .InsertIndent 1 End With '========================= Else MsgBox "Not duplicate Rows " End If Set COl = Nothing: Set REP = Nothing End Sub

تفضل تم وضع المعادلة في العمود E وتتم الفلترة من خلال هذا العمود =IF(AND(ISBLANK(B2);ISBLANK(C2));"إخفاء الصف";"") Filtering.xlsx

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

ممكن جمع الارقام في مربعات النص باستخدام دالة val Val([ملف_انجاز])+Val([امتحان]) جرب المرفق جمع الارقام من مربع نص تنسيقه نص1.accdb

تفضل -يمكنك استخدام معادلة المصفوفة .... لا تنسى الضغط على Ctrl+Shift+Enter =MIN(IF($B$5:$B$21>=TODAY(),$B$5:$B$21)) اظهار التاريخ القادم2.xlsx

تم التعديل قليلاً على الموضوع السابق لادراج الصفوف المكررة وليس فقط تحديدها Find_dup_rows_NEW.xlsm

تفضل 1- ضع المجلد في القسم c 2- الخلية a1 تحتوي على مسار الملفات وهي ثابته لاتغيرها 3- الخلايا من " a2:a400 " تحوي معادلة جلب اسماء الملفات وامتدادها في المجلد المسمى "الملف موجود ام غير موجود" بالاعتماد على دالة تم وضعها في محرر الاكواد 4- اكتب اسم الملف في الخلية b1 سيتم اجراء فلترة للعمود a اذا لم ييظهر اسم الملف بعد الفلترة يعني اما مفقود من المجلد... او لم تكتب اسمه بالشكل الصحيح المطابق لاسم الملف 5- اذا رغبت بتغير اسم المجلد او نقله لمكان اخر يجب تحديث المسار الجديد ونسخه في الخلية a1 الملف موجود أم غير موجود.rar

وعليكم السلام اتفضل ان شاء الله يكون ما طلبت حتى وانت فاتح النموذجين سيتم التحديث بمجرد انتقالك للسجل التالى وليس للحقل التالى تقبل تحياتى وتمنياتى لك وللجميع بالتوفيق Aa_New Microsoft Access Database.rar

ربما كان هذا المطلوب Repeet_by_choise.xlsx

بارك الله فيك ووفقك الله دائما الى مساعدة الأخرين

وعليكم السلام 🙂 في حقل رقم في الجدول ، لا يمكنك ان تُدخل حروف ، ولكن يمكنك ان تُدخل اي رقم تريد 🙂 فخلينا نقول ، ان الغائب تعطيه علامة 200 : وفي الاستعلام ، نعمل معادلة: اذا كان الرقم = 200 ، فأعطنا الحرف غ 🙂 جعفر جمع الارقام من مربع نص تنسيقه نص1.zip

أحسنت استاذ سليم بارك الله فيك وزادك الله من فضله

بارك الله فيك استاذ أحمد

جرب هذه المعادلة =EDATE($A$1,$A$2)

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

وعليكم السلام -طبعا اخى الكريم فى ملف اكسيل

بارك الله فيك أخى الكريم ونوت المنتدى

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

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

السلام عليكم 🙂 الفكرة هي ، انه الجداول موجودة في الواجهة الخلفية BE ، واللي موجودة على السيرفر ، واللي نريد نحصل على وقته ، نضع هذه الوحدة النمطية فيه: Public Function Server_Date_Time() As Date Server_Date_Time = Now() End Function . ثم في برنامج الواجهة FE نضع هذه الوحدة النمطية : Public Function Call_Server_F() Dim apAccess As New Access.Application apAccess.OpenCurrentDatabase (DLookup("[Database]", "MSysObjects", "[Flags]=2097152")) Call_Server_F = apAccess.Run("Server_Date_Time") End Function ثم من النموذج ننادي هذه الوحدة النمطية : me.Server_Time = Call_Server_F جرب المرفق: ضع BE على السيرفر ، والـ FE على كمبيوتر آخر ، ثم شغّل FE 🙂 جعفر Server Time.mdb.zip

🙂 جعفر

السلام عليكم فقط قمت باضافة حقل ID تفضل اخي اتمنى يكون المطلوب ESAL-1.rar

يا اخي المثال غير واضح تماماً جميع الجداول تحتوي على (الكود غير صحيح) و ليس هناك جدول كامل بينها رجاء ارفق ملف فيه صفحتين أو ثلاثة لا أكثر (مع عدم دمج اي خليين داخل الجداول) لا تحتوي كل صفحة على أكثر من 10 صفوف فقط مع ملء الجداول ( الجدوال التي ارسلتها فارغة وليس عندي وقت كي املئها ببيانات عشوائية)

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

لو سمحت اخي ممكن ترفع صورة عن المشكلة او الملف الذي تعمل عليه لانه يمكن ان تكون هناك معادلات تعمل المشكلة دي عموما الكود يعمل عندي بحيث لما تعمل ضوبل كليك بالماوس على اي اسم في شيت 1 ينتقل الى الشيت2 ويظهر الاسم ورقم الهاتف في استمارة واحدة

من واجهة البرنامج يبدو لي انه ليس مصمم بالاكسس اعتقد هذه واجهة فجول بيسك ...؟ اذا كان الأمر كذالك يكون موضوعك وسؤالك ليس هذا مكانه وعلى العموم تأكد من اصدار حزمة Microsoft .NET Framework في الجهاز الاخر تكون نفس اختيارك عند بدأ تصميم البرنامح في تطبيق visual studio ::بالتوفيق::

شكرا استاذ خالد شهادة اعتز بيها

See this file E2.xlsx

اخي العزيز المشكله في الاستعلام وانا شرحتها لك سابقا وهي (ان الحقول A8 , A9 هي فارغة تماما ) احذف المعيار ISNULL منها لانها فارغة اصلا لو وضعتها سوف تظهر لك كل السجلات لان المعيار ينطبق عليها تحياتي FMARK.rar

انظر مسافة يمين فورم الفرعي عند العرض.rar

السلام عليكم 1- الملف الاول فيه تنبيه انك ادخلت رقم ايصال (ويعطيك رقمه برسالة) سابقا ويرفض التسجيل 2- الملف الثاني فيه تنبيه انك ادخلت رقم ايصال (ويعطيك رقمه برسالة) سابقا ويسمح التسجيل اتمنى يكون طلبك تحياتي ESAL-1.rar ESAL-2.rar

اخي العزيز صباح النور والبركات تفضل الملف اتمنى يكون المطلوب مثال اوفيسنا منع ترك حقل فارغ.rar

تفضل اخي حسب مافهمت من طلبك اتمنى يكون المطلوب MM-2.rar

هل الجداول في قاعدة والنماذج في قاعدة أخرى ؟؟؟؟؟

تلوين اسماء الشيتات بضغطة واحدة لاى عدد من الشيتات الفيديو

انا بصراحة شغال على 2007 والملف كويس معايا

انا لا ارى اى مشكلة فى الفلترة فهى تعمل عندى تمام

تفضل اخى الكريم طالمل لم تقم برفع ملف كان عليك رفع ملف تجنبا لمضيعة الوقت -1ترتيب الاسماء.xlsm

تفضل بنسخة Mdb وكلمة السر واسم المستخدم 1 العيادات الطبية.mdb

تفضل اخى الكريم ليس هناك اى خطأ فى معادلة جلب الأسماء بدون تكرار ولكن الخطأ كان فى طريقة اقفال المعادلة فهذه معادلة مصفوفة وليست كمعادلة عادية ان تضغط على انتر بعد انهاء المعادلة ولكن لابد من الضغط على Ctrl+Shift+Enter بدون تكرار2.xlsm

وعليكم السلام ,تفضل الملف بعد التعديل عليه 99.xlsx

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

اهلا بك اخ كريم فى المنتدى تفضل يعرض قيمة الخلية C5 فى تكست بوكس1 فى الفورم Userform.xlsm

لة ممكن رفع الملف حتى نتمكن من حل المشكلة

الكود التالي يحدف الملف بعد مرة واحدة من استعماله تلقائيا و بدون اشعار المستخدم ! ضع الكود في ThisWorkbook Module Option Explicit Private Const MAX_USES As Long = 1 Private Sub Workbook_Open() Dim lNumberOfUses As Long  On Error Resume Next lNumberOfUses = Evaluate("NumberOfUses") If Err.Number = 13 Then Me.Names.Add "NumberOfUses", 1, False Me.Save Exit Sub End If Me.Names.Add "NumberOfUses", Evaluate("NumberOfUses") + 1, False Me.Save If Evaluate("NumberOfUses") > MAX_USES Then Kill_Myself End Sub Private Sub Kill_Myself() With Me .Saved = True .ChangeFileAccess xlReadOnly Kill .FullName .Close False End With  End Sub ينصح اقفال الكود بباسوورد لمنع المستخدم من رؤية او حدف الكود

بارك الله فيك دائما وفى استاذنا الكبير ياسر خليل ابو البراء له منا كل الحب والإحترام وأدامه الله دائما عونا لنا جعله الله فى ميزان اعماله وغفر الله له

اتفضل استاذ رمهان هذا البرنامج يفتح جميع الملفات المضغوطة وبكل الامتدادات وخفيف وجميل .. وكل الشكر للاستاذ جعفر هو من دلنى عليه برنامج ضغط الملفات 7z1801.rar