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

جميل جدا

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

السلام عليكم

راجع هذا الموضوع

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

السلام عليكم

اخي صالح جرب هذا الحل 

بالنسبة للمجموع لم اجد الوقت للتعديل فقم بذلك اذا كان هذا المطلوب

الشهادات.zip

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

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

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

جزاك الله خيرا

في ٤‏/٥‏/٢٠٢٢ at 20:52, عبدالله المجرب said:

هل تقصد ان الدالة بوضعها التالي 

Private Declare PtrSafe Function apiGetUserName Lib "advapi32.dll" Alias _
    "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

ستعمل على النواتين

 

جربت هذا الحل والى الان الامور تمام 

سلمت استاذ جعفر 

شكرا لك وكل عام والجميع بخير

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

هل تقصد ان الدالة بوضعها التالي 

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  ولكن لا توجد اخطاء في الكود ويصبخ غير مفعل اي انه لا اخطاء في الأكواد

ما الحل من فضلكم 

في ٢٧‏/١‏/٢٠٢٢ at 00:52, king5star said:

ابشروا تبقى قليل للدورة لعمل تطبيق مربوط بالاكسس وعرض التقارير والمعلومات الاساسية به

بالانتظار

ما شاء الله 

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

سلمت استاذي الفاضل

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

سلمت استاذي الغالي 

تمت التجربة على النواتين وعمل الملف بشكل صحيح 

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

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

استاذ جعفر شكرا على عرض هذا الموضوع الهام 

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

مثال على ذلك 

استخدمت ملفك (تصدير الجداول والاستعلامات الى اكسل )

في الموضوع الخاص بك  لا استطيع تحميل المرفق كونك ذاكر انه يعمل على النواتين

-------------------------------------------------------------------------------------------------------

فيه فورم للتصدير الى الاكسل بعدد من الخيارات ((طبعا انا استخدمت ملف من مشاركة ابو الا 

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

ولكن بحثت ووجدت دالة تقوم بالعمل المطلوب ولكن ٦٤ بت 

اتمنى ان تجرب على ذلك الملف وتطلعنا على التغيرات الني نحتاجها ليعمل على النواتين

طبعا ان

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

سلمت استاذ جعفر 

أبدعت بصراحة 

وفقك الله وجعا ما تقدمه في ميزان حسناتك

للرفع