How can I add this code to the storage location of my file before scanning and then convert it to a PDF file?
I want to select a folder or through a combox before scanning my document.
t
I want to select a folder or through a combox before scanning my document.
Code:
Public Function feeder scan()
'Must include reference to Microsoft Windows Image Acquisition 2.0 dell
Sub SetTheMainPathForAttachments()
'Define the main path to save attachments
'Change the main path of attachments from here only
' ---------------
PathOfFile = "c:\scan\" ---> Not in this way
' Create a folder after making sure that it does not already exist
If Len(Dir(PathOfFile, vbDirectory)) = 0 Then
MkDir PathOfFile
End If
End Sub
On Error GoTo Handle_Err
Dim ComDialog As New wia.CommonDialog, DPI As Integer, PP As Integer, l As Integer
Dim wiaScanner As wia.Device
Dim wiaImg As wia.ImageFile
Dim intPages As Integer
Dim strFileJPG As String
Dim rsParent As DAO.Recordset2
Dim rsChild As DAO.Recordset2
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
Dim picfullname
strProcName = "ScanDocs"
blnContScan = True
Dim Counter As Integer
'Number is 150,200,300,400,500,600,1200
DPI = DLookup("[DPI]", "DPI")
If Len(Dir(PathOfFile & Forms![Form1]![IDD], vbDirectory)) = 0 Then
MkDir PathOfFile & Forms![Form1]![IDD]
End If
Set ComDialog = New wia.CommonDialog
Set wiaScanner = ComDialog.ShowSelectDevice(WiaDeviceType.UnspecifiedDeviceType, False, True)
Counter = 0
With wiaScanner.Items(1)
wiaScanner.Properties("3088").Value = 1
.Properties("6146").Value = DLookup("[Colour]", "DPI") '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 = DLookup("[Horizontal]", "DPI") * DPI 'Horizontal extent -A4 = 8.5
.Properties("6152").Value = DLookup("[Vertical]", "DPI") * DPI 'Vertical extent for letter -A4 = 11
End With
'Start Scan if err number -2145320957 Scan document finish
Do While Err.Number <> -2145320957 'error number is ADF status don't feed document
On Error GoTo here
Counter = Counter + 1
picfullname = PathOfFile & Forms![Form1]![IDD] & "\" & Forms![Form1]![IDD] & "-" & Format(Now, "d-m-yy_h-n-s") & Counter & ".jpg"
' ÎØæÉ ÓÍÈ ÇáÕæÑÉ
Set wiaImg = wiaScanner.Items(1).Transfer(wia.FormatID.wiaFormatJPEG)
wiaImg.SaveFile picfullname
Set wiaImg = Nothing
strFileJPG = ""
' Add full name of pic in table images
'Must include reference to Microsoft office 16.0 database engine object libaray
Dim Ttb As Recordset
Set Ttb = CurrentDb.OpenRecordset("Image")
Ttb.AddNew
Ttb![IDD] = Forms![Form1]![IDD]
Ttb![Path] = picfullname
Ttb.Update
Forms![Form1]![ImagesSubform].Requery
Forms![Form1]![ImagesSubform].SetFocus
DoCmd.GoToRecord , , acLast
Loop
here:
Handle_Exit:
Exit Function
Handle_Err:
Select Case Err.Number
Case 2501
Resume Handle_Exit
Case Else
MsgBox "Oops! Something went wrong." & vbCrLf & vbCrLf & _
"In Function:" & vbTab & strProcName & vbCrLf & _
"Err Number: " & vbTab & Err.Number & vbCrLf & _
"Description: " & vbTab & Err.Description, 0, _
"Error in " & Chr$(34) & strProcName & Chr$(34)
Resume Handle_Exit
End Select
End Functiont
| Public Function feeder scan() 'Must include reference to Microsoft Windows Image Acquisition 2.0 dell Sub SetTheMainPathForAttachments() 'Define the main path to save attachments 'Change the main path of attachments from here only ' --------------- PathOfFile = "c:\scan\" ---> Not in this way ' Create a folder after making sure that it does not already exist If Len(Dir(PathOfFile, vbDirectory)) = 0 Then MkDir PathOfFile End If End Sub On Error GoTo Handle_Err Dim ComDialog As New wia.CommonDialog, DPI As Integer, PP As Integer, l As Integer Dim wiaScanner As wia.Device Dim wiaImg As wia.ImageFile Dim intPages As Integer Dim strFileJPG As String Dim rsParent As DAO.Recordset2 Dim rsChild As DAO.Recordset2 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 Dim picfullname strProcName = "ScanDocs" blnContScan = True Dim Counter As Integer 'Number is 150,200,300,400,500,600,1200 DPI = DLookup("[DPI]", "DPI") If Len(Dir(PathOfFile & Forms![Form1]![IDD], vbDirectory)) = 0 Then MkDir PathOfFile & Forms![Form1]![IDD] End If Set ComDialog = New wia.CommonDialog Set wiaScanner = ComDialog.ShowSelectDevice(WiaDeviceType.UnspecifiedDeviceType, False, True) Counter = 0 With wiaScanner.Items(1) wiaScanner.Properties("3088").Value = 1 .Properties("6146").Value = DLookup("[Colour]", "DPI") '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 = DLookup("[Horizontal]", "DPI") * DPI 'Horizontal extent -A4 = 8.5 .Properties("6152").Value = DLookup("[Vertical]", "DPI") * DPI 'Vertical extent for letter -A4 = 11 End With 'Start Scan if err number -2145320957 Scan document finish Do While Err.Number <> -2145320957 'error number is ADF status don't feed document On Error GoTo here Counter = Counter + 1 picfullname = PathOfFile & Forms![Form1]![IDD] & "\" & Forms![Form1]![IDD] & "-" & Format(Now, "d-m-yy_h-n-s") & Counter & ".jpg" ' ÎØæÉ ÓÍÈ ÇáÕæÑÉ Set wiaImg = wiaScanner.Items(1).Transfer(wia.FormatID.wiaFormatJPEG) wiaImg.SaveFile picfullname Set wiaImg = Nothing strFileJPG = "" ' Add full name of pic in table images 'Must include reference to Microsoft office 16.0 database engine object libaray Dim Ttb As Recordset Set Ttb = CurrentDb.OpenRecordset("Image") Ttb.AddNew Ttb![IDD] = Forms![Form1]![IDD] Ttb![Path] = picfullname Ttb.Update Forms![Form1]![ImagesSubform].Requery Forms![Form1]![ImagesSubform].SetFocus DoCmd.GoToRecord , , acLast Loop here: Handle_Exit: Exit Function Handle_Err: Select Case Err.Number Case 2501 Resume Handle_Exit Case Else MsgBox "Oops! Something went wrong." & vbCrLf & vbCrLf & _ "In Function:" & vbTab & strProcName & vbCrLf & _ "Err Number: " & vbTab & Err.Number & vbCrLf & _ "Description: " & vbTab & Err.Description, 0, _ "Error in " & Chr$(34) & strProcName & Chr$(34) Resume Handle_Exit End Select End Function |
Last edited by a moderator:
