13Type Mismatch Access 2007 - vba

I'm attempting to fix some botched up VBA from someone whom I inherited this Access database from. Aside from the hardly-useful notes left in VBA, there is no documentation, so I am trying to figure out what everything does, and if it is correct. I continue getting a 13Type Mismatch error when I am Clicking a button to add either units or a value to a table of Contributions. I thought it was an easy fix such as a messed up variable declaration, however I've changed them to Double and it didn't seem to correct my error. Does anyone see anything off the bat that they might recognize as throwing this error? Thanks ahead of time for your efforts.
Private Sub AddContributionBtn_Click()
On Error GoTo Err_AddContributionBtn
Dim Cancel As Integer
Dim CurrentNAVDate As Date
Dim CurrentNAV As Double
Dim ConfirmAddCont As Double
Dim CalcContUnits As Double
Dim CalcContValue As Double
Dim StringSQL As String
'get current NAV
CurrentNAVDate = Format(DateAdd("s", -1, DateAdd("q", DateDiff("q", "1/1/1900", Date), "1/1/1900")), "Short Date")
CurrentNAV = Format(DLookup("NetAssetValue", "NAV_Tbl", "Format(NAV_Date, ""mmddyyyy"") = " & Format(CurrentNAVDate, "mmddyyyy")), "Currency")
'validation to require either contribution units or value is entered, not both
If IsNull(Me.ContValueTxt) = True And IsNull(Me.ContUnitsTxt) = True Then
MsgBox "Please enter contribution units or value."
Me.ContUnitsTxt.SetFocus
Cancel = True
Exit Sub
ElseIf IsNull(Me.ContValueTxt) = False And IsNull(Me.ContUnitsTxt) = False Then
MsgBox "Both contribution units and value may not be entered."
Me.ContUnitsTxt.SetFocus
Cancel = True
Exit Sub
Else:
If IsNull(Me.ContValueTxt) = True And IsNull(Me.ContUnitsTxt) = False Then
'calculate contribution value from units
CalcContUnits = Me.ContUnitsTxt
CalcContValue = CalcContUnits * CurrentNAV
GoTo ConfirmAppend
ElseIf IsNull(Me.ContValueTxt) = False And IsNull(Me.ContUnitsTxt) = True Then
'calculate contribution units from value
CalcContValue = Me.ContValueTxt
CalcContUnits = CalcContValue / CurrentNAV
GoTo ConfirmAppend
End If
End If
ConfirmAppend:
'confirm contribution value and units, run append query
ConfirmAddCont = MsgBox("Add " & Format(CalcContUnits, "fixed") & " units for a contribution value of " & Format(CalcContValue, "currency") & "?", _
vbOKCancel, "Add Contribution")
If ConfirmAddCont = vbOK Then
DoCmd.Hourglass True
DoCmd.SetWarnings False
StringSQL = "INSERT INTO ContributionTbl(ContDate, ContUnits, ContNAV, ContType) VALUES (#" & Date & "#, " & CalcContUnits & ", #" & CurrentNAVDate & "#, " & 1 & ");"
DoCmd.RunSQL (StringSQL)
DoCmd.SetWarnings True
DoCmd.Hourglass False
Me.ContUnitsTxt = Null
Me.ContValueTxt = Null
Forms!PlanFrm![PlanContributedUnitsFrm].Requery
Else
Cancel = True
Exit Sub
End If
Exit_AddContributionBtn:
Exit Sub
Err_AddContributionBtn:
MsgBox Err.Number & Err.Description
Resume Exit_AddContributionBtn
End Sub

