اذهب الي المحتوي
أوفيسنا

توحيد اكواد الباركود في نموذجين منفصلين بكود واحد

محمد التميمي

بواسطه محمد التميمي
في قسم الأكسيس Access

 مشاركة
إذهب إلى الإجابة الإجابة بواسطة Foksh,

الردود الموصى بها

محمد التميمي

محمد التميمي

قام بنشر
قام بنشر

السلام عليكم :

تقبل الله صيامكم واعمالكم في هذا الشهر الفضيل...

في المثال المرفق يوجد نموذجين 

النموذج الاول باسم (th44) يحتوي على باركود  خصصته لقراءة للارقام حسب ما مكتوب في مربع النص ( str_Text)

النموذج الثاني باسم (th55) يحتوي على QR خصصته للاسماء بالحروف العربية حسب ما مكتوب في مربع النص ( th_Text)

 

اساتذتي الكرام : اُريد دمج الاكواد (في الحالي) ليظهر الباركود مع QR في نموذج واحد مع الاحتفاض بمربعي النص [ ( th_Text) و ( th_Text) ] المخصصة للحروف العربية والارقام

علما ان اصل الموضوع منقول عن الاستاذ جعفر جزاه الله الف خير

حاولت كثيراً الدمج بين الاكواد فلم افلح كونها متشابهة ...

 

مع فائق الشكر والتقدير...

 

 

Barcood + QR.rar

Foksh

Foksh

قام بنشر
قام بنشر
20 دقائق مضت, محمد التميمي said:

السلام عليكم :

 

وعليكم السلام ورحمة الله وبركاته ,,

المرفق غير سليم ،:excl:،

Trojan.png.288a41aef6a12fe6fda7e6eb6189ea23.png

 

محمد التميمي

محمد التميمي

قام بنشر
  • الكاتب
قام بنشر (معدل)
منذ ساعه, Foksh said:

وعليكم السلام ورحمة الله وبركاته ,,

المرفق غير سليم ،:excl:،

Trojan.png.288a41aef6a12fe6fda7e6eb6189ea23.png

 

السلام عليكم تم استبدال المرفق

علما ان المرفق الاول يعمل لدي ربما حماية الفايروس في الويندوز هو المشكلة

New.rar

تم تعديل بواسطه محمد التميمي
محمد التميمي

محمد التميمي

قام بنشر
  • الكاتب
قام بنشر
5 ساعات مضت, محمد التميمي said:

السلام عليكم تم استبدال المرفق

علما ان المرفق الاول يعمل لدي ربما حماية الفايروس في الويندوز هو المشكلة

New.rar 295.06 kB · 8 downloads

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

https://www.mediafire.com/file/ss6v518qve9ubgw/New.rar/file

Foksh

Foksh

قام بنشر
قام بنشر (معدل)
12 ساعات مضت, محمد التميمي said:

السلام عليكم تم استبدال المرفق

علما ان المرفق الاول يعمل لدي ربما حماية الفايروس في الويندوز هو المشكلة

New.rar 295.06 kB · 9 downloads

نفس النتيجة للأسف ، يبدو أن جهازك مصاب بفايروس لذلك لا تظهر المشكلة في جهازك يا صديقي 🤗,

تم تعديل بواسطه Foksh
  • تمت الإجابة
Foksh

Foksh

قام بنشر
  • تمت الإجابة
قام بنشر
5 ساعات مضت, محمد التميمي said:

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

https://www.mediafire.com/file/ss6v518qve9ubgw/New.rar/file

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 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

 

اخبرنا بالنتيجة 😊 .

 

 

 

 

  • Like 1
محمد التميمي

محمد التميمي

قام بنشر
  • الكاتب
قام بنشر
2 ساعات مضت, Foksh said:

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 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 469.03 kB · 2 downloads

 

اخبرنا بالنتيجة 😊 .

 

 

 

 

السلام عليكم : دعائنا في هذا الشهر الفضيل لك ولولديك بالتوفيق والمغفرة وجزاكم الله خيرا في الدنيا والاخرة.

نعم النتيجة مبهرة بعد تعديل جنابكم الكريم ... بارك الله بجهودكم القيمة وشكراً جزيلاً:fff:

  • Thanks 1
محمد التميمي

محمد التميمي

قام بنشر
  • الكاتب
قام بنشر
15 ساعات مضت, Foksh said:

بعد تحميل المرفق من الرابط والإطلاع عليه ،اضطررت الى تعديل أصل الكود بحيث يعمل على النواتين 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 469.03 kB · 4 downloads

 

اخبرنا بالنتيجة 😊 .

 

 

 

 

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

  • Like 1
Foksh

Foksh

قام بنشر
قام بنشر
10 دقائق مضت, محمد التميمي said:

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

وعليكم السلام ورحمة الله وبركاته..

تبارك الرحمن ، ما شاء الله ، جزاكم الله كل الخير ، والله يعطيك العافية 🤗

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
 مشاركة
الذهاب الي قائمه المواضيع

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information

  I accept