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

وعليكم السلام 🙂 رجاء النظر الى جدول ascii هذا ، والذي فيه جميع رموز لوحة المفاتيح الانجليزية: . بمعنى آخر ، كل زر تنقر عليه على لوحة المفاتيح (حرف يمكنك رؤيته وقراءته) ، يتم ترجمتها في الكمبيوتر ، حسب طلب البرنامج الذي تستعمله ، الى واحدة من هذه الارقام والرموز 🙂 من الجدول ، انظر الى الحقل Dec الرقم 10 و 13 ، والقيم التي تقابلها من الحقل Chr (او Char) (ومعناها) ، فهذه القيم هي التي تقرر الانتقال الى السطر التالي ، هكذا chr(10) و chr(13) 🙂 هذه القيم تعتمد على البرنامج الذي يستخدمها ، فهناك من يستعمل 10 وهناك من يستخدم 13 وهناك من يستخدمهم معا 🙂 رجاء تنظر الى المشاركات في هذا الرابط حتى يصير عندك إلمام كامل بالموضوع: . وفي محرر الاكواد VBE ، يمكننا استعمال مسميات هذه الرموز بلغة الاكسس (والتي تم اخذها من لغة Visual Basic ، VB) ، بدلا من الارقام اعلاه ، في محرر الاكواد ، ابحث عن vb constants ، وسترى قائمة المسميات . وعند النقر على الرابط الذي عليه السهم (الاوامر التي تخص موضوعنا) . نرى ان خياراتنا لجواب سؤالك اصبحت: الطريقة 2 او الطريقة 1 Me.text3=Me.text1 & vbNewLine & Me.text2 Me.text3=Me.text1 & chr(13) & chr(10) & Me.text2 Me.text3=Me.text1 & vbCrLF & Me.text2 Me.text3=Me.text1 & chr(13) & chr(10) & Me.text2 Me.text3=Me.text1 & vbLF & Me.text2 Me.text3=Me.text1 & chr(10) & Me.text2 Me.text3=Me.text1 & vbCr & Me.text2 Me.text3=Me.text1 & chr(13) & Me.text2 جعفر

أولا : طهور إن شاء الله، أوصيكم بالصبر والثبات والإكثار من ذكر الله، أعظم الله أجركم، وضاعف مثوبتكم، شفاكم الله وعافاكم اللهم إني أسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ علي أخونا عبد الله وعلى كل مريض بالشفاء العاجل، وألّا تدع فينا جرحًا إلّا داويته، ولا ألمًا إلا سكنته، ولا مرضًا إلا شفيته، وألبسنا ثوب الصحة والعافية عاجلًا غير آجل، وشافِنا وعافِنا واعف عنا، واشملنا بعطفك ومغفرتك، وتولّنا برحمتك يا أرحم الراحمين إلهي أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقمًا، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يا رب العالمين ربنا الله الذي في السماء، تقدّس اسمك، أمرك في السماء والأرض، كما رحمتك في السماء، اجعل رحمتك في الأرض، اغفر لنا خطايانا، أنت رب الطيبين، أنزل رحمة من رحمتك، وشفاءً من شفائك على على كل مريض من أي وجع فيبرأ اللهم يا مُفرّج الكرب يا مُجيب دعوة المُضطرين، اللهم ألبس كل مريض ثوب الصحة والعافية عاجلًا غير آجل يا أرحم الراحمين، اللهم اشفى كل مريض ، اللهم اشفى كل مريض، اللهم اشفى كل مريض، اللهم آمين ----------------------- ثانيا : تتمحور فكرتي المتواضعة في هذه الاكواد والتي تكتب في موديول ويتم استدعائها حسب الحاجة انظر التطبيق داخل الاستعلام Public Function CountCapitals(fld) As Integer If fld & "" = "" Then Exit Function Dim StrLn As Integer CountCapitals = 0 For StrLn = 1 To Len(fld) Select Case Asc(Mid(fld, StrLn, 1)) Case 65 To 90: CountCapitals = CountCapitals + 1 End Select Next StrLn End Function Public Function CountSmall(fld) As Integer If fld & "" = "" Then Exit Function Dim StrLn As Integer CountSmall = 0 For StrLn = 1 To Len(fld) Select Case Asc(Mid(fld, StrLn, 1)) Case 97 To 122: CountSmall = CountSmall + 1 End Select Next StrLn End Function Public Function CountingNumbers(fld) As Integer If fld & "" = "" Then Exit Function Dim StrLn As Integer CountingNumbers = 0 For StrLn = 1 To Len(fld) Select Case Asc(Mid(fld, StrLn, 1)) Case 48 To 57: CountingNumbers = CountingNumbers + 1 End Select Next StrLn End Function Public Function CountingArabic(fld) As Integer If fld & "" = "" Then Exit Function Dim StrLn As Integer CountingArabic = 0 For StrLn = 1 To Len(fld) Select Case Asc(Mid(fld, StrLn, 1)) Case 192 To 214: CountingArabic = CountingArabic + 1 Case 216 To 219: CountingArabic = CountingArabic + 1 Case 221 To 223: CountingArabic = CountingArabic + 1 Case 225: CountingArabic = CountingArabic + 1 Case 227 To 230: CountingArabic = CountingArabic + 1 Case 236 To 237: CountingArabic = CountingArabic + 1 End Select Next StrLn End Function Public Function CountingSpecialCharacter(fld) As Integer If fld & "" = "" Then Exit Function Dim StrLn As Integer CountingSpecialCharacter = 0 For StrLn = 1 To Len(fld) Select Case Asc(Mid(fld, StrLn, 1)) Case 33 To 47: CountingSpecialCharacter = CountingSpecialCharacter + 1 Case 58 To 64: CountingSpecialCharacter = CountingSpecialCharacter + 1 Case 91 To 96: CountingSpecialCharacter = CountingSpecialCharacter + 1 Case 123 To 126: CountingSpecialCharacter = CountingSpecialCharacter + 1 End Select Next StrLn End Function Database5.accdb

