طباعة اسكنر

**ابو ياسين المشولي** · أغسطس 24, 2024

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

عندي كود عجزت فيه يطبع اسكنر

  On Error Resume Next
Dim ID_PuB As String
Dim bb As String
bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\")))
ID_PuB = Me.nofatora.Value
Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
'On Error GoTo Handle_Err
On Error Resume Next
Dim Dialog1 As New WIA.CommonDialog, DPI As Integer, PP As Integer, L As Integer
Dim Scanner As WIA.Device
Dim img As WIA.ImageFile
Dim intPages As Integer
Dim strFileJPG As String

Dim blnContScan As Boolean
Dim ContScan As String    'msgbox to chk if more pages are to be scanned

Dim strFilePDF As String
Dim RptName As String
Dim strProcName As String
strProcName = "ScanDocs"



blnContScan = True
intPages = 0

    DPI = 200
    PP = 1 'No of pages
    Set Scanner = Dialog1.ShowSelectDevice(WIA.WiaDeviceType.ScannerDeviceType, False)

  With Scanner.items(1)
        .Properties("6146").Value = 1 'Colour intent (1 for color, 2 for grayscale, 4 for b & w)
        .Properties("6147").Value = DPI 'DPI horizontal
        .Properties("6148").Value = DPI 'DPI vertical
        .Properties("6149").Value = 0 'x point to start scan
        .Properties("6150").Value = 0 'y point to start scan
        .Properties("6151").Value = 8.27 * DPI 'Horizontal extent
        .Properties("6152").Value = 11.69 * DPI     'Vertical extent for letter
    End With
'    If CurrentProject.Path & "\DATA\StPic" & "\" & Trim(STR(nofatora)) & ".jpg" = [sora] Then
'If MsgBox(" يوجد مرفقات من قبل في هذا السجل هل تريد اضافه المزيد" & vbCrLf & vbCrLf & _
'"", vbYesNo + vbMsgBoxRight + vbExclamation, " تنبية ") = vbNo Then
'Exit Sub
'
'End If
'End If
'Kill CurrentProject.Path & "\DATA\StPic" & "\" & Trim(STR(nofatora)) & ".jpg"
    If bb = "DATATAILORVATa" Then
    Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True)
    intPages = Me.nofatora
    strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" & "\" & Trim(STR(intPages)) & ".jpg"
    img.SaveFile (strFileJPG)
    ElseIf bb = "DATATAILORVATb" Then
    Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True)
    intPages = Me.nofatora
    strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" & "\" & Trim(STR(intPages)) & ".jpg"
    img.SaveFile (strFileJPG)
    ElseIf bb = "DATATAILORVATc" Then
    Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True)
    intPages = Me.nofatora
    strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" & "\" & Trim(STR(intPages)) & ".jpg"
    img.SaveFile (strFileJPG)
    ElseIf bb = "DATATAILORVATd" Then
    Set img = Dialog1.ShowTransfer(Scanner.items(1), wiaFormatJPEG, True)
    intPages = Me.nofatora
    strFileJPG = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" & "\" & Trim(STR(intPages)) & ".jpg"
'    strFileJPG = CurrentProject.Path & "\DATA\StPic" & "\" & ID_PuB & Trim(Str(intPages)) & ".jpg"
'    strFileJPG = CurrentProject.Path & "\DATA\StPic" + "\" & ID_PuB & ".jpg"
    img.SaveFile (strFileJPG)

    DoCmd.SetWarnings False
'    DoCmd.RunSQL "UPDATE Data SET Data.sora = [CurrentProject].[Path] & ""\DATA\StPic""+""\"" & nofatora & "".jpg"" " & vbCrLf & _
"WHERE (((Data.nofatora)=[Forms]![zx]![nofatora]));"
    DoCmd.SetWarnings True
DoCmd.RunCommand acCmdSaveRecord
 MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & "  )  بنجاح" & "  ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5)

    Set Scanner = Nothing
    Set img = Nothing
'    strFileJPG = ""

    'Prompt user if there are additional pages to scan




strFilePDF = ""

End If

