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

وعليكم السلام 🙂 رجاء النظر الى جدول 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 جعفر

السلام عليكم صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . Msgbox With ComboBox.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

السلام عليكم 🙂 لتعم الفائدة ، رجاء قراءة الطريقة السابقة ، والتي يمكن قراءتها من هنا : 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

تفضل هذا التعديل بكود واحد فقط ... - لن يستطيع المستخدم الإدخال الا بعد اختيار نوع الفاتورة - جميع الحقول متاحة لكن لن يستطيع المستخدم ادخال البيانات الا بعد اختيار نوع الفاتورة امكانية التسجيل.accdb

السلام عليكم ورحمة الله وبركاته . كما وعدتكم الاصدارالثاني لبرنامج صانع القوائم فى البداية هذا العمل مجاني لوجة الله ولكن اتمنى مزيد من التفاعل لارتقاء العمل وحس المساعدة بيننا فالصدار الاول تخطي 550 مشاهدة و 7 ردود فقط فأذا تخطي هذا المشروع 100 رد يكون المشروع الثاني مفاجأه وهو ارسال رسائل SMS مجاناً معتمداً على الباقة المتوفرة من شركة جوالك دون تكلفة اضافية او وسيط والان فيديو شرح البرنامج : لتحميل البرنامج : https://www.mediafire.com/file/z17cd3rpjtikyxi/ARM.exe مساعدة من الخبراء ان أمكن هل من الممكن تشغيل سكريبتك بالاكسس دون الحجة لتفعيله يدوياً كما موضح بأخر الفيديو مع العلم باننى قمت بمحاولات لا تحصي ولكن لا يعمل بالجودة المطلوبة . ثانياً تشغيل زر تصدير الدوال حتى يقوم الصانع بتصدير الدوال والجدول المخصص للشريط دون الحاجة لاستردادهم يدوياً . ولكم جزيل الشكر .

أولا : طهور إن شاء الله، أوصيكم بالصبر والثبات والإكثار من ذكر الله، أعظم الله أجركم، وضاعف مثوبتكم، شفاكم الله وعافاكم اللهم إني أسألك بأسمائك الحسنى وبصفاتك العلا وبرحمتك التي وسعت كلّ شيء، أن تمنّ علي أخونا عبد الله وعلى كل مريض بالشفاء العاجل، وألّا تدع فينا جرحًا إلّا داويته، ولا ألمًا إلا سكنته، ولا مرضًا إلا شفيته، وألبسنا ثوب الصحة والعافية عاجلًا غير آجل، وشافِنا وعافِنا واعف عنا، واشملنا بعطفك ومغفرتك، وتولّنا برحمتك يا أرحم الراحمين إلهي أذهب البأس ربّ النّاس، اشف وأنت الشّافي، لا شفاء إلا شفاؤك، شفاءً لا يغادر سقمًا، أذهب البأس ربّ النّاس، بيدك الشّفاء، لا كاشف له إلّا أنت يا رب العالمين ربنا الله الذي في السماء، تقدّس اسمك، أمرك في السماء والأرض، كما رحمتك في السماء، اجعل رحمتك في الأرض، اغفر لنا خطايانا، أنت رب الطيبين، أنزل رحمة من رحمتك، وشفاءً من شفائك على على كل مريض من أي وجع فيبرأ اللهم يا مُفرّج الكرب يا مُجيب دعوة المُضطرين، اللهم ألبس كل مريض ثوب الصحة والعافية عاجلًا غير آجل يا أرحم الراحمين، اللهم اشفى كل مريض ، اللهم اشفى كل مريض، اللهم اشفى كل مريض، اللهم آمين ----------------------- ثانيا : تتمحور فكرتي المتواضعة في هذه الاكواد والتي تكتب في موديول ويتم استدعائها حسب الحاجة انظر التطبيق داخل الاستعلام 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