السلام عليكم شباب 🙂 طريقتي: . وفي حدث "بعد تحديث" Date Start : Private Sub Date_Start_AfterUpdate() Me.cmb_3Dates.RowSourceType = "Value List" Me.cmb_3Dates.RowSource = Empty Me.cmb_3Dates.AddItem Me.Date_Start Me.cmb_3Dates.AddItem Me.Date_Start + 1 Me.cmb_3Dates.AddItem Me.Date_Start + 2 End Sub جعفر 1416.3Dates.accdb.zip

هذه المعادلة في C2 =SUM(B2,A2/100) تفي بالغرض بالتوفيق

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

دائما مبدع يا أبا جودي 😉

اتفضل بدون اى جداول فقط حسب الوجدة النمطية 3Dates.accdb

اذا كنت تفضلها بالاكواد بطريقتين 1 - UserForm1.Show 0 2- UserForm1.Show vbModeless

Sub Test() Dim x, y, sh As Worksheet, lr As Long, i As Long, cnt As Long With Sheet1 lr = .Cells(Rows.Count, 1).End(xlUp).Row For i = 4 To lr If .Cells(i, 1).Value <> "" And .Cells(i, 7).Value <> "" Then If InStr(.Cells(i, 7).Value, Chr(219) & Chr(237) & Chr(209)) Then Set sh = Sheet3 ElseIf InStr(.Cells(i, 7).Value, Chr(227) & Chr(196) & Chr(222) & Chr(202)) Then Set sh = Sheet4 Else Set sh = Sheet2 End If x = Application.Match(.Cells(i, 1).Value, sh.Columns(1), 0) If Not IsError(x) Then y = Application.Match(.Range("G3").Value2, sh.Rows(3), 0) If Not IsError(y) Then sh.Cells(x, y).Value = "*" cnt = cnt + 1 End If End If End If Next i End With MsgBox "Transferred Successfully = " & cnt, 64 End Sub

السلام عليكم 🙂 لتعم الفائدة ، رجاء قراءة الطريقة السابقة ، والتي يمكن قراءتها من هنا : https://www.officena.net/ib/topic/107637-اجعل-برنامجك-يعمل-على-النواتين-32بت-و-64بت/ ------------------------------------------------------------------------------------------------------------------ اذا عملنا برنامج على الاكسس 32بت ، وفيه مكتبات الوندوز الـ 32بت (لاحظ الرقم 32 في اسم المكتبة: comdlg32.dll) ، ثم شغلنا البرنامج على اكسس 64بت ، فنحصل على هذا الخطأ : . للعمل بهذه الطريقة محتاجين الى: 1. ملف في موقع مايكروسوف (مرفق نسخة Win32API_PtrSafe.zip) ، وفيه طريقة عمل مناداة النواتين : https://www.microsoft.com/en-us/download/details.aspx?id=9970 وعند فك الملف ، سنستعين بالملف Win32API_PtrSafe.TXT ، 2. البرنامج Notepad++ المجاني ، ويمكن انزاله من هنا : https://notepad-plus-plus.org بعد تنصيب البرنامج ++Notepad ، يمكننا فتح الملف Win32API_PtrSafe.TXT به : هذا البرنامج يفهم تنسيق وعمل الكثير من لغات البرمجة ، ومنها VB ، ونستفيد منه حتى في برمجة كود VBE لأنه يفهم تنسيقها: . ------------------------------------------------------------------------------------------------------------------ سنستخدم المرفق في هذ الرابط لنجعله يعمل على النواتين 32بت و 64بت: https://www.officena.net/ib/topic/61106-هدية-من-اليمين-الى-اليسار،-مربع-القائمة-listbox-والشجرة-treeview/ هذه هي مكتبات 32بت الوندوز المستعمله في المرفق: Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long . خطوات العمل: A. ننسخ اسم المكتبة GetWindowLong من برنامج الاكسس ، B. ثم في برنامج ++Notepad ، نبحث عن هذه الكلمة عن طريق Ctrl+F ، C. فنضع الكلمة مكان البحث ، وننقر على المربع: Find All in Current Document . D. نرى هذ النافذة تُفتح في اسفل البرنامج ، اهم شيء في هذه النافذه هو ان نفرق بين كلمة البحث التي نريدها ، ونفرقها عن كلمات البحث المشابهه والتي لا علاقة لنا بها (يجب ملاحظة ان بعض البرامج/الامثلة التي ننزلها من الانترنت ، يكون صاحبها عمل تغيير في اسم المكتبة ، مثلا: بدل GetWindowLong يكون apiGetWindowLong ، فيجب ان نعرف انه نفس الاسم ، ونبحث عن الكلمة الاصل ، كما نلاحظ ان تعديل الاسم يتم من بدايته وليس من نهايته) . E. اذن نرى هنا ان آخر سطرين فيهما طلبنا ، F. ندقق في السطر ، ونبحث عن اي كلمة تنتهي بـ Ptr ، مثل LongPtr ، CLngPtr ، VarPtr ، ObjPtr ، StrPtr ، او الكلمات التالية LongLong ، CLngLng ، فاذا وجدناها ، اذن يجب التصريح لهذه المكتبة في الكود في برنامجنا على سطرين مختلفين ، السطر الاول للنواة 64 بت ، ونأخذه من برنرنامج ++Notepad ، والسطر الثاني للنواة 32 بت ، ونأخذه من برنامجنا الاصل ، هكذا : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long #End If . *** الخطوة الاولى والاهم هي اضافة كلمة PtrSafe بعد كلمة Declare ، للنواة 64بت. *** لاحظ اننا اضفنا كلمة Public في اول السطر للنواتين ، *** وبعد كل خطوة نعملها ، يجب ان نعمل Compile :على الاكسس 32 بت والاكسس 64 بت :حتى نتأكد انه لا توجد اخطاء ونتبع نفس الخطوات اعلاه لبقية المكتبات ، المكتبة التاليه: SetWindowLong ، والنتيجة نفسها مثل المكتبة السابقة ، اذن الكود اصبح #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long #End If . وهكذا مع بقية المكتبات ، فيكون الكود النهائي: #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As Long Public Declare PtrSafe Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare PtrSafe Function InvalidateRect Lib "user32" Alias "InvalidateRect" (ByVal hwnd As LongPtr, lpRect As Long, ByVal bErase As Long) As Long Public Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr Public Declare PtrSafe Function GetFocus Lib "user32" Alias "GetFocus" () As LongPtr Public Declare PtrSafe Function GetWindow Lib "user32" Alias "GetWindow" (ByVal hwnd As LongPtr, ByVal wCmd As Long) As LongPtr #Else '32 bits Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Public Declare Function InvalidateRect Lib "user32" (ByVal hwnd As Long, lpRect As Long, ByVal bErase As Long) As Long Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long Public Declare Function GetFocus Lib "user32" () As Long Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long #End If . الآن لنفترض ان لدينا هذه المكتبة كذلك: Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) . نلاحظ في البحث انه لا توجد لدينا اي من كلمات التي ذكرناها في #F اعلاه . اذن نكتب السطر (من برنامجنا ذو 32 بت) نفسه مرتين ، مرة للنواة 64 بت ، ومرة للنواة 32 بت ، فيصبح الكود (الفرق بين السطرين هي كلمة PtrSafe) : #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او #If VBA7 And Win64 Then '64 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #Else '32 bits Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) #End If او سطر واحد مستقلا Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal lngMilliSeconds As Long) ------------------------------------------------------------------------------------------------------------------ 2021-11-20 : اخوي @عبدالله المجرب نبهني عند استخدام الاكسس 64بت ، يظهور خطأ في مرفق الرابط: https://www.officena.net/ib/topic/64989-هدية-برنامج-تصدير-بيانات-من-جداولاستعلامات-اكسس-الى-اكسل-،-32بت-و-64بت/ لما نعمل Compile للبرنامج على كمبيوتر به اكسس 64بت ، تظهر هذه الرسالة ، واللي معناها مافي توافق في تعريف المتغير (يعني جزء من سطر الكود تم تعريفه بطريقة ، وجزء آخر من سطر الكود تم تعريفه بطريقة لا تتلائم مع المتغير السابق ، وابسط مثال: متغير تم تعريفه كنص ، ثم تعطي قيمته الى متغير آخر تم تعريفه كرقم) : . من الملاحظة ، نرى انه بما اننا نستخدم اكسس 64بت ، فتعريف المكتبة ShellExecute يكون عن طريق (VB7) ، وتعريفها انها LongPtr ، بينما في الكود ، اعطينا قيمة ShellExecute الى المتغير lRet والذي تم تعريفه على انه Long ، لهذا السبب لا يوجد توافق بين المتغيرين ، وعليه نحصل على الخطأ !! هناك حلين للموضوع: إما ان نعمل if VBA7 then# خاص للمتغير lRet لحالتي 32بت و 64بت ، او نحذف تعريف المتغير lRet من الكود ، ونضعه في الاعلى ، مع تعريف المكتبة ShellExecute ، وهذا ما قمت به: . وبعد عمل Comiple مرة اخرى ، نحصل على خطأ مشابه للخطأ اعلاه ، ولكن لمكتبة اخرى : . والحل ، كما عملته للمشكلة السابقة ، فيصبح الكود : . وبعد عمل Compile مرة اخرى ، نجد ان الكود يعمل بدون اخطاء 🙂 ------------------------------------------------------------------------------------------------------------------ 2021-11-23: اخوي @ابا جودى طلب مساعدة في برنامجه ، ليعمل على النواتين: https://www.officena.net/ib/topic/111963-سؤال-بخصوص-التعديل-على-قاعدة-بيانات-لتعمل-على-32-64-bit/ والشيء الجديد فيه والذي لم يتم شرحه سابقا هو: المتغير hIcon (باللون الاصفر) ، تعريفه يعتمد على النواة : . وعندنا هذه الدالة fSetIcon ومعرفها Long ، وفي الدالة ، نعطي نتيجة hIcon الى fSetIcon . المشكلة لما نواة البرنامج تكون 64بت ، فحينها يكون معرف الحقل hIcon هو LongPtr ، بينما الدالة fSetIcon لا يزال معرفها Long ، وهنا نحصل على رسالة خطأ بعدم تطابق معرف الحقلين !! والطريقة التي استعملتها هي: استعمال الدالة مرتين ، مرة بمعرف LongPtr اذا كانت النواة 64بت ، ومرة بمعرف Long اذا لم تكن النواة 64بت : . وعلشان نعرف ان البرنامج تقبل هذا التغيير ، يجب ان نعمل Compile 🙂 جعفر Win32API_PtrSafe (2).zip

