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

طباعة اسكنر

ابو ياسين المشولي
 مشاركة
إذهب إلى أفضل إجابة Solved by ابو ياسين المشولي,

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

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

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

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

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

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

  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

 

رابط هذا التعليق
شارك
ابوخليل

ابوخليل

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

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

اولا :

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

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

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

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

ثانيا :

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

 

رابط هذا التعليق
شارك
ابو ياسين المشولي

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

قام بنشر
  • الكاتب
قام بنشر

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

يسعدني مرورك

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

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

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

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

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

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

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

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

رابط هذا التعليق
شارك
ابو ياسين المشولي

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

قام بنشر
  • الكاتب
قام بنشر

السلام عليكم

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

'  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"

 

رابط هذا التعليق
شارك
  • أفضل إجابة
ابو ياسين المشولي

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

قام بنشر
  • الكاتب
  • أفضل إجابة
قام بنشر (معدل)

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

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

'  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

 

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

ابوخليل

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

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

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

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

  • Thanks 1
رابط هذا التعليق
شارك
ابو ياسين المشولي

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

قام بنشر
  • الكاتب
قام بنشر

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

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

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

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

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

رابط هذا التعليق
شارك

من فضلك سجل دخول لتتمكن من التعليق

ستتمكن من اضافه تعليقات بعد التسجيل



سجل دخولك الان
 مشاركة
الذهاب الي قائمه المواضيع

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

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

Important Information

  I accept