عبدالله المجرب

جميل جدا جاري التجربة مع جزيل الشكر

السلام عليكم راجع هذا الموضوع https://www.officena.net/ib/topic/84487-عرض-عدد-سجلات-معينه-في-التقرير/

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

الف مبروك الترقية المستحقة

الف مبروك والى الامام دائما مع هذا الصرح العظيم

رائع جدا ومفيد جدا بكتابة الدوال جزاك الله خيرا

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

ان شاء الله اجرب واعلمك النتيجة

هل تقصد ان الدالة بوضعها التالي Private Declare PtrSafe Function apiGetUserName Lib "advapi32.dll" Alias _ "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long ستعمل على النواتين

تم التوصل الى الخلل في هذه الدالة apiGetUserName بالذات هذا السطر nSize As Long لازم يكون nSize As LongPtr طلبي الان هو التعديل في الكود بخيث يعمل على النواتين Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function apiGetUserName Lib "advapi32.dll" Alias _ "GetUserNameA" (ByVal lpBuffer As String, nSize As LongPtr) As Long #Else Private Declare Function apiGetUserName Lib "advapi32.dll" Alias _ "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long #End If Function fOSUserName() As String ' Returns the network login name Dim lngLen As Long, lngx As Long Dim strUserName As String strUserName = String$(254, 0) lngLen = 255 lngx = apiGetUserName(strUserName, lngLen) If (lngx > 0) Then fOSUserName = Left$(strUserName, lngLen - 1) Else fOSUserName = vbNullString End If End Function بالذات في هذه الدالة Function fOSUserName() As String ' Returns the network login name Dim lngLen As Long, lngx As Long Dim strUserName As String strUserName = String$(254, 0) lngLen = 255 lngx = apiGetUserName(strUserName, lngLen) If (lngx > 0) Then fOSUserName = Left$(strUserName, lngLen - 1) Else fOSUserName = vbNullString End If End Function لانها ظهرت اخطاء في هذه الاسطر lngx = apiGetUserName(strUserName, lngLen) وهذا السطر fOSUserName = Left$(strUserName, lngLen - 1)

كل عام وانت بخير استاذ جعفر شكرا للرد لكنه الواقع والمشكلة التي اصادفها هي انه بعد حوالي 5 دقائق يغلق البرنامج وتظهر له نسخة احتياطية ثم يفتح من جديد وهكذا

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

لا زلت اعاني من هذه المشكلة جربت التعديلات المطلوبة على حسب معرفتي (عملت #If VBA7 Then - وكذلك PtrSafe بدلت المتغيرات التي تحتاج الى تغيير مثل Len الى LenB طبعاً حسب الحاجة) لا زالت المشكلة عندي انه اذا شغلت البرنامج على اوفيس 64 بت فانه يعمل لمدة 5 دقائق وبعدها فجأة يغلق ويقوم بعمل نسخة إحتياطية ثم تشغيل البرنامح طبعاً جربته على خمسة كمبيوترات لاني كنت اعتقد المشكلة في الاوفيس ولا والت المشكلة مستمرة طبعاً عملت Compile ولكن لا توجد اخطاء في الكود ويصبخ غير مفعل اي انه لا اخطاء في الأكواد ما الحل من فضلكم

بالانتظار

ما شاء الله استاذ جعفر انت كما عودتنا دائما تفاجأنا بالجديد المبهر سلمت استاذي الفاضل

Up

السلام عليكم اخي السائل هل انحلت المشكلة

جرب المرفق تلوين نطاق.xlsm

السلام عليكم أستاذ جعفر هل ممكن ان ترفق هذه الدالة للعمل على النواتين لأستبدلها بالدالة لدي كوني حاولت ولم انجح هذا هو الكود المستخدم عندي Option Compare Database Option Explicit Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String Flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _ "GetOpenFileNameA" (OFN As OPENFILENAME) As Boolean Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias _ "GetSaveFileNameA" (OFN As OPENFILENAME) As Boolean Private Const ALLFILES = "All files" Function MakeFilterString(ParamArray varFilt() As Variant) As String Dim strFilter As String Dim intRes As Integer Dim intNum As Integer intNum = UBound(varFilt) If (intNum <> -1) Then For intRes = 0 To intNum strFilter = strFilter & varFilt(intRes) & vbNullChar Next If intNum Mod 2 = 0 Then strFilter = strFilter & "*.*" & vbNullChar End If strFilter = strFilter & vbNullChar End If MakeFilterString = strFilter End Function Private Sub InitOFN(OFN As OPENFILENAME) With OFN .hwndOwner = hWndAccessApp .hInstance = 0 .lpstrCustomFilter = vbNullString .nMaxCustFilter = 0 .lpfnHook = 0 .lpTemplateName = 0 .lCustData = 0 .nMaxFile = 511 .lpstrFileTitle = String(512, vbNullChar) .nMaxFileTitle = 511 .lStructSize = Len(OFN) If .lpstrFilter = "" Then .lpstrFilter = MakeFilterString(ALLFILES) End If .lpstrFile = .lpstrFile & String(512 - Len(.lpstrFile), vbNullChar) End With End Sub Function OpenDialog(OFN As OPENFILENAME) As Boolean Dim intRes As Integer InitOFN OFN intRes = GetOpenFileName(OFN) If intRes Then With OFN .lpstrFile = Left$(.lpstrFile, InStr(.lpstrFile, vbNullChar) - 1) End With End If OpenDialog = intRes End Function

سلمت استاذي الغالي تمت التجربة على النواتين وعمل الملف بشكل صحيح ملاحظة في نسخة ٦٤ يعطي لون احمر على جزئية الكود الخاص ب ٣٢ فهل ذلك يسبب مشكلة

هذا ما يظهر عندي عند تحميل المرفق من المشاركة

استاذ جعفر شكرا على عرض هذا الموضوع الهام تواجهنا عند التطبيق عدد من المشكلات في جعل البرنامج يعمل على النواتين وخصوصا اذا كان البرنامج مليء بالاكواد مثال على ذلك استخدمت ملفك (تصدير الجداول والاستعلامات الى اكسل ) في الموضوع الخاص بك لا استطيع تحميل المرفق كونك ذاكر انه يعمل على النواتين ------------------------------------------------------------------------------------------------------- فيه فورم للتصدير الى الاكسل بعدد من الخيارات ((طبعا انا استخدمت ملف من مشاركة ابو الا استخدمت الطريقة المذكورة في المشاركة في التعديل لكن لم يعمل الكود الخاص بتحديد مسار ملف الاكسل ولكن بحثت ووجدت دالة تقوم بالعمل المطلوب ولكن ٦٤ بت اتمنى ان تجرب على ذلك الملف وتطلعنا على التغيرات الني نحتاجها ليعمل على النواتين طبعا ان

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

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

للرفع