As shown in the discussion, I make our guess clearer in this temporary reponse:
Error may be here:
CurrentNAV = Format(DLookup("NetAssetValue", "NAV_Tbl", "Format(NAV_Date, ""mmddyyyy"") = " & Format(CurrentNAVDate, "mmddyyyy")), "Currency")
as DLookup("NetAssetValue",...) gets NULL,
Format(NULL, "Currency") gets 13 Type Mismatch, as I've reproduced this in Access 2007.
This can be explained:
Since there is no recent date in the table field NAV_Tbl.NetAssetValue, as in the case we get the date CurrentNAVDate = 09/30/2013 (last date of the last quarter).
So you may try code like this, by introducing varCurrency variable to handle this NULL value case:
Private Sub AddContributionBtn_Click()
On Error GoTo Err_AddContributionBtn
Dim Cancel As Integer
Dim CurrentNAVDate As Date
Dim CurrentNAV As Double
Dim ConfirmAddCont As Double
Dim CalcContUnits As Double
Dim CalcContValue As Double
Dim StringSQL As String
Dim varCurrency
'get current NAV
CurrentNAVDate = Format(DateAdd("s", -1, DateAdd("q", DateDiff("q", "1/1/1900", Date), "1/1/1900")), "Short Date")
varCurrency = DLookup("NetAssetValue", "NAV_Tbl", "Format(NAV_Date, ""mmddyyyy"") = " & Format(CurrentNAVDate, "mmddyyyy"))
If(IsNull(varCurrency) then
CurrentNAV = 0
Else
CurrentNAV = Format(varCurrency, "Currency")
End If
'validation to require either contribution units or value is entered, not both
If IsNull(Me.ContValueTxt) = True And IsNull(Me.ContUnitsTxt) = True Then
MsgBox "Please enter contribution units or value."
Me.ContUnitsTxt.SetFocus
Cancel = True
Exit Sub
ElseIf IsNull(Me.ContValueTxt) = False And IsNull(Me.ContUnitsTxt) = False Then
MsgBox "Both contribution units and value may not be entered."
Me.ContUnitsTxt.SetFocus
Cancel = True
Exit Sub
Else:
If IsNull(Me.ContValueTxt) = True And IsNull(Me.ContUnitsTxt) = False Then
'calculate contribution value from units
CalcContUnits = Me.ContUnitsTxt
CalcContValue = CalcContUnits * CurrentNAV
GoTo ConfirmAppend
ElseIf IsNull(Me.ContValueTxt) = False And IsNull(Me.ContUnitsTxt) = True Then
'calculate contribution units from value
CalcContValue = Me.ContValueTxt
CalcContUnits = CalcContValue / CurrentNAV
GoTo ConfirmAppend
End If
End If
ConfirmAppend:
'confirm contribution value and units, run append query
ConfirmAddCont = MsgBox("Add " & Format(CalcContUnits, "fixed") & " units for a contribution value of " & Format(CalcContValue, "currency") & "?", _
vbOKCancel, "Add Contribution")
If ConfirmAddCont = vbOK Then
DoCmd.Hourglass True
DoCmd.SetWarnings False
StringSQL = "INSERT INTO ContributionTbl(ContDate, ContUnits, ContNAV, ContType) VALUES (#" & Date & "#, " & CalcContUnits & ", #" & CurrentNAVDate & "#, " & 1 & ");"
DoCmd.RunSQL (StringSQL)
DoCmd.SetWarnings True
DoCmd.Hourglass False
Me.ContUnitsTxt = Null
Me.ContValueTxt = Null
Forms!PlanFrm![PlanContributedUnitsFrm].Requery
Else
Cancel = True
Exit Sub
End If
Exit_AddContributionBtn:
Exit Sub
Err_AddContributionBtn:
MsgBox Err.Number & Err.Description
Resume Exit_AddContributionBtn
End Sub
For DLookup():
varCurrency = DLookup("NetAssetValue", "NAV_Tbl", "NAV_Date >= #" & Format(CurrentNAVDate, "yyyy-mm-dd") & "#")

Related

Quick Filters in a Split Form Datasheet

Creating an access database for work. Users will use a split form with only the datasheet visible to review and manipulate numeric data. On the form I have built in quick filters that consist of of textboxes in which the values are either raised or lowered with arrow buttons that have on-click events. I currently have the text boxes linked to the recordsource query criteria.
With all of this stated, the problem that I am having is that I need the filter to act in the following manner:
If the value in the text box equals 0 I want to see all records. If the value is greater than 0, I want all records greater than or equal to the text box value to show. Finally, if the value in the text box is less than 0, I want to see all values less than or equal to 0.
I have considered trying to use multiple sql statements but I typically have about 3 of these quick filters on each form, and my project will eventually have about 20 forms. That is a lot of sql statements to potentially mess up.
What ideas do you guys have to solve this problem? I really need help.
If you only have 1 textbox on each form, then you may want to consider using the form's Filter property:
Private Sub txtFilter_AfterUpdate()
On Error GoTo E_Handle
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
Me.Filter = "Price<=0"
Me.FilterOn = True
Case 0
Me.FilterOn = False
Case Is > 0
Me.Filter = "Price>=" & Me!txtFilter
Me.FilterOn = True
End Select
End If
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
If need to have multiple filters, then consider moving the filter creation to a procedure by itself that handles all cases, and just call this procedure from each text box. You may have to think about the logic here of what happens if one text box is 0 (No filter), but another text box is 5 (display all values >= 5) and another text box is -3 (display all values <= 0):
Private Sub txtFilter2_AfterUpdate()
On Error GoTo E_Handle
Call sFilterForm2
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!txtFilter2_AfterUpdate", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Private Sub sFilterForm2()
On Error GoTo E_Handle
Dim strSQL As String
If Not IsNull(Me!txtFilter) Then
If IsNumeric(Me!txtFilter) Then
Select Case Me!txtFilter
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter
End Select
End If
End If
If Not IsNull(Me!txtFilter2) Then
If IsNumeric(Me!txtFilter2) Then
Select Case Me!txtFilter2
Case Is < 0
strSQL = " AND Price<=0 "
Case 0
Case Is > 0
strSQL = strSQL & " AND Price>=" & Me!txtFilter2
End Select
End If
End If
If Len(strSQL) > 0 Then
strSQL = Mid(strSQL, 5)
Me.Filter = strSQL
Me.FilterOn = True
Else
Me.FilterOn = False
End If
sExit:
On Error Resume Next
Exit Sub
E_Handle:
MsgBox Err.Description & vbCrLf & vbCrLf & "Form2!sFilterForm2", vbOKOnly + vbCritical, "Error: " & Err.Number
Resume sExit
End Sub
Regards
Given a text box control CriteriaField1 and a corresponding field to filter Field1 in the record source I would use this:
Private Sub CriteriaField1_AfterUpdate()
Const FIELD_NAME As String = "Field1"
Dim value As Long
value = Nz(Me("Criteria" & FIELD_NAME).Value, 0)
Dim condition As String
condition = FIELD_NAME & IIf(value < 0, " <= 0", " >= " & value)
Me.FilterOn = value <> 0
End Sub
If you need to combine multiple fields to a filter condition, you would have to use and set form-global variables instead of local ones.
You could call a helper function which holds a set of arrays and builds and sets the filter dynamically:
Private Sub Filter0_AfterUpdate()
SetFilter
End Sub
Private Sub Filter1_AfterUpdate()
SetFilter
End Sub
Private Sub Filter2_AfterUpdate()
SetFilter
End Sub
Private Sub SetFilter()
Dim FieldNames() As Variant
Dim TextboxNames() As Variant
Dim Criteria() As String
Dim Index As Integer
Dim Value As Long
' Specify the field names to filter on.
FieldNames = Array("Quantity", "Stock", "Size")
' Specify the names of the textboxes to enter filter values.
TextboxNames() = Array("Filter0", "Filter1", "Filter2")
ReDim Criteria(LBound(TextboxNames) To UBound(TextboxNames))
For Index = LBound(Criteria) To UBound(Criteria)
Value = Val(Nz(Me(TextboxNames(Index)).Value))
If Value < 0 Then
Criteria(Index) = FieldNames(Index) & " <= 0"
ElseIf Value > 0 Then
Criteria(Index) = FieldNames(Index) & " >= " & CStr(Value)
Else
Criteria(Index) = "True"
End If
Next
' Assemble and apply the filter.
Me.Filter = Join(Criteria, " And ")
Me.FilterOn = True
Debug.Print Me.Filter
End Sub

Visual Basic- I've got an error

It says error on Line 32....
The given code is of visual basic. I guess I have got everything correct but have no clue what I did wrong. when I checked about it in the console it said line 32
Module Module1
Sub Main()
Dim isInKG As Boolean = Nothing
Dim canDrink As Boolean = Nothing
Dim isSeniorCitizen As Boolean = Nothing
Console.WriteLine("what is your age?")
Dim age As Integer = Console.ReadLine()
Dim outcomeKG As String = Nothing
Dim outcomeSenior As String = Nothing
Dim outcomeDrink As String = Nothing
If age <> 5 Then
isInKG = False
outcomeKG = "You arent in KG"
Else
isInKG = True
outcomeKG = "You are in KG"
End If
If age >= 65 Then
isSeniorCitizen = True
outcomeSenior = "You are a Senior Citizen"
Else
isSeniorCitizen = False
outcomeSenior = "You are a Junior Citizen"
End If
If age >= 21 Then
canDrink = True
outcomeDrink = "Go and get drunk"
Else
canDrink = False
outcomeDrink = "Sorry Kiddo Not until 21 "
End If
Console.WriteLine(outcomeDrink & " " & outcomeKG & " " & outcomeSenior " " &)
Console.ReadLine()
End Sub
End Module
Third row from the bottom has wrong order...
try this
Console.WriteLine(outcomeDrink & " " & outcomeKG & " " & outcomeSenior & " ")

Unable to add records more than 28 in access database

I am making my first project using vb.net and access. I am trying to develop a project in which the data of patients of the is added from different counters.it works fine till 22nd or 23rd record entered. after that adding new record over writes the last saved record.
to check the database i deleted some record (say after deletion there are 13 records left in the database) and tried to add new record, it gives the same problem, the 13th record is overwritten by the new record.
i deleted all the records and tried to add new record, the first record successfully entered but after that new record entry over writes the last (only) record.
i'm unable to understand the problem
code for saving data is
Private Sub Save()
'Dim st As String
Dim str As String
btnSave_Click = False
str = check
If Not str = "" Then
MsgBox(str, vbInformation, "Patient Registration")
btnSave_Click = False
Exit Sub
End If
If conn.State = 0 Then
Module1.openConnection()
End If
If Not rsDept Is Nothing Then
If rsDept.State = 0 Then
Call openRecordset("SELECT * FROM tblDept", rsDept)
End If
Else
Call openRecordset("SELECT * FROM tblDept", rsDept)
End If
If Not rsData Is Nothing Then
If rsData.State = 0 Then
Call openRecordset("Select * from tblPatientRecord", rsData)
End If
Else
Call openRecordset("Select * from tblPatientRecord", rsData)
End If
conn.BeginTrans()
On Error GoTo ProcError
If Not (rsData.BOF And rsData.EOF) Then
rsData.MoveLast()
Call addData(rsData)
Else
Call addData(rsData)
End If
conn.CommitTrans()
MsgBox("Patient's Record Saved Successfully...!", MsgBoxStyle.Information, "Patient Registration")
Call loadDataListview()
Call fieldDisable()
Call Disable_SearchButtons()
btnSave_Click = True
comDepart.Enabled = False
conn.Close()
ProcError:
If Err.Number <> 0 Then
conn.RollbackTrans()
MsgBox(Err.Number & " " & Err.Description)
Call addNewR()
Exit Sub
End If
End Sub
Private Sub addData(rData As ADODB.Recordset)
Dim rsPaymentType As New ADODB.Recordset
'Dim str As String
If Not (rData.BOF And rsData.EOF) Then
rData.MoveFirst()
If rData.RecordCount > 0 Then
Do
If txthn.Text = rData("hNumber").Value Then
Call addVisit()
conn.Execute("update tblPatientRecord set visitNo = '" & vNo.Text & "' where hNumber = '" & txthn.Text & "'")
Call fieldEnable()
Exit Sub
End If
rData.MoveNext()
Loop Until rData.EOF
End If
End If
rData.AddNew()
rData("hNumber").Value = txthn.Text
rData("fName").Value = txtfn.Text
rData("contactNo").Value = txtContact.Text
rData("address").Value = txtaddress.Text
rData("cnic").Value = txtcnic.Text
'rData("cnic").Value = rCNIC()
rsData("visitNo").Value = vNo.Text
rsData("cnicSD").Value = comSD.Text
''Add gender as selected
If radmale.Checked = True Then
rData("gender").Value = radmale.Text
ElseIf radfemale.Checked = True Then
rData("gender").Value = radfemale.Text
Else
rData("gender").Value = " - "
End If
If txtAge.Text < 105 Or Year(dtAgePicker.Value) < 1915 Then
Call addAge()
'MsgBox("data of tblAge added")
Else
MsgBox("Please Enter Correct Age ", vbCritical, "")
txtAge.Select()
Exit Sub
End If
If comRelation.Text = "Select Relation with Patient" Or comRelation.Text = "" Then
comRelation.Text = "Not Selected"
End If
If txtfh.Text = "" Then
txtfh.Text = "Not Given"
End If
Call addRelation()
'Save Department ID as selected
If comDepart.Text <> "Select Department" Then
Call addVisit()
'MsgBox("data of tblVisit added")
Else
MsgBox("Please Enter the Department ", vbCritical, "")
comDepart.Select()
Exit Sub
End If
If Not rsPaymentType Is Nothing Then
If rsPaymentType.State = 0 Then
Call openRecordset("Select * from tblPaymentType", rsPaymentType)
'MsgBox("Patient record is open" & rsData.State)
End If
Else
Call openRecordset("Select * from tblPaymentType", rsPaymentType)
'MsgBox("Patient record is open")
End If
If Not (rsPaymentType.BOF And rsPaymentType.EOF) Then
rsPaymentType.MoveFirst()
Do
If rsPaymentType("paymentType").Value = comPaymentType.Text Then
rData("paymentType").Value = rsPaymentType("paymentTypeID").Value
Exit Do
Else
rData("paymentType").Value = 0
End If
rsPaymentType.MoveNext()
Loop Until rsPaymentType.EOF
End If
rsData.Update()
End Sub
Public Function h_N0_Generator(rs As ADODB.Recordset) As String
Dim str, p1() As String
Dim auto_long As Long
Dim hMonth As String
Dim strCounter As String, temp As String
'this counter file is added to make the hNumber unique for multiple counter /* in the file counter number is added and have respective counter number only*/
FileOpen(FileNum, "C048ounter.txt", OpenMode.Input)
strCounter = LineInput(FileNum)
FileClose(FileNum)
If strCounter = "" Then
strCounter = "1"
End If
hMonth = Month(Now).ToString("D2")
If (rs.EOF And rs.BOF) Then
h_N0_Generator = "NIRM-" & Year(Now) & "-" & hMonth & "-" & "00000" & strCounter
Else
rs.MoveLast()
str = rs("HNumber").Value
p1 = str.Split("-")
' check if the current month is the same as in last stored Hospital No or not
'if yes the last five digits increment otherwise it restarts with 0
If p1(2) = Month(Now) And p1(1) = Year(Now) Then
temp = Right(rs(0).Value, 6)
auto_long = Left(temp, 5) + 1
h_N0_Generator = "NIRM-" & Year(Now) & "-" & hMonth & "-" & Right("00000" & auto_long, 5) & strCounter
Else
h_N0_Generator = "NIRM-" & Year(Now) & "-" & hMonth & "-" & "00000" & strCounter
End If
End If
'Return auto_num
End Function

Access VBA Filter RecordCount not properly updating value

I have a form that I have built a filter search on that runs "after_update". When the filter results in no records the form fails and shows blank. To get around this i found several posts recommending to add a "RecordCount" and use an "if" statement to then trigger the filter if it is not <1 or =0. My issue is that the value of the RecordCount seems to be showing the # of records from the last ran filter selections, not the current filter. I have tried several methods to "requery" and update the value of the RecordCount after the filter is applied but I cant get it to update as i intend it to work.
Example:
Filter 1: Results in 14 records, the debug.print recordcount displays 1
Filter 2: Results in 22 records, the debug.print recordcount displays 14
Filter 3: Results in 0 records, Form fails, the debug.print recordcount displays 22
Code:
Private Sub ApplyFilterBtn_Click()
On Error GoTo Err_ApplyFilterBtn_Click
Dim stFilter As String
stFilter = ""
If Nz(Me.FilterOwner, "") <> "" Then
stFilter = stFilter & "[MachineOwner] = " & Me.FilterOwner & " AND "
End If
If Nz(Me.FilterType, "") <> "" Then
stFilter = stFilter & "[MachineType] = " & Me.FilterType & " AND "
End If
If Nz(Me.FilterSubType, "") <> "" Then
stFilter = stFilter & "[MachineSubType] = " & Me.FilterSubType & " AND "
End If
If Nz(Me.FilterMake, "") <> "" Then
stFilter = stFilter & "[Make] Like '" & Me.FilterMake & "' AND "
End If
If Nz(Me.FilterModel, "") <> "" Then
stFilter = stFilter & "[Model] Like '*" & Me.FilterModel & "*' AND "
End If
If Nz(Me.FilterSN, "") <> "" Then
stFilter = stFilter & "[SN] Like '" & Me.FilterSN & "' AND "
End If
If Nz(Me.FilterStatus, "") <> "" Then
stFilter = stFilter & "[NewStatus] = " & Me.FilterStatus & " AND "
End If
If stFilter <> "" Then
stFilter = Left(stFilter, Len(stFilter) - 5) 'Remove the extra AND
'<<<<<<<Issue starts here<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
Me.Recordset.Clone
Me.RecordsetClone.Filter = stFilter
Me.RecordsetClone.MoveLast
' Me.RecordsetClone.MoveNext 'Tried this - did not help
' Me.RecordsetClone.Requery 'tried this - did not help
' Me.Filter = stFilter ' Tries this - did not help
'debugging to see value of RecordCount
Debug.Print stFilter
Debug.Print Me.RecordsetClone.RecordCount
'>>>>>> Recordsetclone.RecordCount value not refreshing properly above, shows previously called filter record count
If Me.RecordsetClone.RecordCount < 1 Then ' no records, don't filter
'If Not (Me.RecordsetClone.BOF And Me.RecordsetClone.EOF) Then 'work around attempt 2 - failed
'If Me.NoMatch Then 'Work around Attempt 3 - failed
RemoveFilterBtn_Click ' Call sub that Clears filter
MsgBox "Filter Results in No records", vbOKOnly, "No Results"
Else ' there are records, turn on filter
Me.Filter = stFilter
Me.FilterOn = True
End If 'Me.RecordCount < 1
Else
Me.FilterOn = False
RemoveFilterBtn_Click ' Clears filter
End If 'stFilter <> ""
Exit_ApplyFilterBtn_Click:
Exit Sub
Err_ApplyFilterBtn_Click:
MsgBox Err.Description
Resume Exit_ApplyFilterBtn_Click
End Sub
Private Sub RemoveFilterBtn_Click()
On Error GoTo Err_RemoveFilterBtn_Click
'Sets Filter Field Values to Blank
Me.FilterOwner = ""
Me.FilterType = ""
Me.FilterMake = ""
Me.FilterModel = ""
Me.FilterSN = ""
Me.FilterStatus = ""
Me.FilterSubType = ""
'Removes Filter
Me.Filter = ""
Me.FilterOn = False
Exit_RemoveFilterBtn_Click:
Exit Sub
Err_RemoveFilterBtn_Click:
MsgBox Err.Description
Resume Exit_RemoveFilterBtn_Click
End Sub
It is simpler but you need the right syntax:
Dim rst As DAO.Recordset
Dim rstFiltered As DAO.Recordset
Set rst = Me.RecordsetClone
rst.Filter = stFilter
Set rstFiltered = rst.OpenRecordset()
If rstFiltered.RecordCount > 0 Then
' Do stuff.
End If
rstFiltered.Close
Set rstFiltered = Nothing
Set rst = Nothing

Scan image in vba with cannon scanner not work

I have a vba code that scan image from scanner , the code works and doesnt have any problem with type hp an brother scanner but when I used it with canon can not find the scanner and send message no wia device. How can solve this problem
Private Sub Command10_Click()
Const wiaFormatJPEG = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
On Error GoTo Handle_Err
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 ' to activate the scanner to start scan
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"
DoCmd.SetWarnings False
DoCmd.RunSQL "delete from scantemp"
DoCmd.SetWarnings False
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
Set Scanner = Dialog1.ShowSelectDevice(WIA.WiaDeviceType.ScannerDeviceType, True, False)
Set img = Dialog1.ShowTransfer(Scanner.Items(1), wiaFormatJPEG, True)
strFileJPG = ""
intPages = intPages + 1
strFileJPG = "\\User-pc\saveimage\" & num & Trim(str(intPages)) & ".jpg"
img.SaveFile (strFileJPG)
DoCmd.RunSQL "insert into scantemp (picture) values ('" & strFileJPG & "')"
DoCmd.SetWarnings False
Set Scanner = Nothing
Set img = Nothing
' strFileJPG = ""
'Prompt user if there are additional pages to scan
ContScan = MsgBox("?save another page ", vbQuestion + vbYesNoCancel)
If ContScan = vbNo Then
blnContScan = False
ElseIf ContScan = vbCancel Then
DoCmd.RunSQL "delete from scantemp where picture = '" & strFileJPG & "'"
End If
'''''''''''''''
Loop
Dim Image_Path As String
GoTo StartPDFConversion
StartPDFConversion:
Dim s As String
strFilePDF = "\\User-pc\saveimage\" & (num) & ".pdf"
RptName = "rptScan"
DoCmd.OpenReport RptName, acViewReport, , , acHidden
DoCmd.Close acReport, RptName, acSaveYes
DoCmd.OutputTo acOutputReport, RptName, acFormatPDF, strFilePDF
Me.imgp = strFilePDF
DoCmd.RunSQL "delete from scantemp" 'delete all data from table scantemp after converted it to pdf
'/*******************************\
'/********************************************\
Handle_Exit:
Exit Sub
Handle_Err:
Select Case Err.Number
Case 2501
Resume Handle_Exit
Case Else
MsgBox "the." & 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
Exit Sub
End Sub
Option Compare Database
Private Declare Function TWAIN_AcquireToFilename Lib "TWAIN32d.DLL" (ByVal hwndApp As Long, ByVal bmpFileName As String) As Integer
Private Declare Function TWAIN_IsAvailable Lib "TWAIN32d.DLL" () As Long
Private Declare Function TWAIN_SelectImageSource Lib "TWAIN32d.DLL" (ByVal hwndApp As Long) As Long
Private Sub cmdScan_Click()
Dim Ret As Long, PictureFile As String
Dim intPages As Integer
Dim blnContScan As Boolean
Dim ContScan As String 'msgbox to chk if more pages are to be scanned
blnContScan = True
intPages = 0
Do While blnContScan = True
DPI = 200
PP = 1 'No of pages
intPages = intPages + 1
PictureFile = CurrentProject.Path & "\" & myfolder & "\" & Me.number & Trim(Str(intPages)) & ".jpg"
Ret = TWAIN_AcquireToFilename(Me.hwnd, PictureFile)
ContScan = MsgBox("? ÍÝÙ ÕæÑÉ ÇÎÑì ", vbQuestion + vbYesNo, "ÊäÈíÉ")
If ContScan = vbNo Then
blnContScan = False
End If
Loop