jjafferr

السلام عليكم 🙂 نعم يصير بالطريقة اللي تريدها ، ولكنها ليست الطريق الصحيحة لقواعد البيانات ، الطريقة الصحيحة هي عمل جدول لبيانات مربعي السرد ، هكذا ، بحيث تقدر تضيف وتغير البيانات بكل بساطة ، ويمكنك عمل نموذج لهذا الجدول لتسهيل ادخال البيانات وتغييرها : وعليه تكون النتيجة بعد الاختيار : . جعفر 1334.Database1 (3).accdb.zip

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

وين؟ . جعفر

احي الفاضل ، هذا المنتدى لتبادل الخبرات واستفادة الجميع ، اما اذا اردت ان يتم التواصل مباشرة بينك وبين المبرمج ، فرجاء وضع طلبك هنا: https://www.officena.net/ib/forum/157-إعلانات-شخصية-بأجر-للاعضاء/ جعفر

الحمدلله 🙂 والمفروض يكون اسرع من الكود السابق 🙂 ورجاء تجربته في الموضوع الآخر كذلك ، وضع الجواب هناك 🙂 حعفر

تفضل

اعطنا مثال

السلام عليكم 🙂 هذه آخر محاولة لي ، وقد قمت بتغيير العمل: Option Compare Database Option Explicit Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer 'unify endline characters, so that we can use Split function myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, Chr(10) & Chr(13), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) ' myValue = Replace(myValue, " ", " ") ' myValue = Replace(myValue, " ", " ") ' myValue = Replace(myValue, " ", " ") 'convert the one paragraph into different phrases separated by vbcrlf x = Split(myValue, vbCrLf) 'Loop through the phrases For j = 0 To UBound(x) 'remove the extra spaces on the Left x(j) = Trim(x(j)) If Len(x(j)) > 1 And j <> UBound(x) Then 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it 'only if the right character is a spcae and its not the last phrase x(j) = Trim(Mid(x(j), 1, Len(x(j)) - 1)) & vbCrLf End If 'Remove the Empty lines (one character length), and accumelate the rest of the lines If Len(x(j)) < 2 Then Else Remove_Extras = Remove_Extras & x(j) End If Next j 'this is an Access conversion error, so lets uninfy it like all endlines Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'replace the VT characters with vbcrlf 'if the last character is vbcrlf, remove it, so that we dont have extra empty line at the end If Right(Remove_Extras, 1) = vbCrLf Or Right(Remove_Extras, 1) = Chr(10) Or Right(Remove_Extras, 1) = Chr(13) Then Remove_Extras = Mid(Remove_Extras, 1, Len(Remove_Extras) - 2) End If End Function جعفر أسطر3.zip

جرب هذا الكود : Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer Dim mySpace As String For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) 'remove the extra spaces on: x(j) = LTrim(x(j)) 'remove the left spaces If Len(x(j)) < 2 Then Else 'remove the extra spaces on: x(j) = LTrim(x(j)) 'remove the left spaces 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it 'only if the right character is a spcae mySpace = Mid(x(j), 1, Len(x(j)) - 1) If Right(mySpace, 1) = " " Then x(j) = Trim(mySpace) & vbCrLf End If Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function جعفر

شوف المرفق. ما فهمت !! خليني اشوف اللي عملته 1311.4.Data.accdb.zip

اما تجربتي فتقول ، قبل: . وبعد: . جرب المرفق 🙂 جعفر أسطر2.zip

تفضل يا سيدي 🙂 . جعفر 1311.4.Data.accdb.zip

وتعديل آخر: Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer Dim mySpace As String For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) If Len(x(j)) < 2 Then Else 'remove the extra spaces on: x(j) = LTrim(x(j)) 'remove the left spaces 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it 'only if the right character is a spcae mySpace = Mid(x(j), 1, Len(x(j)) - 1) If Right(mySpace, 1) = " " Then x(j) = Trim(mySpace) & vbCrLf End If Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function . ولكن المطلوب ليس تحويل المسافات الى مسافة واحدة ، وانما المطلوب حذف هذه المسافات/المسافة 🙂 قاعدة البيانات المرفقة فيها مثال ، فجرب كودك عليها 🙂 جعفر

يعني قصدك هكذا:

اخوي هاوي 🙂 بعض الاحيان ، وبمجرد رؤية المطلوب ، تقفز الحلول الى الخاطر ، ولكن وبعد التجربة ، نرى ان بعض هذه الحلول لا تعطي النتائج الصحيحة ، والنقطة اللي نتناقش حولها هي مثل هذا الاحتمال: مسافة مسافة 1234 مسافة مسافة vbcrlf الدالة Trim واخواتها ممكن ان يحذفو المسافات الفارغة قبل وبعد اي قيمة ، ولكن في حال المثال اعلاه ، فإن الدالة ستقوم بحذف المسافات في مقدمة الرقم ، سواء Trim او LTrim، ولكن وبسبب وجود اشارة السطر التالي vbcrlf ، فالمسافات التي قبلها لن تحذفها الدالة ، فعليه ، يكون نتيجة اجراء الدالة: 1234 مسافة مسافة vbcrlf لهذا السبب ، فالموضوع يتطلب اجراء اضافي 🙂 جعفر