Private Sub Worksheet_Change(ByVal Target As Range) Dim sCompany As String, m As Long If Target.Cells.CountLarge > 1 Then Exit Sub If Target.Address = "$D$5" Then sCompany = Target.Value If Evaluate("ISREF('" & sCompany & "'!A1)") Then With Sheets(sCompany) m = .Cells(Rows.Count, "D").End(xlUp).Row + 1 .Range("D" & m).Resize(1, 4).Value = Application.Transpose(Range("M7:M10").Value) MsgBox "Data Copied To [ " & .Name & " ] Worksheet", 64 End With End If End If End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transf() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, Tmp As Variant Dim LR As Long, LS As Long, i As Long, j As Long, p As Long Set Sh = Sheets("BASS") LR = Sh.Range("B" & Rows.Count).End(3).Row Arr = Sh.Range("A5:E" & LR).Value ReDim Tmp(1 To UBound(Arr, 1), 1 To UBound(Arr, 2)) For Each ws In Worksheets LS = ws.Range("B" & Rows.Count).End(3).Row For i = 1 To UBound(Arr, 1) If Arr(i, 5) = ws.Name Then p = p + 1 For j = 1 To 5 Tmp(p, j) = Arr(i, j) Next End If Next If p > 0 Then ws.Range("A" & LS).Resize(p, UBound(Tmp, 2)).Value = Tmp p = 0 Next ws End Sub

طيب بعد اذن اخى الحبيب باش مهندس كريم وبناء على طلبه فى تقديم المساعدة ان امكن المرفق الاتى والخاص بكملة المرور هناك عدد 2 زر امر الاول OK : المفروض ان كانت كلمة المرور صحيحة يتم تمريرها من خلال صندوق الرسائل الى النموذج الثانى No : المفروض ان كانت كلمة المرور صحيحة او خطأ لا يتم تمريرها ولتنفيذ ذلك من خلال الكلاس لابد من اضافة sub routine الى النموذج مع بعض التعديلات على الكود اترككم مع المرفق .. اتمنى لكم تجربة ممتعة 08- Msgbox With Input Password (2).accdb

هذه يسهل ما تشاء من شروط .... استخدم هذا Dim myCriteria As String myCriteria = "[نوع المستند] = '" & Me.نوع_المستند & "'" myCriteria = myCriteria & " AND " myCriteria = myCriteria & "[كود الدعوي] =" & Me.كود_الدعوي Me.n = DCount("[كود الحركة]", "harka", myCriteria)

وعليكم السلام يبدو انه تنتظرنا درر من تلك السلسة اول الغيث قطرة.. وهذه بدايات اكتشافاتي تجدها على زر الامر خروج وانا في انتظار باقي السلسة بشغف يا باش مهندس كريم Msgbox With ComboBox.zip

السلام عليكم ورحمة الله فى هذا الجزء من المعادلة *(التحميل!$G$2:$G$1496=A10)* استبدل حرف G بحرف C لاتنسى الضغط على CTRL+ SHIFT+ENTER حت تعمل معك المعادلة بشكل جيد

السلام عليكم شباب 🙂 طريقتي: . وفي حدث "بعد تحديث" 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) تفي بالغرض بالتوفيق

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

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

ا جازانا و اياكم جرب و قل تعديلك

حياك الله 🙂 من وين جابوا سالفة الدكتور هاي 🤔 ليكون انا صدق دكتور وانا ما ادري 🤭

وعليكم السلام تعتمد طريقتى على الاكواد داخل موديول عام والذى يتم استدعاؤها من خلال وضع الكود الاتى فى حدث عند تحميل نموذج Call Xicon والكود داخل الموديول هو مع مراعاة تغيير البيانات الاتية فى رأس الموديول اسم التطبيق AppName اسم الايقونة بدون الامتداد icoName وتم عمل الكود على ان الايقونة فى نفس مسار القاعدة فى حالة تغيير مكان الايقونة لابد من تغير المسار فى الروتين AppIcon() Const AppName = "Alia Yusr El Din" Const icoName = "4" Public Function AppIcon() AppIcon = CurrentProject.Path & "\" & icoName & ".ico" End Function Public Function AccessIcon() AccessIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Debug.Print AccessIcon End Function Function AddAppProperty(strName As String, _ varType As Variant, varValue As Variant) As Integer Dim dbs As Object, prp As Variant Const conPropNotFoundError = 3270 Set dbs = CurrentDb On Error GoTo AddProp_Err dbs.Properties(strName) = varValue AddAppProperty = True AddProp_Bye: Exit Function AddProp_Err: If Err = conPropNotFoundError Then Set prp = dbs.CreateProperty(strName, varType, varValue) dbs.Properties.Append prp Resume Else AddAppProperty = False Resume AddProp_Bye End If End Function Function Xicon() On Error GoTo ErrHandler Dim dbs As Object Set dbs = CurrentDb() Dim intX As Integer Const DB_Text As Long = 10 ' AppTitle intX = AddAppProperty("AppTitle", DB_Text, AppName) ' AppIcon Dim Chk Dim MyIcon As String Set Chk = CreateObject("Scripting.FileSystemObject") If Chk.FileExists(AppIcon()) = False Then MyIcon = (SysCmd(acSysCmdAccessDir) & "MSACCESS.EXE") Else MyIcon = AppIcon() End If intX = AddAppProperty("AppIcon", DB_Text, MyIcon) dbs.Properties("UseAppIconForFrmRpt") = 1 Application.RefreshTitleBar exitProc: Exit Function ErrHandler: If Err = 3270 Then Resume Next Else MsgBox Err & Err.Description Resume exitProc End If End Function testIcon.zip

السلام عليكم هذا البرنامج عملته في زمن مضى برنامج لتسجيل الأسر : الأجداد والآباء والأبناء والأحفاد بكل يسر وسهولة باستخدام جداول عدة مترابطة و يتم عرضهها في تقرير خاص ايضا استخدمت شجرة الحسابات كمستكشف لعرض الأصول والفروع بطريقة شيقة ولمسات خاصة وبالألوان ولمسات اخرى تجدونها عند تجربة البرنامج ارجوا ممن يستفيد منه الا ينساني من دعوة في ظهر الغيب . Osrah.rar

So simple. Do it yourself Create a variable and name it for example counter Then inside the loop and before the line that populates the value "Total" increase the variable by one like that counter = counter + 1 And finally put the ampersand symbol after the word "Total" and the variable name which is counter. That's all

فين المرفق اللى هنطبق عليه الحل ؟ عامة يمكنك استخدام For كالمثال التالى جرب وان مشتغلش ارفق النموذج. ملاحظة : يفضل عدم استخدام اللغة العربية فى الاكواد لأنها بيصعب التعامل معها ولذلك استبدلت اسماء الحقول العربية فى الكود بأسماء افتراضية Cnt بدلا من نص 6 و Result للنتيجة مستجد او راسب . بالتوفيق On Error Resume Next DoCmd.GoToRecord , , acFirst For i = 0 To Me.Form.Recordset.RecordCount - 1 If Me.Cnt = 0 then Me.Result = 1 Else Me.Result = 10 end if DoCmd.GoToRecord , , acNext Next هناك ايضا طريقة ابسط عن طريق الاستعلامات هيكون فيه استعلام لعد مواد الرسوب لكل طالب و فيه حقل فيه دالة IIF لبيان الحالة طبقا للعدد .. وفى النموذج الخاص بيك يتم استدعاء حالة الطالب بناء على الكود او ID مثلا هناك حلول كثيرة فى هذا الشأن .

السلام عليكم استخدم استعلام تحديث Query1 UPDATE TBLSub SET TBLSub.booksshkr = Nz([booksshkr])+1 WHERE (((TBLSub.booksshkr)<3)); Prog202.rar تحياتي

3- عرض الرسالة مع مربع نص بقيمة افتراضية صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 03- Msgbox With Input Box With a default Value - Copy.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 4- عرض الرسالة مع مربع نص بقيمة افتراضية سطري مع الازرار صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 04- Msgbox With Input Box With a default Value Line with buttons.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 5- عرض الرسالة مع مربع نص بقيمة افتراضية أسفل الازرار صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 05- Msgbox With Input Box With a default Value In Footer.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 6- عرض الرسالة مع مربع نص بقيمة افتراضية مع تغير عرض المربع صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 06- Msgbox With Input Box Resize Width.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 7- عرض الرسالة مع مربع نص مع ملحوظة داخل مربع النص صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 07- Msgbox With Input Box Cue.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني . 8- عرض الرسالة مع مربع نص لادخال الرقم السري مع ملحوظة صورة لفهم المحتوى وقاعدة بيانات بها مثال لطريقة العمل . 08- Msgbox With Input Password.accdb ولا تنسي ان تسترد الكلاس الموجود لبرنامجك لانه سوف يبني عليه باقي السلسلة . بالتوفيق . كريم الحسيني .

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

ما شاء الله ، واقعا هذه اشياء جديدة علينا ، وفي انتظارها على احر من الجمر 🙂 الاكسس مليء بالمفاجآت ، ومفاجآته لا تنتهي 🙂 جعفر

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