**ابوخليل** · أغسطس 24, 2024

اهلا اخي ابو ياسين .. من زمان عنك .. اتمنى تكون بخير انت واهلك واحبابك

اولا :

مادمت تستخدم هذا السطر On Error Resume Next فلن تجد سبب المشكلة

فانت استخدمته في اكثر من مكان داخل الكود

نصيحتي ان تلغيه وتتبع الخطأ وتعالجه

وانا متأكد انك ستجد الخلل بنفسك

ثانيا :

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

**ابو ياسين المشولي** · أغسطس 24, 2024

حبيبي ابو خليل معلمنا الجليل

يسعدني مرورك

انا بخير دامك بخير الله يسعدك

هو كان عندي شغال بشرط واحد

اي عندما يكون بمجلد واحد

ولكن باربعه اجهزة مرتبطه بالشبكه

والمشكله الاكبر اني حاليا في اليمن

والنت عندنا ماشاء الله مايعادل 10% في بلادكم الحبيبه

وان شاء الله بجد له حل

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

**ابو ياسين المشولي** · أغسطس 26, 2024

السلام عليكم

وصلت لحل الى هذا وارجو ان يفيد الجميع

'  On Error Resume Next

Dim fdialog As Office.FileDialog
Dim filepath As String
Dim bb As String
Dim sdialog As New WIA.CommonDialog
Dim imagefile As WIA.imagefile
On Error GoTo errorhandle
bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\")))

Dim fso As Object
Dim fldrname, fldrpath, FoldrPath As String
FoldrPath = "Pictures"
Set fso = CreateObject("scripting.filesystemobject")
          fldrpath = CurrentProject.Path & "\" & FoldrPath
          If Not fso.FolderExists(fldrpath) Then
             fso.CreateFolder (fldrpath)
          End If

'==================================
Set fdialog = Application.FileDialog(msoFileDialogSaveAs)
If bb = "DATATAILORVATa" Then
'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATb" Then
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & ".jpg"
'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATc" Then
'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATd" Then
'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & ".jpg"
 End If

            Set imagefile = sdialog.ShowAcquireImage()
            imagefile.SaveFile filepath
            PicPath = filepath
           imagefile.Requery

errorhandleexit:
        Exit Sub
