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

جرب هذا التعديل البسيط ra1 (2).accdb

للرفع

تم تعديل اسلوب الدالة من المديول على النحو التالي :- Function CalculateFridaysSaturdays(monthName As String, Optional baseYear As Integer = 0, Optional dayType As String = "Both") As Variant Dim monthNumber As Integer Dim startDate As Date, endDate As Date Dim fridays As Integer, saturdays As Integer Dim targetYear As Integer monthName = Trim(monthName) Select Case monthName Case "يناير": monthNumber = 1 Case "فبراير": monthNumber = 2 Case "مارس": monthNumber = 3 Case "ابريل": monthNumber = 4 Case "مايو": monthNumber = 5 Case "يونيو": monthNumber = 6 Case "يوليو": monthNumber = 7 Case "اغسطس": monthNumber = 8 Case "سبتمبر": monthNumber = 9 Case "اكتوبر": monthNumber = 10 Case "نوفمبر": monthNumber = 11 Case "ديسمبر": monthNumber = 12 Case Else CalculateFridaysSaturdays = "اسم الشهر غير صحيح" Exit Function End Select If monthNumber >= 10 Then targetYear = year(Date) - 1 ElseIf monthNumber <= 6 Then targetYear = year(Date) Else targetYear = baseYear End If If targetYear < 1900 Or targetYear > 2100 Then CalculateFridaysSaturdays = "السنة غير صحيحة" Exit Function End If fridays = CountWeekdayOccurrences(targetYear, monthNumber, vbFriday) saturdays = CountWeekdayOccurrences(targetYear, monthNumber, vbSaturday) Select Case LCase(dayType) Case "friday": CalculateFridaysSaturdays = fridays Case "saturday": CalculateFridaysSaturdays = saturdays Case Else: CalculateFridaysSaturdays = Array(fridays, saturdays) End Select End Function Function CountWeekdayOccurrences(targetYear As Integer, monthNumber As Integer, targetWeekday As Integer) As Integer Dim startDate As Date, endDate As Date Dim firstDay As Integer, totalDays As Integer Dim count As Integer startDate = DateSerial(targetYear, monthNumber, 1) endDate = DateSerial(targetYear, monthNumber + 1, 0) firstDay = Weekday(startDate) totalDays = endDate - startDate + 1 count = ((totalDays + firstDay - targetWeekday) \ 7) + IIf((firstDay <= targetWeekday), 1, 0) CountWeekdayOccurrences = count End Function ✅ تحسين قراءة أسماء الأشهر بحيث لا تتأثر بالمسافات الزائدة . ✅ إضافة فحص للسنة لمنع القيم غير المنطقية . ✅ تحسين الأداء باستخدام دالة تقوم بالحساب المباشر . ✅ تجنب الأخطاء عند تمرير قيم غير صحيحة أو عند التعامل مع أسماء الأشهر . ✅ تحديث الاستعلام SQL بحيث يستبعد القيم غير الصالحة (NULL أو الفراغ) . 👌 النتيجة : كود أسرع وأكثر كفاءة ويعمل دون أخطاء غير متوقعة بهذه الطريقة ، لن تحتاج إلى تغيير الكود يدوياً كل سنة ، وسيتم احتساب القيم المطلوبة تلقائياً !! أما الإستعلام ، فقد تم تعديله لمحاكاة الكود السابق على النحو التالي :- UPDATE data_shr SET gm = CalculateFridaysSaturdays([shr], 0, "Friday"), sbt = CalculateFridaysSaturdays([shr], 0, "Saturday") WHERE shr IN ("يناير", "فبراير", "مارس", "ابريل", "مايو", "يونيو", "اكتوبر", "نوفمبر", "ديسمبر") AND shr IS NOT NULL AND shr <> ""; ايام الغياب 2.accdb * تم حذف الأجزاء السابقة الغير ضرورية لتلافي ظهور رسائل الأخطاء .