شكرا لك استاذ جعفر طبعاً سوف ارسل ملاحظتي وأيضاً سوف اقول علي ملاحظة هنا اتمني أن نتعامل مع الاسكنر مباشرة من الاكسس ٠٠ السحب مباشرة من الفيدر وتحويل الي ملف بي دي اف ٠٠ تحياتي 🌹

يمكنك وضع جميع ملفات الاكسل المطلوب تحويلها في مجلد باسم xls بنفس مسار الملف الذي به هذا الكود وإنشاء مجلد باسم csv بنفس مسار الملف الذي به هذا الكود واستدعاء الاجراء Mas_Xls2Csv Sub Mas_Xls2Csv() Dim xObjWB As Workbook Dim xStrEFPath As String Dim xStrEFFile As String Dim xStrSPath As String Dim xStrCSVFName As String Application.ScreenUpdating = False Application.EnableEvents = False Application.Calculation = xlCalculationManual xStrEFPath = ThisWorkbook.Path & "\xls\" xStrSPath = ThisWorkbook.Path & "\csv\" xStrEFFile = Dir(xStrEFPath & "*.xls*") Do While xStrEFFile <> "" Set xObjWB = Workbooks.Open(Filename:=xStrEFPath & xStrEFFile) xStrCSVFName = xStrSPath & Left(xStrEFFile, InStr(1, xStrEFFile, ".") - 1) & ".csv" xObjWB.SaveAs Filename:=xStrCSVFName, FileFormat:=xlCSVUTF8 xObjWB.Close savechanges:=False xStrEFFile = Dir Loop Application.Calculation = xlCalculationAutomatic Application.EnableEvents = True Application.ScreenUpdating = True MsgBox "Done by mr-mas.com" End Sub بالتوفيق

تفضل اخي الكريم Me.TotalTime11 = Int(DateDiff("h", Me.TimeIn1, Me.TimeOut1)) Me.TotalTime12 = Int(DateDiff("h", Me.TimeIn2, Me.TimeOut2)) Me.TotalTime13 = Int(DateDiff("h", Me.TimeIn3, Me.TimeOut3)) Me.TotalTime14 = Int(DateDiff("h", Me.TimeIn4, Me.TimeOut4)) Me.TotalTime15 = Int(DateDiff("h", Me.TimeIn5, Me.TimeOut5)) Me.TotalTimeALL = Me.TotalTime11 + Me.TotalTime12 + Me.TotalTime13 + Me.TotalTime14 + Me.TotalTime15 & " ساعة" &&ساعات.rar تحياتي

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

لا تحتاج الى عمل وحدة نمطية اكثر من مرة ولا تحتاج الى تكرار الاكواد بدون داعى فقط لابد من إزالة Exit Function وموقعها في الكود بين الروتين الذى يتم تطبيقه على النماذج والروتين الذى يتم تطبيقه على التقارير ولم يتم تغيير الخط فقط في التقارير بسبب الخروج من الروتين بسبب هذا السطر والأفضل من استخدام On Error Resume Next استخدام كود تصيد الأخطاء ErrorHandler لتتمكن من الوقوف على سبب ومكان وتوصيف ورقم الخطأ وتمت التعديلات كالاتي إزالة Exit Function تغيير اسم الروتين العام حتى يتناسب مع الوظيفة التي يقوم بها ليسهل مستقبلا لأى مطور التعامل بسهولة في قاعدة البيانات إضافة كود تصيد الأخطاء ErrorHandler للوقوف على سبب ومكان وتوصيف ورقم الأخطاء حتى يسهل تفاديها إن وجدت أخطاء إضاقة متغير ثابت في أول الكود ليتم وضع اسم الخط فقط مرة واحدة في الروتين من باب المرونة والتسهيل على المطور ملاحظة هامة جدا جدا لابد من تغير اسم الخط الذى قمت انا باستخدامه في الوحدة النمطية وهو Calibri (Detail) باسم الخط الذى تريد أنت التغيير إليه وقمت بوضع هذا التلميح للتذكير في الوحدة النمطية عند المتغير الثابت الذى يحمل اسم الخط <<---------< Font name must be changed here between the quotation marks يتم استدعاء الكود من خلالChange Font.mdb Call ApplyDefaultFont وأخيرا الروتين والذى يتم وضعه داخل وحدة نمطية Function ApplyDefaultFont() On Error GoTo ErrorHandler Const strFontName = "Calibri (Detail)" ' <<---------< Font name must be changed here between the quotation marks Dim frm As AccessObject Dim rpt As AccessObject Dim dbs As Object Dim frm1 As Access.Form Dim rpt1 As Access.Report Dim ctl As Access.Control Set dbs = Application.CurrentProject ' Apply Default Font for All Forms For Each frm In dbs.AllForms DoCmd.OpenForm frm.Name, acDesign Set frm1 = Forms(frm.Name) For Each ctl In frm1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print frm.Name & " > " & ctl.ControlType & " > " & ctl.Name If frm1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acForm, frm.Name, acSaveYes Next frm ' Apply Default Font for All Reports For Each rpt In dbs.AllReports DoCmd.OpenReport rpt.Name, acDesign Set rpt1 = Reports(rpt.Name) For Each ctl In rpt1.Controls If ctl.ControlType = acComboBox Or _ ctl.ControlType = acCommandButton Or _ ctl.ControlType = acLabel Or _ ctl.ControlType = acListBox Or _ ctl.ControlType = acOptionButton Or _ ctl.ControlType = acTextBox Then ctl.FontName = strFontName 'Debug.Print rpt.Name & " > " & ctl.ControlType & " > " & ctl.Name If rpt1.DefaultView = 2 Then frm1.DatasheetFontName = strFontName End If End If Next ctl DoCmd.Close acReport, rpt.Name, acSaveYes Next rpt Set frm = Nothing Set rpt = Nothing Set dbs = Nothing Set frm1 = Nothing Set rpt1 = Nothing Set ctl = Nothing Exit Function ExitHandler: Exit Function ErrorHandler: MsgBox "Error Number : " & Err.Number & vbNewLine & "Error Description : " & Err.Description End Function وهذا مرفق التطبيق لتعم الفائدة ويكون مرجعا سهلا ان شاء الله Change Font.mdb

