Private Sub Command2_Click()
Dim rs As ADODB.Recordset, oBookMark As Object, dbConn As ADODB.Connection, strBMName As String
Dim oWord As Word.Application, oDocMain As Word.Document, oDocTemp As Word.Document
Dim strTmp As String, strTemplateFileName As String, intVNumber As Long, blnIsOpen As Boolean
Dim intError As Integer
Dim docfilevI As String, docfilepI As String, docfilevP As String, docfilepP As String
If Not Val(Me.txtStartNo) > 0 Then
MsgBox "You have not filled in a starting number for the " & _
"vouchers", vbExclamation + vbOKOnly + vbDefaultButton1, _
"Missing Information"
Exit Sub
Else
appPath = Left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
docfilevI = appPath & "Config\Voucher mosad standard.doc" 'With voucher
docfilepI = appPath & "Config\Blank mosad standard.doc" 'Without voucher
docfilevP = appPath & "Config\Voucher cause standard.doc" 'With voucher
docfilepP = appPath & "Config\Blank cause standard.doc" 'Without voucher
intVNumber = Me.txtStartNo
Set rs = New ADODB.Recordset
Set dbConn = CurrentProject.Connection
Dim MyString As String
Dim myStringNew As String
Open "c:\temp\dg\temps.tmp" For Input As #1 ' Open file for input.
Do While Not EOF(1) ' Loop until end of file.
Input #1, MyString ' Read data into variable
Debug.Print MyString ' Print data to the Immediate window.
Loop
Close #1 ' Close file.
MyString = Replace(MyString, "%", "")
'MyString = Replace(MyString, Chr(34) & "%", "*")
If InStr(MyString, ProfileGetItem("report8", "table", "nothing", appPath & "config\control.ini")) < 1 Then
MsgBox "Please return to the search interface and select " & _
"the correct view before selecting reports again", _
vbInformation + vbOKOnly + vbDefaultButton1, "Missing information"
Exit Sub
End If
myStringNew = Left(MyString, InStr(MyString, "FROM") - 1)
myStringNew = myStringNew & "," & ProfileGetItem("report8", "select", "nothing", appPath & "config\control.ini")
myStringNew = myStringNew & " FROM " & ProfileGetItem("report8", "table", "nothing", appPath & "config\control.ini")
If InStr(MyString, "WHERE") < 1 Then
myStringNew = myStringNew & " WHERE " & ProfileGetItem("report8", "where", "", appPath & "config\control.ini")
Else
Dim strWhere As String
strWhere = Right(MyString, Len(MyString) - Len(Left(MyString, InStr(MyString, "WHERE") - 1)))
strWhere = Left(strWhere, InStr(strWhere, "ORDER BY") - 1)
'myStringNew = myStringNew & " " & strWhere
myStringNew = myStringNew & " " & strWhere & " AND " & ProfileGetItem("report8", "where", "", appPath & "config\control.ini")
End If
myStringNew = myStringNew & " ORDER BY " & ProfileGetItem("report8", "orderby", "nothing", appPath & "config\control.ini")
MyString = myStringNew
Debug.Print MyString ' Print data to the Immediate window.
'rs.Open "getRemmitance", dbConn, adOpenStatic, adLockPessimistic
rs.Open MyString, dbConn, adOpenStatic, adLockPessimistic
rs.Filter = "locked <>" & 1
rs.Requery
If rs.RecordCount = 0 Then
MsgBox "There are no remittance slips to process. " & _
"Check that those unlocked are within date.", _
vbInformation + vbOKOnly + vbDefaultButton1, "No records found!"
DoCmd.Close acForm, "frmremmitance", acSaveYes
Exit Sub
End If
rs.Filter = ""
rs.Requery
rs.Filter = "mpay='Voucher' And Locked <>" & 1
rs.Requery
strTmp = rs.RecordCount & " Vouchers to be printed" & vbCr
'rs.Filter = ""
rs.Filter = "mpay<>'Voucher' And mpay<>'' And mpay<> null and locked <>" & 1
rs.Requery
strTmp = strTmp & rs.RecordCount & " other notes to be printed" & vbCr & _
"Please insert correct number of required stationery"
MsgBox (strTmp)
'rs.Filter = ""
rs.Filter = "locked <>" & 1
rs.Requery
Me.cdlSaveAs.CancelError = True
On Error GoTo docErrorHandle:
Me.cdlSaveAs.ShowSave
On Error GoTo 0
rs.MoveFirst
Set oWord = StartWord(blnIsOpen)
Set oDocMain = oWord.Documents.Add
Do While Not rs.EOF
If rs("mpay") = "Voucher" Then
If Len(rs("ijname")) > 0 Then
strTemplateFileName = docfilevI
Else
strTemplateFileName = docfilevP
End If
If Me.chkTest = 0 Then
rs("cnum") = intVNumber
rs.Update
End If
intVNumber = intVNumber + 1
Else
If Len(rs("ijname")) > 0 Then
strTemplateFileName = docfilepI
Else
strTemplateFileName = docfilepP
End If
End If
Debug.Print strTemplateFileName
If Not IsNull(rs("greeting")) Then
If rs("greeting") <> "" Then strTemplateFileName = rs("greeting")
End If
Debug.Print rs("id")
Debug.Print rs("greeting")
On Error GoTo docErrorHandle:
Set oDocTemp = oWord.Documents.Open(strTemplateFileName, , True)
On Error GoTo 0
oDocTemp.Application.Visible = True
For Each oBookMark In oDocTemp.Bookmarks
If ((Val(Right(oBookMark.Name, 1)) > 0) And (Mid(oBookMark.Name, Len(oBookMark.Name) - 1, 1) = "_")) Then
strBMName = Left(oBookMark.Name, Len(oBookMark.Name) - 2)
Else
strBMName = oBookMark.Name
End If
If Left(strBMName, 5) <> "TOTXT" Then
If IsNull(rs(strBMName).Value) Then
oBookMark.Range.Text = ""
Else
oBookMark.Range.Text = rs(strBMName).Value
End If
Else
If IsNull(rs(Mid(strBMName, 6)).Value) Then
oBookMark.Range.Text = ""
Else
oBookMark.Range.Text = SpellNumber(rs(Mid(strBMName, 6)).Value)
End If
End If
Next
'oDocTemp.Activate
oDocTemp.Application.Selection.WholeStory
oDocTemp.Application.Selection.Copy
oDocMain.Activate
oDocMain.Application.Selection.PasteAndFormat (wdPasteDefault)
oDocMain.SaveAs cdlSaveAs.FileName
'this locks only vouchers
'If rs("mpay") = "Voucher" Then rs("locked") = 1
Me.txtStartNo = intVNumber
'this locks all printed matter if test checkbox is unticked
If Me.chkTest = 0 Then
rs("locked") = 1
'save the voucher template
rs("greeting") = strTemplateFileName
rs.Update
Else
End If
'oDocMain.Application.Selection.InsertBreak Type:=wdPageBreak
oDocTemp.Close (False)
endofLoop:
rs.MoveNext
If Not rs.EOF Then oDocMain.Application.Selection.InsertBreak Type:=wdPageBreak
Loop
Me.ActiveControl.SetFocus
If intError > 0 Then MsgBox intError & " documents failed-Please check file source exists and is correctly named!", vbCritical
'If MsgBox("do you want to print this Document?", vbYesNo) = vbYes Then oDocMain.PrintOut
'If blnIsOpen Then
' oDocMain.Close
'Else
' oDocMain.Application.Quit
'End If
End If
rs.Close
Set rs = Nothing
DoCmd.Close
Exit Sub
docErrorHandle:
Debug.Print "Error: "; Err.Number
Select Case Err.Number
Case 5174 'Template file not found
Case 5273
intError = intError + 1
Err.Clear
Resume endofLoop:
Case cdlCancel 'Cancel pressed
Exit Sub
End Select
Resume Next
'Close Form
'DoCmd.Close
End Sub