وممكن على طريقة الاستاذ جعفر فى النموذج مباشرة بهذا الكود Me.cmb_3Dates.RowSourceType = "Value List" Me.cmb_3Dates.RowSource = Empty Dim Days As Integer For Days = 0 To 2 Me.cmb_3Dates.AddItem Format(DateAdd("d", Days, Date_Start), "dd/mm/yyyy") Next Days وان اردنا استعمالها من خلال روتين عام ممكن Function DayLoop2(ByVal DateStart As Date) As String Dim strSQL As String Dim i As Integer Dim N As Integer N = 2 strSQL = "" For i = 0 To 2 strSQL = strSQL & Format(DateAdd("d", i, DateStart), "dd/mm/yyyy") & "; " Next i DayLoop2 = strSQL End Function

السلام عليكم 🙂 الله ان شاء الله يسهل عليك ، وقوم بالسلامة ان شاء الله 🙂 من الصعب التغلب على سرعة اباجودي 🙂 هذه محاولتي: الاستعلام: الحقل ALL ينادي الوحدة النمطية Count_Chr ، ويرسل معها قيمة الحقل Enter ، . الحقل ALL يستلم عدد مرات وجود الحقول الاخرى ، وبين كل قيمة حقل ، وضعت حرف ابجدي متسلسل ، حتى استطيع من خلال الاستعلام ان: انادي الوحدة النمطية مرة واحدة فقط لكل سجل ، ثم نفكك قيمة الحقل ALL الى بقية الحقول (وعلشان تجربة التفكيك ، قمت بعمل وحدة نمطية اسمها myTest ، وكل حقل اعطيته رقم a1 ثم a2 ... وهكذا) . الآن وعندك هذه القيم في استعلام ، وفي وحدة نمطية ، يمكنك الاستفادة منه بالطريقة التي تريدها 🙂 هذه هي الوحدات النمطية: Public Function Count_chr(str As String) As String 'NA = رقم عربي 'CA1 = حرف عربي 'NE = رقم انجليزي 'CE1 = حروف انجليزي كبيرة 'CE2 = حروف انجليزي صغيرة 'B1 = اشكال و رموز Dim i As Integer Dim NA As Integer, CA1 As Integer, NE As Integer, CE1 As Integer, CE2 As Integer, B1 As Integer Dim Each_Letter As String For i = 1 To Len(str) Each_Letter = Mid(str, i, 1) If Asc(Each_Letter) >= 48 And Asc(Each_Letter) <= 57 Then 'English Numbers NE = NE + 1 ElseIf Asc(Each_Letter) >= 65 And Asc(Each_Letter) <= 90 Then 'English, Capital letters CE1 = CE1 + 1 ElseIf Asc(Each_Letter) >= 97 And Asc(Each_Letter) <= 122 Then 'English, Samall letters CE2 = CE2 + 1 ElseIf (AscW(Each_Letter) >= 1569 And AscW(Each_Letter) <= 1594) Or _ (AscW(Each_Letter) >= 1600 And AscW(Each_Letter) <= 1610) Then 'Arabic Letters CA1 = CA1 + 1 ElseIf AscW(Each_Letter) >= 1632 And AscW(Each_Letter) <= 1641 Then 'Arabic Numbers NA = NA + 1 Else 'Symbols B1 = B1 + 1 End If Next i 'send the result, seperated with letters, 'then parse the result into its 6 components (see Function myTest) Count_chr = NA & "A" & CA1 & "B" & NE & "C" & CE1 & "D" & CE2 & "E" & B1 & "F" 'Debug.Print NA & vbTab & CA1 & vbTab & NE & vbTab & CE1 & vbTab & CE2 & vbTab & B1 & vbTab & str End Function Function myTest() Dim a1 As String, a2 As String, a3 As String, a4 As String, a5 As String, a6 As String, ALL As String ALL = "1A22B333C4444D55555E666666F" a1 = Mid(ALL, 1, InStr(ALL, "A") - 1) a2 = Mid(ALL, InStr(ALL, "A") + 1, InStr(ALL, "B") - (InStr(ALL, "A") + 1)) a3 = Mid(ALL, InStr(ALL, "B") + 1, InStr(ALL, "C") - (InStr(ALL, "B") + 1)) a4 = Mid(ALL, InStr(ALL, "C") + 1, InStr(ALL, "D") - (InStr(ALL, "C") + 1)) a5 = Mid(ALL, InStr(ALL, "D") + 1, InStr(ALL, "E") - (InStr(ALL, "D") + 1)) a6 = Mid(ALL, InStr(ALL, "E") + 1, InStr(ALL, "F") - (InStr(ALL, "E") + 1)) End Function . للحصول على الارقام الصحيحة للامر Asc (للارقام والحروف الانجليزية) و AscW (للارقام والحروف العربية) ، استعنت بالصور الموجودة في هذا الموضوع: https://www.officena.net/ib/topic/104923-قراءة-وتفكيك-بيانات-الحقل-الى-حقول/ ولكني لم افهم قصدك في آخر سجلين: المطوب لايتكرر و يسمح له بتكرر مرة واحدة جعفر 1408.Parse_a_Value.accdb.zip