نعم ،مكان الكود كان في السطر الخطأ !! اما الآن ، وبعد التجربة ، فهو شغال تمام ان شاء الله 🙂 هكذا اصبحت الدالة: Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines 'unify the end of the line characters myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) If Len(x(j)) < 2 Then Else 'remove the extra spaces on: 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it x(j) = Trim(Mid(x(j), 1, Len(x(j)) - 1)) & vbCrLf Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function جعفر أسطر2.zip

السلام عليكم 🙂 هل افهم انك تحتاج التقارير بهذه الطريقة: . 1. . 2. . جعفر

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

الحمد لله اننا لازلنا محافظين على قوانين المنتدى ، بقية بس شعرة واحدة وننزلق الى المحظور 😁 جعفر

كلامك يخص كلمة سر البرنامج ، اما بالنسبة الى كلمة سر VBA ، فلا ينطبق عليها هذا 😁 جعفر

توجد طرق وبرامج ، ولكن قصدك ان قوانين المنتدى لا تسمح برفع مثل هذه الامور ، للحماية الفكرية لصاحب الموضوع 🙂 وقصدك انه لا يوجد شي لتخطي أو الغاء باسورد VBA أبداً ، اذا كان البرنامج بصيغة mde او accde 🙂 جعفر

لا اعلم اذا هذا له علاقة بالموضوع ، ولا استبعد ذلك !! ولا تحذف اي ملف الآن ، هناك خطأ في التعليمات اعلاه ، فلا نحتاج الى نسخه الى مجلدات النظام (وتم تحديث التعليمات اعلاه) هكذا : C:\Windows\system32>regsvr32 "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll" او حسب نظامك C:\Windows\system32>regsvr32 "C:\Program Files (x86)\Common Files\Microsoft Shared\DAO\dao360.dll" . جعفر

اخي nssj لا انصحك بالخلط بين الاكواد ، فمنها سيكون متكرر ، فيعمل بطئ في برنامجك ، وتستطيع ان تضعه هنا ، ليقوم الاعضاء بتصحيحه 🙂 حيا الله اخوي الهاوي 🙂 نعم اعرف هذا ، ولكن لم تنجح التجربه به !! تفضل هذا المرفق ، ولاحظ المسافات حسب ما اوضحتها ، جرب واخبرنا 🙂 . واتضح ان كودي يحتاج الى تعديل ليحل هذه الاشكاليه كذلك : 'remove the extra spaces on: 'separate the text from vbcrlf, Remove the extra spaces, then attache vbcrlf to it x(j) = Trim(Mid(x(j), 1, Len(x(j)) - 1)) & vbCrLf . جعفر أسطر2.zip

الظاهر انك استخدمت صيغة mdb ، ووجدت هذا الجواب في احد المواقع: 1. ابحث في جهازك عن ملفات doa3*.dll ، واحذفها جميعا ، ولا تحذف ملف dao360.dll الموجود في : لنظام 32بت C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll لنظام 64بت C:\Program Files (x86)\Common Files\Microsoft Shared\DAO\dao360.dll 2. ثم سجل الملف dao360.dll كمسؤول في برنامج cmd : لنظام 32بت C:\Windows\system32>regsvr32 "C:\Program Files\Common Files\Microsoft Shared\DAO\dao360.dll" لنظام 64بت C:\Windows\system32>regsvr32 "C:\Program Files (x86)\Common Files\Microsoft Shared\DAO\dao360.dll" لتحصل على هذه الرسالة المؤكدة بنجاح الامر: 3. واعد تشغيل الكمبيوتر ، ثم جرب البرنامج مرة اخرى 🙂 جعفر

تفضل: تم اضافة : 'remove the extra spaces on: x(j) = LTrim(x(j)) 'the Left x(j) = RTrim(x(j)) 'the Right Function Remove_Extras(myValue As String) As String Dim x() As String Dim j As Integer For j = 1 To 999 'remove all the extra characters at the end of the line If Right(myValue, 1) = Chr(7) Or _ Right(myValue, 1) = vbCr Or _ Right(myValue, 1) = vbLf Or _ Right(myValue, 1) = vbCrLf Then myValue = Mid(myValue, 1, Len(myValue) - 1) Else Exit For End If Next j 'now remove the empty lines myValue = Replace(myValue, Chr(7), vbCrLf) myValue = Replace(myValue, vbCr, vbCrLf) myValue = Replace(myValue, vbLf, vbCrLf) x = Split(myValue, vbCrLf) For j = 0 To UBound(x) 'remove the extra spaces on: x(j) = LTrim(x(j)) 'the Left x(j) = RTrim(x(j)) 'the Right If Len(x(j)) < 2 Then Else Remove_Extras = Remove_Extras & x(j) End If Next j Remove_Extras = Replace(Remove_Extras, Chr(11), vbCrLf) 'remove all VT characters End Function جعفر