السلام عليكم : تم اليوم وبحمد الله تطبيق مثال الباركود على القاعة الاصلية التي تحتوي على 66245 سجل وتطبع اربع انواع من الهويات ( البطاقات البلاستيكية) وكان العمل رائع جدا . والنتائج جيدة والحمد لله . بارك الله بجهودك استاذي الفاضل منكم نتعلم وشكرا جزيلا وجعله الله في ميزان حسناتك . ومن الله التوفيق.

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 32 و 64 (النسخة لدي 64 ) ، لتصبح الدالة في المديول كالآتي بعد إزالة التعليقات التوضيحية منها :- Option Compare Database Option Explicit #If VBA7 Then Private Declare PtrSafe Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As LongPtr, ByVal bInheritHandle As LongPtr, ByVal dwProcessId As LongPtr) As LongPtr Private Declare PtrSafe Function CloseHandle Lib "kernel32.dll" (ByVal hObject As LongPtr) As Long Private Declare PtrSafe Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As LongPtr, Optional ByVal lpDst As LongPtr, Optional ByVal nSize As LongPtr) As Long Private Declare PtrSafe Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As LongPtr, ByRef lpExitCode As Long) As Long Private Declare PtrSafe Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As LongPtr, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare PtrSafe Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr, Optional ByVal Length As Long) As Long Private Declare PtrSafe Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As LongPtr, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As LongPtr) As LongPtr Private Declare PtrSafe Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As LongPtr) As Long Private Declare PtrSafe Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As LongPtr, ByVal lpszSrc As LongPtr) As Long Private Declare PtrSafe Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) As LongPtr Private Declare PtrSafe Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As LongPtr, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As LongPtr, Optional ByVal lpArgToCompletionRoutine As LongPtr, Optional ByVal fResume As Long) As Long Private Declare PtrSafe Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As LongPtr) As Long Private Declare PtrSafe Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As LongPtr, Optional ByVal pszStrPtr As LongPtr) As Long Private Declare PtrSafe Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As LongPtr) #Else Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long Private Declare Function ExpandEnvironmentStringsW Lib "kernel32.dll" (ByVal lpSrc As Long, Optional ByVal lpDst As Long, Optional ByVal nSize As Long) As Long Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long Private Declare Function MsgWaitForMultipleObjects Lib "user32.dll" (ByVal nCount As Long, ByRef pHandles As Long, ByVal bWaitAll As Long, ByVal dwMilliseconds As Long, ByVal dwWakeMask As Long) As Long Private Declare Function SysReAllocStringLen Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long Private Declare Function CreateWaitableTimerW Lib "kernel32.dll" (Optional ByVal lpTimerAttributes As Long, Optional ByVal bManualReset As Long, Optional ByVal lpTimerName As Long) As Long Private Declare Function GetProcessId Lib "kernel32.dll" (ByVal hProcess As Long) As Long Private Declare Function PathCanonicalizeW Lib "shlwapi.dll" (ByVal lpszDst As Long, ByVal lpszSrc As Long) As Long Private Declare Function PathGetArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) As Long Private Declare Function SetWaitableTimer Lib "kernel32.dll" (ByVal hTimer As Long, ByRef pDueTime As Currency, Optional ByVal lPeriod As Long, Optional ByVal pfnCompletionRoutine As Long, Optional ByVal lpArgToCompletionRoutine As Long, Optional ByVal fResume As Long) As Long Private Declare Function ShellExecuteExW Lib "shell32.dll" (ByVal pExecInfo As Long) As Long Private Declare Function SysReAllocString Lib "oleaut32.dll" (ByVal pBSTR As Long, Optional ByVal pszStrPtr As Long) As Long Private Declare Sub PathRemoveArgsW Lib "shlwapi.dll" (ByVal pszPath As Long) #End If Private Const SEE_MASK_NOCLOSEPROCESS As Long = &H40 Private Const SEE_MASK_DOENVSUBST As Long = &H200 Private Const SEE_MASK_FLAG_NO_UI As Long = &H400 #If VBA7 Then Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As LongPtr lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As LongPtr lpIDList As LongPtr lpClass As String hkeyClass As LongPtr dwHotKey As Long hIcon As LongPtr hProcess As LongPtr End Type #Else Private Type SHELLEXECUTEINFO cbSize As Long fMask As Long hWnd As Long lpVerb As String lpFile As String lpParameters As String lpDirectory As String nShow As Long hInstApp As Long lpIDList As Long lpClass As String hkeyClass As Long dwHotKey As Long hIcon As Long hProcess As Long End Type #End If Public Const INFINITE As Long = &HFFFFFFFF Public Const STILL_ACTIVE As Long = &H103 Public Const PROCESS_HAS_TERMINATED As Long = vbObjectError Or &HDEAD Public Enum AppWinStyle vbHide = 0 vbShowNormal = 1 vbShowMinimized = 2 vbShowMaximized = 3 vbMaximize = 3 vbShowNoActivate = 4 vbShow = 5 vbMinimize = 6 vbShowMinNoActive = 7 vbShowNA = 8 vbRestore = 9 vbShowDefault = 10 End Enum Public Function Shell_n_Wait(ByRef PathName As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus) As Long Const PROCESS_QUERY_INFORMATION = &H400, QS_ALLINPUT = &H4FF, SYNCHRONIZE = &H100000 Dim hProcess As LongPtr, sPath As String If InStr(PathName, "%") = 0 Then sPath = PathName Else SysReAllocStringLen VarPtr(sPath), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(sPath), Len(sPath) + 1 End If On Error GoTo ErrorHandler hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, False, Shell(sPath, WindowStyle)) On Error GoTo 0 If hProcess Then sPath = vbNullString Do While MsgWaitForMultipleObjects(1, hProcess, False, INFINITE, QS_ALLINPUT) DoEvents Loop GetExitCodeProcess hProcess, Shell_n_Wait CloseHandle hProcess End If Exit Function ErrorHandler: Err.Raise Err.Number, , Err.Description End Function Public Function ShellW(ByRef PathName As String, Optional ByVal WindowStyle As AppWinStyle = vbShowNormal, Optional ByVal Wait As Long) As Long Const MAX_PATH = 260, QS_ALLINPUT = &H4FF, WAIT_OBJECT_0 = &H0 Dim TimedOut As Boolean, nCount As Long, pHandles As LongPtr, RV As Long, SEI As SHELLEXECUTEINFO Err.Clear If LenB(PathName) = 0 Then Exit Function With SEI .cbSize = LenB(SEI) .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_DOENVSUBST Or SEE_MASK_FLAG_NO_UI .nShow = WindowStyle If InStr(PathName, "%") Then SysReAllocStringLen VarPtr(.lpFile), , ExpandEnvironmentStringsW(StrPtr(PathName)) - 1 ExpandEnvironmentStringsW StrPtr(PathName), StrPtr(.lpFile), Len(.lpFile) + 1 Else .lpFile = PathName End If If InStr(.lpFile, "\.") <> 0 Or InStr(.lpFile, ".\") <> 0 Then If Len(.lpFile) < MAX_PATH Then SysReAllocStringLen VarPtr(.lpVerb), , MAX_PATH - 1 If PathCanonicalizeW(StrPtr(.lpVerb), StrPtr(.lpFile)) Then SysReAllocString VarPtr(.lpFile), StrPtr(.lpVerb) End If .lpVerb = vbNullString End If End If SysReAllocString VarPtr(.lpParameters), PathGetArgsW(StrPtr(.lpFile)) If LenB(.lpParameters) Then PathRemoveArgsW StrPtr(.lpFile) If InStr(.lpParameters, """") Then .lpParameters = Replace(.lpParameters, """", """""") End If If ShellExecuteExW(VarPtr(SEI)) Then ShellW = GetProcessId(.hProcess) If Wait Then .lpFile = vbNullString .lpParameters = vbNullString If .hProcess Then nCount = 1 pHandles = VarPtr(.hProcess) End If If Wait > INFINITE Then .hIcon = CreateWaitableTimerW If .hIcon Then nCount = nCount + 1 pHandles = VarPtr(.hIcon) Wait = SetWaitableTimer(.hIcon, CCur(-Wait)) End If End If Do RV = MsgWaitForMultipleObjects(nCount, ByVal pHandles, False, INFINITE, QS_ALLINPUT) If RV < nCount Then If .hIcon Then TimedOut = RV = 0 RV = CloseHandle(.hIcon) End If Err.Clear Exit Do End If DoEvents Loop If Not (TimedOut) Then RV = GetExitCodeProcess(.hProcess, ShellW) Err = PROCESS_HAS_TERMINATED Err.Description = "Exit Code" End If End If If .hProcess Then RV = CloseHandle(.hProcess) End If End With End Function Public Function ShellWS(ByRef Command As String, Optional ByVal WindowStyle As VbAppWinStyle = vbNormalFocus, Optional ByVal WaitOnReturn As Boolean) As Long Dim ws As Object Set ws = CreateObject("Wscript.Shell") ShellWS = ws.Run(Command, WindowStyle, WaitOnReturn) End Function الآن في النموذج الأول th44 ، وبعد نسخ مربع النص str_Text وعنصر الصورة للباركود اليه ، أصبح كود النموذج كالآتي :- Option Compare Database Option Explicit Private Function ConstQRPath() ConstQRPath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "QR_code.png" End Function Private Function ConstBarcodePath() ConstBarcodePath = CurrentProject.Path & "\Data\QR_images\" & Me.Key & " - " & "ID_PDF_417.png" End Function Private Sub CreateQRCode() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.th_Text & Chr(34) OutputFile = Chr(34) & ConstQRPath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --scale=2 -w 0 --height=100 --barcode=58 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub CreateBarcode() On Error GoTo ErrorHandler If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Exit Sub End If Dim AppName As String Dim OutputFile As String Dim OutputText As String Dim CommandLine As String AppName = Chr(34) & Application.CurrentProject.Path & "\Data\zint.exe" & Chr(34) OutputText = Chr(34) & Me.str_Text & Chr(34) OutputFile = Chr(34) & ConstBarcodePath & Chr(34) CommandLine = AppName & " -o " & OutputFile & " --rotate=0 --eci=24 --binary --barcode=55 --mode=3 -d " & OutputText Shell_n_Wait CommandLine, vbHide Exit Sub ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical, "Error" End Sub Private Sub Form_Current() Call CreateAndDisplayCodes End Sub Sub CreateAndDisplayCodes() On Error GoTo ErrorHandler If IsNull(Me.th_Text) Or IsEmpty(Me.th_Text) Or Len(Trim(Nz(Me.th_Text, ""))) = 0 Then Me.QR_Code.Picture = "" Else Call CreateQRCode Me.QR_Code.Picture = ConstQRPath End If If IsNull(Me.str_Text) Or IsEmpty(Me.str_Text) Or Len(Trim(Nz(Me.str_Text, ""))) = 0 Then Me.ID_PDF_417.Picture = "" Else Call CreateBarcode Me.ID_PDF_417.Picture = ConstBarcodePath End If Exit Sub ErrorHandler: If Err.Number = 2220 Then Me.QR_Code.Picture = "" Me.ID_PDF_417.Picture = "" Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical, "Code generation error" End If Resume Next End Sub Private Sub sdfff_Click() On Error Resume Next DoCmd.OpenForm "thaaer55" Dim RName, FldCriteria As String RName = "rpt_Details" FldCriteria = "[Key]=" & Me![Key] DoCmd.OpenReport RName, acViewNormal, , FldCriteria End Sub وهذا الملف بعد التعديل :- New.zip اخبرنا بالنتيجة 😊 .

