طباعة اسكنر

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

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

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

  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

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

اولا :

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

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

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

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

ثانيا :

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

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

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

يسعدني مرورك

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

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

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

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

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

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

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

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

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

السلام عليكم

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

'  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

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

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

'  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 بواسطه ابو ياسين المشولي
للفائدة

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

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

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

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

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

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

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

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

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

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

تسجيل الدخول

طباعة اسكنر

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

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

ابوخليل

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

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

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

ابوخليل

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

Join the conversation

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

تصفح الموقع

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

Support

Important Information