بارك الله في استاذ عبدالله على هذه المحاولة

تفضل ..... moh.rar وهذا الفلدر به القاعدة المنشأ فيها الجداول .... ضع الفولدر في الدرايف D New folder (2).rar

تفضل اخى الكريم الملف بعد وضع الكود به كشوفات الطلبة للعام 2021-2022.xlsm

السلام عليكم 🙂 شفت بعض الاوقات لما تحس ان مخك ما يشتغل ، هذا انا الحين 😁 بما انك حددت وين المشكلة في برنامجك ، فانا عملت لك هذه المساعدة : وحدة نمطية اسمها mod_Global_Variables ، وفيها نحتفظ بنوع المستخدم في الحقل ppos ، ويمكن للبرنامج قراءته من اي مكان في البرنامج ، وعلى اساس قيمة ppos ، فقد وضعتها في حدث "الحالي" للنموذج ، فالرجاء وضعها بالطريقة الصحيحة (قلت لك مخي ما يشتغل 🙂) . جعفر 1417.moh.accdb.zip

السلام عليكم ورحمة الله استخدم الكود التالى بدلا من الكود السابق Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant, LR As Long Set ws = Sheets("vi") Set Sh = Sheets("DATA") LR = Sh.Range("B" & Rows.Count).End(3).Row + 1 Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B" & LR).Resize(, 3) = Arr End Sub

السلام عليكم ورحمة الله استخدم هذا الكود Sub Transfer() Dim ws As Worksheet, Sh As Worksheet Dim Arr As Variant Set ws = Sheets("vi") Set Sh = Sheets("DATA") Arr = Array(ws.Range("B3"), ws.Range("C7"), ws.Range("A6")) Sh.Range("B4").Resize(, 3) = Arr End Sub

وممكن على طريقة الاستاذ جعفر فى النموذج مباشرة بهذا الكود 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

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

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

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

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

السلام عليكم اعتقد مشكلتك باسماء الجداول ----لانها تتغير عند رفعها عل الsql server ---- لان قاعدة الاكسس تبق كما هي وتتغير اسماء الجداول فقط ---- لذلك عليك تغير اسماء الجداول في الاستعلامات وكذلك في الاكواد الموجوده في النماذج ممكن تستفاد من الرابط التالي

تم الحل أخي الحلبي ولله الحمد بهذه الدالة : 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

عند نسخ الصفحة يجب ان تنقل إلى النهاية إليك الملف AA.xlsm

تفضل هذا التعديل بدون التقييد بتصميم الأكسل و على نفس التصميم تصدير اكسل.zip

كود اختيار تعليقات من جدول معد مسبقا كود تعليقات من قائمة.rar