وعليكم السلام ورحمة الله تعالى وبركاته بالنسبة للكود المقدم لك مسبقا يمكنك تعديله على الشكل التالي Private Sub CommandButton16_Click() Dim Tmam_Wbk As Workbook, TPath As String If ComboBox28.Value = "" Then MsgBox "من فضلك أختار التجهيزة": Exit Sub If OptionButton1.Value Then TPath = ThisWorkbook.Path & "\تمام\مدينة\" & ComboBox28.Value ElseIf OptionButton2.Value Then TPath = ThisWorkbook.Path & "\تمام\محافظات\" & ComboBox28.Value End If If Len(Dir(TPath & ".xlsx")) > 0 Then TPath = TPath & ".xlsx" ElseIf Len(Dir(TPath & ".xls")) > 0 Then TPath = TPath & ".xls" Else MsgBox "الملف غير موجود": Exit Sub End If On Error GoTo ErrorHandler Set Tmam_Wbk = Workbooks.Open(TPath) Unload Me Exit Sub ErrorHandler: Unload Me End Sub هنا قمت بتعديل الامتدادات على عدة أكواد للتجربة Run V3.xls

الاستاذة الأعزاء ابوبسملة وBarnaوغيرهم حياكم الله اليوم تمت انخراط العامل رقم ،261 مبلغ مالي قدره 3000.00 ولكن عندما نقوم بفتح FrmTransfer يقوم الكود بإقتطاع له مبلغ إضافي 1500.00 ليصبح 4500.00 وهذا خطأ اي الكود مزال يعاني من المشاكل حاولت التعديل على دالة Between في الكود واستبدلت شرط DateSerial 2,،28 استبدلتها ب 3,31 فامتنع الكود على الاقتطاع الاضافي ولكن مزلت متخوف يمكن تكون مشاكل في جويلية القادم وبارك الله فيكم. مشكلة 2025.rar

تفضل أخي @husseinharby مع التحفظ عليه .... كود من مايكروسوفت . Private Sub UserForm_Initialize() On Error Resume Next End Sub