errorhandle:
If Err.Number = "-2147024816" Then
If MsgBox("توجد صورة تحمل نفس الرقم" & vbNewLine & "هل تريد حذف الصورة القديمة" & vbNewLine & "في حال الرفض سيتم اضافة رقم عشوائي الى اسم الصورة لتمييزها", vbCritical + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then
'Kill filepath
If bb = "DATATAILORVATa" Then
'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
ElseIf bb = "DATATAILORVATb" Then
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
ElseIf bb = "DATATAILORVATc" Then
'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
ElseIf bb = "DATATAILORVATd" Then
'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & "(" & "1" & ")" & ".jpg"
 End If

            Set imagefile = sdialog.ShowAcquireImage()
            imagefile.SaveFile filepath
            PicPath = filepath
'            imagefile.Requery
'
Else



 End If

ElseIf Err.Number = "-2145320939" Then
MsgBox "الاسكانر غير متصل", vbCritical + vbMsgBoxRight, "تنبيه"
Else
        PicPath = Err.Number
'        MsgBox Err.Description
   MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & "  )  بنجاح" & "  ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5)

End If
        Resume errorhandleexit

ولكن لم استطيع

كيف اجعله اكثر

من واحد

مثلا من واحد الى خمسه او عشر

اقصد هذا

filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & "1" & ")" & ".jpg"

**ابو ياسين المشولي** · أغسطس 26, 2024

ماخيبت ظنك استاذي ابو خليل ابوخليل

وصلت الى هذا فكانت النتيجه ممتازة وكانت المطلوب بانسبة لي

'  On Error Resume Next

Dim fdialog As Office.FileDialog
Dim filepath As String
Dim bb As String
Dim sdialog As New WIA.CommonDialog
Dim imagefile As WIA.imagefile
On Error GoTo errorhandle
bb = (Mid(CurrentDb("data1").Connect, InStrRev(CurrentDb("data1").Connect, "\") + 1, Len(CurrentDb("data1").Connect) - InStrRev(CurrentDb("data1").Connect, "\")))

Dim fso As Object
Dim fldrname, fldrpath, FoldrPath As String
FoldrPath = "Pictures"
Set fso = CreateObject("scripting.filesystemobject")
          fldrpath = CurrentProject.Path & "\" & FoldrPath
          If Not fso.FolderExists(fldrpath) Then
             fso.CreateFolder (fldrpath)
          End If

'==================================
Set fdialog = Application.FileDialog(msoFileDialogSaveAs)
If bb = "DATATAILORVATa" Then
'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATb" Then
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & ".jpg"
'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATc" Then
'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & ".jpg"
ElseIf bb = "DATATAILORVATd" Then
'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & ".jpg"
 End If

            Set imagefile = sdialog.ShowAcquireImage()
            imagefile.SaveFile filepath
            PicPath = filepath
           imagefile.Requery

errorhandleexit:
        Exit Sub
errorhandle:
If Err.Number = "-2147024816" Then
If MsgBox("توجد صورة تحمل نفس الرقم" & vbNewLine & "هل تريد حذف الصورة القديمة" & vbNewLine & "في حال الرفض لم تتم الاضافه", vbCritical + vbYesNo + vbMsgBoxRight, "تنبيه") = vbYes Then
TempVars.add "name", InputBox(Space(30) & " ادخـل رقم عددتكرار الفاتورة ", Space(30) & DLookup(" [الاسم_التجاري] ", "بيانات_الشركه"), "1")

'Kill filepath
If bb = "DATATAILORVATa" Then
'filepath = CurrentProject.Path & "\DATA\StPica" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPica" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
ElseIf bb = "DATATAILORVATb" Then
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicb" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
'filepath = CurrentProject.Path & "\DATA\StPicb" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
ElseIf bb = "DATATAILORVATc" Then
'filepath = CurrentProject.Path & "\DATA\StPicc" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicc" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
ElseIf bb = "DATATAILORVATd" Then
'filepath = CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
filepath = "\\WIN-GRM8M28FNLU\Tailor\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"
 End If

            Set imagefile = sdialog.ShowAcquireImage()
            imagefile.SaveFile filepath
            PicPath = filepath
'            imagefile.Requery
'
Else
 End If
ElseIf Err.Number = "-2145320939" Then
MsgBox "الاسكانر غير متصل", vbCritical + vbMsgBoxRight, "تنبيه"
Else
        PicPath = Err.Number
'        MsgBox Err.Description
   MsgBox " تم حـفـظ صـورة الفاتورة ( " & nofatora & "  )  بنجاح" & "  ", 48, DLookup(" [الاسم_التجاري] ", "بيانات_الشركه") & Space(5)

End If
        Resume errorhandleexit

تم تعديل أغسطس 27, 2024 بواسطه ابو ياسين المشولي
للفائدة

**ابوخليل** · أغسطس 26, 2024

الحمد لله على انقضاء حاجتك

كما تعلم لا يمكنني فحص الكود وتتبعه الا من خلال تطبيق

خاصة وانه موزع على اكثر من جهاز ووجود مسميات ومسارات ومتغيرات تظهر عندك فقط

**ابو ياسين المشولي** · أغسطس 27, 2024

انا عامل كود للشبكةوكود بدون شبكه

وهذا هة بدون شبكه

كان ودي ارفع ملف بس للاس

CurrentProject.Path & "\DATA\StPicd" + "\" & nofatora & "(" & TempVars!name & ")" & ".jpg"

ف النت عندنا مرة ضعيف

تسجيل الدخول

طباعة اسكنر

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

ابو ياسين المشولي

ابوخليل

ابو ياسين المشولي

ابو ياسين المشولي

ابو ياسين المشولي

ابوخليل

ابو ياسين المشولي

Join the conversation

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

تصفح الموقع

تصفح جديد الموقع

Support

Important Information