السلام عليكم اخواني الاعزاء الكود يفي بالغرض ومعه الرسالة الجديدة تفضل Database4.accdb

السلام عليكم استاذ @jjafferr دائما مبدع ربي يحغظك من كل مكروه

شكرا لك استاذي العزبز

الف شكر يا استاذ /محمد صالح جزاك الله خيرا

Change the worksheets names according to your file Sub Test() Const nRows As Long = 25 Const sCells As String = "B5,D5,F5" Dim x, a, t, ws As Worksheet, sh As Worksheet, rng As Range, r As Range, lr As Long, n As Long, i As Long, m As Long, ii As Long Application.ScreenUpdating = False Set ws = ThisWorkbook.Worksheets("Names") Set sh = ThisWorkbook.Worksheets("Lists") sh.Range("B5:B29,D5:D29,F5:F25").ClearContents x = Application.Match(sh.Range("G1").Value, ws.Rows(1), 0) If Not IsError(x) Then lr = ws.Cells(Rows.Count, x).End(xlUp).Row If lr < 4 Then MsgBox "No Data", vbExclamation: Exit Sub Set rng = ws.Range(ws.Cells(4, x), ws.Cells(lr, x)) If rng.Rows.Count > 75 Then MsgBox "No Place For All Data", vbExclamation: Exit Sub rng.Sort Key1:=ws.Cells(4, x), Order1:=xlAscending, Header:=xlNo a = rng.Value n = UBound(Split(sCells, ",")) + 1 For i = 1 To n Set r = sh.Range(Split(sCells, ",")(i - 1)) t = Slice(a, m, m + nRows - 1) m = m + nRows For ii = UBound(t) To LBound(t) Step -1 If IsError(t(ii)) Then t(ii) = Empty Else Exit For Next ii r.Resize(UBound(t)).Value = Application.Transpose(t) Set r = Nothing Next i End If Application.ScreenUpdating = True End Sub Function Slice(ByVal arr, ByVal f, ByVal t) Slice = Application.Index(arr, Evaluate("Transpose(Row(" & f + 1 & ":" & t + 1 & "))")) End Function

تفضل أخي أحمد 3Dates.accdb

احسنتم جميعاً. جزاكم الله الف خير

وعليك السلام ورحمة الله وبركاته الخطوات افتج محرر الاكواد ثم الفورم ثم غير الخاصية كما بالصورة

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

وعليكم السلام ورحمة الله وبركاته جرب هذه المحاولة تقارير.xlsm

شكرا جزيلا

جزاكم الله عني كل خير أحلا زملاء الله يكرمكم ممنون لطفك أخي حياك الله أسعدتني ..

يحب اضافة مكتبةزالاكسس

السلام عليكم تفضل اخي الكريم Me.text1 & vbNewLine & Me.text2 تحياتي

تفضل هذا التعديل Database1.accdb

👍 جزاك الله خيرا وجعله في ميزان حسناتك.

تم الحل أخي الحلبي ولله الحمد بهذه الدالة : Private Function NoEntry() If xtyp = "" Or IsNull(xtyp) Then Me.AllowEdits = False MsgBox "لا يمكن التسجيل الا بعد تعبئة حقل نوع الفاتورة" Me.xtyp.SetFocus Else Me.AllowEdits = True End If End Function تحدد جميع العناصر وتضع في حدث عند التركيز اسم الدالة هكذا بهذه الصورة : =NoEntry() وهذا هو الملف امكانية التسجيل2.accdb

تم ولله الحمد .. هذه هي النتيجة النهائية حسبما فهمت : (الوارد + المرتجع) - الصادر 12 (1).accdb

الآن اتضحت الرؤية 🙂 سأكمل هذه الجزئية لاحقا ..

هذا ما تريده ؟ لم أفهم هذه الجزئية : 12.accdb

ويوجد طريقة ظريفة من بنات افكاري كنت استخدمها في بدايات تعلمي الاكسس انظر المثال امكانية التسجيل3.accdb

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

مشاركة مع اخي موسى تفضل Dim ctl As Control For Each ctl In Me.Controls If xtyp <> "" Then Cancel = False Me.pay = "اجل" Else MsgBox "لا يمكن التسجيل الا بعد تعبئة حقل نوع الفاتورة " Cancel = True Undo Exit Sub End If Next ctl اضفت الكود مرتين في حدث قبل التحديث للنموذج وفي حدث زر الحفظ الاصل ان يتم النقر على زر الحفظ بعد اكتمال البيانات فإما يحفظ او يلغي جميع ما تم تسجيله ويمكنك تعطيل السطر Undo من اجل التسهيل على المستخدم وعدم اعادة كتابة البيانات وانما يكتفي باختيار نوع الفاتورة اما كوني كررت الكود في حدث قبل التحديث للنموذج حتى يتم منع الحفظ فيما لو تم اغلاق النموذج قبل الضغط على الزر امكانية التسجيل2.accdb

وجزاكم مثله اخى الكريم آمين يارب العالمين وإياكم

الموضوع بسيط جدا أخي ... فقط من خصائص القائمة المنسدلة > بيانات > إلتزم بالقائمة > نعم . مرفق لك التعديل : Database4.accdb

السلام عليكم 🙂 هذه طريقتي لتفكيك الحقل الى حقول 🙂 نأخذ المرفق كالمثال من هذا الرابط : . هكذا تبدو السجلات ، بالعين المجردة : . والمطلوب ان نقسم بيانات السجل الواحد الى: الاسم ورقم التسلسل (وخلينا نستخدم السجل الاول كمثال) ، ونريد النتيجة تكون : . هناك طريقتين لفرز هذه البيانات : عن طريق كود ليقرأ الحروف/الارقام/العلامات واحدا واحدا ، ثم بوضع شروط اذا جصلنا على رقم ، فنتوقف ونحفظ الجزء الاول ، ثم نواصل ... ، وهذه العملية مرهقة وتحتاج الى تفاصيل كثيرة ، عن طريق الكود ، ولكن بإستخدام الدالة Split ، ويشترط فيها ان نعرف اين (بعد اي حرف/رقم/علامات) نقسم السطر ، ولنسمية شرط القطع . سنتعامل مع الطريقة الثانية وهي الاسهل 🙂 لمعرفة شرط القطع ، يمكننا ان نتعامل مع الحروف/الارقام/العلامات مباشرة ChrW ، او نتعامل مع ارقام هذه (الحروف/الارقام/العلامات) AscW ، وانا لا استغني عن هذه الصورة المرفقة لعملي ، الحرف Chr ، ومقابله رقمه Dec : . وبالنسبة للحروف العربية ، هذا رابطها : https://sites.psu.edu/symbolcodes/languages/mideast/arabic/arabicchart/ او https://www.ssec.wisc.edu/~tomw/java/unicode.html#x0600 وقد قمت باخذ البيانات من الموقع ورتبتها في صفحة واحد : فمثلا اول حروف اسم ابراهيم : ا = 1575 ، ب = 1576 ، ر = 1585 ، بمعنى AscW(ا) = 1575 , AscW(ب) = 1576 , AscW(ر) = 1585 والعكس يكون ChrW(1575) = ا , ChrW(1576) = ب , ChrW(1585) = ر . للحصول على الاسم ، نريد ان يكون لدينا شرط القطع بعد الاسم وقبل بداية الرقم (اي في المنطقة 1) ، للحصول على التسلسل ، نريد ان يكون لدينا شرط القطع بعد التسلسل وقبل بداية الاسم التالي (اي في المنطقة 2) ، لمعرفة شرط القطع يجب علينا ان نحلل البيانات التي يراها الكمبيوتر ، وذلك بتحويل الحروف/الارقام/العلامات الى AscW ، هذا الكود يقوم بهذه العملية: Public Function Split_Names() Dim rst As DAO.Recordset Dim x() As String Dim i As Long Dim a As String Set rst = CurrentDb.OpenRecordset("Select * From MyTxt_from_pdf") Do Until rst.EOF For i = 1 To Len(rst!Field1) a = Mid(rst!Field1, i, 1) 'الحروف/الارقام/العلامات a = a & "(" & AscW(a) & ") " 'رقمها AscW Debug.Print a Next i Loop rst.Close: Set rst = Nothing End Function ونناديه من نافذة الكود هكذا (يجب ان يكون الكيبور باللغة الانجليزة عند كتابة علامة الاستفهام) : . ونرى ان النتيجة للسجل الاول فقط : . وبعد التدقيق ، نلاحظ ان في نهاية الارقام نرى ان AscW التالية متكررة 8236 ثم 8236 ثم 32 ثم 32 ، وبذلك يمكننا استعمال هذه كشرط القطع بعد الاسم ا(1575) ق(1602) ل(1604) ح(1581) ا(1575) د(1583) م(1605) ح(1581) ي(1610) ا(1575) م(1605) و(1608) د(1583) د(1583) س(1587) ه(1607) ?(8236) ?(8236) ?(8236) -32 -32 -32 -32 -32 -32 . بعد الرقم 3(1635) 2(1634) ?(8236) ?(8236) ?(8236) ?(8236) -32 -32 -32 -32 . وعليه نستعمل هذا الكود ، ونرى نتيجته (للسجل الاول) : Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) Debug.Print x(i) Next i rst.MoveNext Loop ونتيجته ?ابراهيم احمد يحيى احمد? ??3 ?ابتهاج سامح نسيم اقلديوس? ??2 ?ابتسام محمد عبدا حماده? ??1?? . والآن خلينا نفكك الاسم من الرقم : Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) 'Debug.Print x(i) x2 = Split(x(i), ChrW(8236) & ChrW(32) & ChrW(32)) For j = LBound(x2) To UBound(x2) Debug.Print x2(j) Next j Next i rst.MoveNext Loop والنتيجة ?ابراهيم احمد يحيى احمد ??3 ?ابتهاج سامح نسيم اقلديوس ??2 ?ابتسام محمد عبدا حماده ??1?? . ونلاحظ من القائمة اعلاه ، ان علامات الاستفهام ارقامها ?(8235) ?(8234) ?(8236) . الخطوة الاخيرة هي تنظيف النتيجة من علامات الاستفهام هذه عن طريق الامر Replace ، والتخلص من المسافة الزائدة قبل وبعد النتيجة عن طريق الامر Trim ، وبعدها نريد ان نحفظ الاسم في اول حقل ، والرقم في الحقل الثاني: LBound دائما تساوي صفر Do Until rst.EOF x = Split(rst!Field1, ChrW(8236) & ChrW(8236) & ChrW(32) & ChrW(32)) 'Name + ID For i = LBound(x) To UBound(x) 'Debug.Print x(i) x2 = Split(x(i), ChrW(8236) & ChrW(32) & ChrW(32)) For j = LBound(x2) To UBound(x2) 'Debug.Print x2(j) a = Replace(x2(j), ChrW(8234), "") a = Replace(a, ChrW(8235), "") a = Replace(a, ChrW(8236), "") a = Trim(a) 'If j / 2 = Int(j / 2) Then If j = 0 Then 'even Debug.Print "Name: ", a Else 'odd Debug.Print "ID: " & a End If 'Debug.Print a Next j Next i rst.MoveNext Loop والنتيجة Name: ابراهيم احمد يحيى احمد ID: 3 Name: ابتهاج سامح نسيم اقلديوس ID: 2 Name: ابتسام محمد عبدا حماده ID: 1 Name: احمد السيد على محمد ID: 6 Name: ابراهيم كمال ابراهيم محمد ID: 5 Name: ابراهيم سمير عياد عطاا ID: 4 Name: احمد حسن احمد رسلن ID: 9 Name: احمد حجازى على محمد ID: 8 Name: احمد السيد محمد عبدالرحمن ID: 7 . -------------------------------------------------------- وفي سياق هذا الموضوع ، كان عندي مشروع القرآن الكريم ، وحفظه في قاعدة البيانات بعدة طرق: كل صفحة عبارة عن سجل ، وفي جدول آخر ، كل سطر في سجل ، وفي جدول آخر ، كل آية في سجل وقمت بتنزيل القرآن الكريم من مجمع الملك فهد لطباعة المصحف الشريف : https://fonts.qurancomplex.gov.sa/wp02/حفص والمرفق يحتوي على الخط العثماني ، والذي تم عمله في المجمع ، ولذا فهو يحتوي على حروف/ارقام/علامات AscW تختلف عن غيرها من الخطوط ، والطريقة الوحيدة لتفكيك الاسطر كانت بإتباع خطوات شبيهه بالخطوات اعلاه 🙂 جعفر