aimeec
asked on
Access Remains open after a Mailmerge using Visual basic
I have a VB6 program that: opens one access97 database. Purges the second access database, Gets some data and puts it into the second access97 database. And does several mail merges into different templates from the second database.
The second database opens itself in an access window and stays open. This program runs everyday and if you forget to check the server, many instances of the access database remain open - hogging resources.
I have tried DBase.close, recordSet.close, WordApp.close.
I have other programs which do similar things but dont open the DB window. and I cant see the difference between it and the other program. I dont know alot about VB
All help is greatly appreciated.
The second database opens itself in an access window and stays open. This program runs everyday and if you forget to check the server, many instances of the access database remain open - hogging resources.
I have tried DBase.close, recordSet.close, WordApp.close.
I have other programs which do similar things but dont open the DB window. and I cant see the difference between it and the other program. I dont know alot about VB
All help is greatly appreciated.
SOLUTION
![Avatar of Guy Hengel [angelIII / a3]](https://filedb.experts-exchange.com/files/public/2013/11/25/ddbe0ea6-aa6e-4279-b781-57b735dd3ea0.jpeg){kind=small}
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Here is the code. I cant provide the database, ini file or templates.
The tempDatabase opens when this line of code executes
wdApp.Documents.Open (sTemplateName)
which is line 17 inside the Sub
Public Sub MergeLetter(sSQL As String, sDocTemplate As String, sDocFinal As String, sFormalName As String)
I hope someone can help
**************************
Option Explicit
Dim sWorkLine1 As String
Dim sGiven As String
Dim sSurname As String
Dim sMemberName As String
Dim lMemberNo As Long
Dim lFullMemberNo As Double
Dim sCardNo As String
Dim sTitle As String
Dim lTranCode As Long
Dim sNewCardTranCode As String
Dim sAddress1 As String
Dim sAddress2 As String
Dim sAddress3 As String
Dim sAddress4 As String
Dim sPostCode As String
Dim sBranchName As String
Dim lBrandNo As Long
Dim sPLine As String
Dim sSP As String
Dim sOutFileHDR As String
Dim iPrintFlag As Integer
Dim bOK As Boolean
Dim sWorkLine2 As String
Dim sWorkLine3 As String
Dim sWorkLine4 As String
Dim iTempType As Integer
Dim iHdr As Integer
Dim sReportDate As String
Dim lCnt As Long
Dim sEmailDeleteInBox As String
Dim sTemplatePath As String
Dim sTemplateName As String
Dim sNewTemplateName As String
Dim sRenewalTemplateName As String
Dim sNewPostTemplateName As String
Dim sRenewalPostTemplateName As String
Dim sRegisterTemplateName As String
Dim sRegisterTemplateName2 As String
Dim sOutPutPath As String
Dim sRegisterReport1 As String
Dim sRegisterReport2 As String
Dim sNewCardDoc As String
Dim sRenewalCardDoc As String
Dim sNewCardPostDoc As String
Dim sRenewalCardPostDoc As String
Dim sBrandReference As String
Dim sBrandWebAddress As String
Dim sBrandname As String
Dim sEmailNewCardString As String
Dim sEmailRenewalCardString As String
Dim sEmailPostNewCardString As String
Dim sEmailPostRenewalCardStrin
Dim sCardReportPath As String
Dim sCardReport As String
Dim sDBFile As String
Dim sTempDB As String
Dim lBRNo As Long
Dim lHoldBRNo As Long
Dim sProcessDate As String
Dim sReturnDate As String
Dim sSentDate As String
Dim lCardCount As Long
Dim sRegisterNo As String
Dim sErrorMailTo As String
Dim sMailDocsTo As String
'Dim sEmailSubject As String
'Dim sEmailText As String
Dim sBrandImage As String
Dim sBrandImageRef As String
Dim Cnt As Long
Dim ErrorNo As Long
Dim a$
Dim CRLF$
Public Function RemoveChars(TempString)
Debug_Print "RemoveChars(" & TempString & ")"
Dim comma As Integer
If Left(TempString, 1) = Chr(34) And Right(TempString, 1) = Chr(34) Then
TempString = Mid$(TempString, 2, Len(TempString) - 2)
End If
If Left(TempString, 1) = "," Then
TempString = Mid$(TempString, 2, Len(TempString))
End If
If Right(TempString, 1) = "," Then
TempString = Mid$(TempString, 1, Len(TempString) - 1)
End If
comma = InStr(1, TempString, ",")
Do While comma
TempString = Mid$(TempString, 1, comma - 1) & " " & Mid$(TempString, comma + 1, Len(TempString))
comma = InStr(1, TempString, ",")
Loop
RemoveChars = TempString
End Function
Public Function ShellandWait(ExeFullPath As String, Optional TimeOutValue As Long = 0) As Boolean
Debug_Print "ShellAndWait(" & ExeFullPath & "," & TimeOutValue & ")", 2
Dim lInst As Long
Dim lStart As Long
Dim lTimetoQuit As Long
Dim sExeName As String
Dim lProcessId As Long
Dim lExitCode As Long
Dim bPastMidnight As Boolean
On Error GoTo ErrorHandler
lStart = CLng(Timer)
sExeName = ExeFullPath
'Deal with timeout being reset at Midnight
If TimeOutValue > 0 Then
If lStart + TimeOutValue < 86400 Then
lTimetoQuit = lStart + TimeOutValue
Else
lTimetoQuit = (lStart - 86400) + TimeOutValue
bPastMidnight = True
End If
End If
lInst = Shell(sExeName, vbMinimizedNoFocus)
lProcessId = OpenProcess(PROCESS_QUERY_
Do
Call GetExitCodeProcess(lProces
DoEvents
If TimeOutValue And Timer > lTimetoQuit Then
If bPastMidnight Then
If Timer < lStart Then Exit Do
Else
Exit Do
End If
End If
Loop While lExitCode = STATUS_PENDING
ShellandWait = True
Exit Function
ErrorHandler:
ShellandWait = False
On Error Resume Next
End Function
Private Sub ProcessFile()
Debug_Print "ProcessFile()", 2
'*************************
' This procedure will process the CORDR report file
' and creates register sheets and creates letters to be sent to members.
' (For card holders ONLY)
' The register sheets and letters are 'mailed' to nominated staff.
'*************************
Dim bFirst As Boolean
Dim x As String
On Error Resume Next
Dim sModCardNo As String
Dim sVerifiedByA As String
bFirst = True
iPrintFlag = False
Err.Clear
'Stop
'sCardReport
'sTemplateName = "c:\temp.doc"
tblCards.Index = "Card No"
tblMember.Index = "Customer No"
tblTitleCodes.Index = "PrimaryKey"
tblBranchMaster.Index = "PrimaryKey"
tblBrand.Index = "PrimaryKey"
If tblCards.RecordCount > 0 Then
Debug_Print "ProcessFile() - tblCards RecordCount > 0", 3
tblCards.MoveFirst
LblAction.Caption = "Clearing Cards Table"
Do Until tblCards.EOF
tblCards.Delete
tblCards.MoveNext
Loop
End If
On Error Resume Next
bOK = True
Open sCardReport For Input As #1
If Err = 0 Then
Debug_Print "ProcessFile() - Opened Card Report: " & sCardReport, 3
On Error GoTo 0
Line Input #1, sWorkLine1
Debug_Print "ProcessFile() - Workline: " & sWorkLine1, 3
Do Until EOF(1)
If bFirst Then
Debug_Print "ProcessFile() - First Line", 3
If Left$(sWorkLine1, 11) = "REPORT NAME" Then
sProcessDate = Format(Mid$(sWorkLine1, 156, 10), "DD MMM YYYY")
bFirst = False
End If
End If
'If IsNumeric(Left$(sWorkLine1
'If Mid$(sWorkLine1, 9, 6) <> "584002" Then
'sCardNo = Mid$(sWorkLine1, 9, 19)
'lMemberNo = Val(Mid$(sWorkLine1, 30, 17))
'sMemberName = Mid$(sWorkLine1, 65, 26)
'lTranCode = Val(Mid$(sWorkLine1, 93, 6))
'lBRNo = Val(Mid$(sWorkLine1, 103, 6))
'Stop
If IsNumeric(Left$(sWorkLine1
If Mid$(sWorkLine1, 9, 6) <> "584002" Then
sCardNo = Mid$(sWorkLine1, 9, 19)
Debug_Print "ProcessFile() - Card: " & sCardNo, 3
sModCardNo = Left(sCardNo, 4) & " XXXX XXXX " & Right(sCardNo, 4)
lFullMemberNo = Val(Mid$(sWorkLine1, 30, 17))
sMemberName = Mid$(sWorkLine1, 65, 26)
lTranCode = Val(Mid$(sWorkLine1, 93, 6))
lBRNo = Val(Mid$(sWorkLine1, 103, 6))
sVerifiedByA = Mid(sWorkLine1, 143, 11)
If lBRNo = 0 Then
lBRNo = lDefaultBrNo
End If
tblCards.Seek "=", sCardNo
tblMember.Seek "=", lFullMemberNo
If tblMember.NoMatch Then
sTitle = ""
sGiven = ""
sSurname = ""
sAddress1 = ""
sAddress2 = ""
sAddress3 = ""
sPostCode = ""
Else
tblTitleCodes.Seek "=", tblMember("Title code")
If tblTitleCodes.NoMatch Then
sTitle = ""
Else
sTitle = tblTitleCodes("Description
If sTitle = "DEFAULT" Then
sTitle = ""
End If
End If
' added 20060619
' we've modified the customer table to include parsed brand and member no,
' and also have a brand master table, meaning less ini file stuff
lMemberNo = tblMember("memberno")
lBrandNo = tblMember("brand")
' end addition
sGiven = tblMember("Given Name")
sSurname = tblMember("Surname")
If tblMember("Customer Type") = 2 Then
sSurname = sGiven & sSurname
sGiven = ""
End If
' Address 1 code change - 20030930
If IsNull(tblMember("Address Line 1")) Then
sAddress1 = ""
Else
sAddress1 = tblMember("Address Line 1")
End If
' Address 2 code change - 30092003
If IsNull(tblMember("Address Line 2")) Then
sAddress2 = ""
Else
sAddress2 = tblMember("Address Line 2")
End If
' Address 3 code change - 30092003
If IsNull(tblMember("Address Line 3")) Then
sAddress3 = ""
Else
sAddress3 = tblMember("Address Line 3")
End If
' Address 4 code change - 30092003
If IsNull(tblMember("Address Line 4")) Then
sAddress4 = ""
Else
sAddress4 = tblMember("Address Line 4")
End If
' Postcode code change - 30092003
If IsNull(tblMember("PostCode
sPostCode = ""
Else
sPostCode = tblMember("PostCode")
End If
'sAddress2 = tblMember("Address line 2")
'sAddress3 = tblMember("Address line 3")
'sAddress4 = tblMember("Address line 4")
'sPostCode = tblMember("PostCode")
End If
If tblCards.NoMatch Then
tblCards.AddNew
Debug_Print "ProcessFile() - Adding new card record to db", 3
tblCards("Real Card No") = sCardNo
tblCards("Card No") = sModCardNo
tblCards("Full Member No") = lFullMemberNo '---------------------
tblCards("Member No") = lMemberNo
tblCards("Name On Card") = sMemberName
tblCards("Title") = sTitle
tblCards("Init") = Left$(sGiven, 1)
tblCards("Given") = sGiven
tblCards("Surname") = sSurname
tblCards("Address 1") = sAddress1
tblCards("Address 2") = sAddress2
tblCards("Address 3") = sAddress3
tblCards("Address 4") = sAddress4
tblCards("PostCode") = sPostCode
tblCards("Branch No") = lBRNo
tblCards("Tran Code") = lTranCode
tblCards("Brand No") = lBrandNo
tblCards("VerifiedByA") = sVerifiedByA
tblBrand.Seek "=", lBrandNo
If tblBrand.NoMatch Then
Debug_Print "ProcessFile() - Unknown Brand: " & lBrandNo, 3
tblCards("BrandImageRef") = "Unknown"
tblCards("BrandWebAddress"
tblCards("BrandName") = "Unknown"
tblCards("BrandAdd1") = "Unknown"
tblCards("BrandAdd2") = "Unknown"
tblCards("BrandAdd3") = "Unknown"
tblCards("BrandCorr1") = "Unknown"
tblCards("BrandCorr2") = "Unknown"
tblCards("BrandCorr3") = "Unknown"
tblCards("BrandPhone1") = "Unknown"
tblCards("BrandPhone2") = "Unknown"
tblCards("BrandFax") = "Unknown"
tblCards("BrandEmail") = "Unknown"
Else
tblCards("BrandImageRef") = tblBrand("imageRef")
tblCards("BrandWebAddress"
tblCards("BrandName") = tblBrand("LongName")
tblCards("BrandAdd1") = tblBrand("address1")
tblCards("BrandAdd2") = tblBrand("address2")
tblCards("BrandAdd3") = tblBrand("address3")
tblCards("BrandCorr1") = tblBrand("corradd1")
tblCards("BrandCorr2") = tblBrand("corradd2")
tblCards("BrandCorr3") = tblBrand("corradd3")
tblCards("BrandPhone1") = tblBrand("phone1")
tblCards("BrandPhone2") = tblBrand("phone2")
tblCards("BrandFax") = tblBrand("fax")
tblCards("BrandEmail") = tblBrand("email")
End If
tblBranchMaster.Seek "=", lBRNo
If tblBranchMaster.NoMatch Then
sBranchName = "Unknown"
Else
sBranchName = tblBranchMaster("Branch Name")
End If
tblCards("Branch Name") = sBranchName
tblCards.Update
Debug_Print "ProcessFile() - tblCards.Update Method", 3
End If
End If
End If
Line Input #1, sWorkLine1
Loop
Close #1
Else
bOK = False
End If
On Error Resume Next
Debug_Print "ProcessFile() - End", 3
End Sub
Private Sub Form_Load()
'*************************
'The forms is displayed in screen to
'show progress of processing
'*************************
Dim stemp As String
MousePointer = vbHourglass
lblVersion.Caption = "v " & App.Major & "." & App.Minor & "." & App.Revision
LblAction.Caption = "Processing Card Order report"
LblCnt.Caption = lCnt
Debug_Open
Me.Show
stemp = LCase(GetINIString(kPROGNA
If stemp = "y" Then
gVisible = True
Else
gVisible = False
End If
Debug_Print "gVisible = " & gVisible, 3
DoEvents
Main
ProcessFile
CreateRegisterSheets
CreateLetters
MousePointer = vbNormal
'close database - 2006-10-31 - did not fix problem
DBTEMP.Close
Set DBTEMP = Nothing
End
End Sub
'Currently unused - winnt doesnt support this version of CDO.
Sub SendMailNew(ByVal sEmailSubject, ByVal sEmailText, ByVal sEmailRecipient, Optional ByVal sEmailAttachment)
Debug_Print "SendMailNew()", 2
Dim sServerName As String
Dim iConf As New CDO.Configuration
Dim myMsg As New CDO.Message
Dim Flds As ADODB.Fields
Set Flds = iConf.Fields
Dim sPickupPath As String
sPickupPath = GetINIString("Email", "CDOPickupDir", "C:\InetPub\mailroot\Picku
If Right(sPickupPath, 1) = "\" Then
sPickupPath = Left(sPickupPath, Len(sPickupPath) - 1)
End If
sServerName = GetINIString("Email", "EmailFrom", "MisServer")
Flds(cdoLanguageCode) = "en-au"
Flds(cdoSendUsingMethod) = cdoSendUsingPickup
Flds(cdoSMTPServerPickupDi
Flds(cdoFlushBuffersOnWrit
'Flds(cdoSensitivity) = cdoCompanyConfidential
Flds.Update
'make the configuration just set up apply to this mail message
Set myMsg.Configuration = iConf
With myMsg
'example below = "Display Name" <email@address.com>
.From = """" & sServerName & """ <" & kPROGNAME & "@cu.com.au>"
'this should be a comma seperated list of emails
.To = sEmailRecipient
.Subject = App.Title & " - " & Format(Date, "yyyy/mm/dd") & " - " & sEmailSubject
.TextBody = sEmailText
If Not IsMissing(sEmailAttachment
.AddAttachment sEmailAttachment
End If
End With
myMsg.Send
End Sub
Public Function SendMail(ByVal sEmailSubject, ByVal sEmailText, ByVal sEmailRecipient, Optional ByVal sEmailAttachment)
Debug_Print "SendMail(" & sEmailSubject & "," & sEmailText & "," & sEmailRecipient & "optionalattachement)", 2
Dim sEmailFrom As String
Dim sEmailFromPW As String
Dim sEmailTo As String
'Exit Function
sEmailFrom = GetINIString("Email", "EmailFrom", "")
sEmailFromPW = GetINIString("Email", "EmailFromPW", "")
Dim iSemiColon As Integer
Dim lErrorNo As Long
sEmailText = sEmailText & " "
MAPISession.UserName = sEmailFrom
MAPISession.Password = sEmailFromPW
On Error Resume Next
MAPISession.SignOn
DoEvents
If Err = 0 Then
MAPIMessage.SessionID = MAPISession.SessionID
sEmailTo = sEmailRecipient
If sEmailRecipient = "" Then
Exit Function
Else
iSemiColon = InStr(1, sEmailTo, ";")
Do While iSemiColon
sEmailRecipient = Mid$(sEmailTo, 1, iSemiColon - 1)
GoSub ComposeMessage
sEmailTo = Mid$(sEmailTo, iSemiColon + 1, Len(sEmailTo))
iSemiColon = InStr(1, sEmailTo, ";")
Loop
sEmailRecipient = sEmailTo
GoSub ComposeMessage
End If
MAPISession.SignOff
Else
bOK = False
End If
Exit Function
ComposeMessage:
On Error Resume Next
'On Error GoTo 0
MAPIMessage.Compose
MAPIMessage.RecipType = 1
MAPIMessage.RecipAddress = sEmailRecipient
MAPIMessage.AddressResolve
MAPIMessage.ResolveName
lErrorNo = Err
If lErrorNo = 0 Then
MAPIMessage.MsgSubject = sEmailSubject
MAPIMessage.MsgNoteText = sEmailText
If Not IsMissing(sEmailAttachment
MAPIMessage.AttachmentPosi
MAPIMessage.AttachmentPath
End If
'Send the message
MAPIMessage.Send False
End If
On Error GoTo 0
Return
End Function
Public Sub DocumentSetup(wdApp As Word.Application)
Debug_Print "DocumentSetup(wdapp)"
With wdApp.Selection.Font
.Name = "Arial"
.Size = 12
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.ColorIndex = wdAuto
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone
End With
End Sub
Public Sub DocumentHeader(wdApp As Word.Application)
Debug_Print "DocumentHeader(wdapp)", 2
sRegisterNo = lBRNo & "." & Format(Date, "dd.mm.yyyy")
'Stop
With wdApp.Selection
.ParagraphFormat.Alignment
'.TypeParagraph
.TypeText sBranchName & " (" & lBRNo & ")" & " - CORDR Report Date: " & sProcessDate '"Y(5) - 29/5/2002"
.TypeParagraph
.TypeParagraph
'.TypeText "Sent Date: " & sSentDate
'.TypeParagraph
'.TypeText "Return Date: " & sReturnDate
'.TypeParagraph
.TypeText "Register Number = " & sRegisterNo
.TypeParagraph
.TypeParagraph
.Font.Size = 10
'.Tables.Add .Range, 8, 8
.Tables.Add .Range, 1, 7
.Tables(1).Rows.SetLeftInd
.TypeText Text:="Branch Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Member Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Card Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Card Name"
.MoveRight Unit:=wdCell
.TypeText Text:="Letter Completed and on file"
.MoveRight Unit:=wdCell
.TypeText Text:="Date/Branch Card forwarded to: (Complete if sending to another branch for collection)"
.MoveRight Unit:=wdCell
.TypeText Text:="Issuing Staff Member Sig & Op No"
.MoveRight Unit:=wdCell
.MoveUp Unit:=wdLine, Count:=1
'.MoveRight Unit:=wdCell, Count:=7, Extend:=wdExtend
.SelectRow
.Rows.HeadingFormat = wdToggle
.MoveRight Unit:=wdCell
.MoveDown Unit:=wdLine, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
.Rows.SpaceBetweenColumns = CentimetersToPoints(0.1)
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.MoveRight Unit:=wdCell
End With
End Sub
Public Sub DocumentFooter(wdApp As Word.Application)
Debug_Print "DocumentFooter(wdapp)"
With wdApp.Selection
.MoveRight Unit:=wdCell
.MoveRight Unit:=wdCell
'Stop
.TypeText Text:="* End of List *"
.MoveRight Unit:=wdCell, Count:=5
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveDown Unit:=wdLine, Count:=2
.InsertBreak Type:=wdPageBreak
.Font.Size = 10
.ParagraphFormat.Alignment
'Stop
.TypeParagraph
.TypeText Text:="Total cards on " & sBranchName & " Register for " & sProcessDate & " = " & lCardCount
.TypeParagraph
.TypeParagraph
.TypeText Text:="Total cards collected by Members with letters on file: _______"
.TypeText Text:=" Total cards NOT collected and security destroyed: _______"
.TypeParagraph
.TypeParagraph
.TypeText Text:="Total cards sent to other branches _______ and overall Total cards _______."
.TypeParagraph
.TypeParagraph
.TypeText Text:="Please return this register sheet to the Card Clerk"
.TypeText Text:=" 5 weeks after receipt on (" & sReturnDate & "), together with fully completed letters."
.TypeParagraph
.TypeParagraph
.TypeText Text:="Register and letters checked by: __________________________
End With
End Sub
Public Sub CreateLetters()
Debug_Print "CreateLetters()", 2
Dim i As Integer, j As Integer
Dim iMax As Integer
Dim sSQL As String
Dim sTemplateName As String
Dim sFinalDocName As String
Dim lTranCode As Long
Dim sLabel As String
Dim sMatchBranch As String
iMax = CInt(GetINIString(kPROGNAM
For i = 1 To iMax Step 1
sTemplateName = sTemplatePath & GetINIString(kPROGNAME, "Template" & i, "")
sFinalDocName = sOutPutPath & GetINIString(kPROGNAME, "FinalDoc" & i, "")
sSQL = GetINIString(kPROGNAME, "Query" & i, "0")
sLabel = GetINIString(kPROGNAME, "Label" & i, "")
If myFSO.FileExists(sTemplate
MergeLetter sSQL, sTemplateName, sFinalDocName, sLabel
Else
j = MsgBox("Cannot find template:" & vbCrLf & sTemplateName, vbCritical, "Skipping: " & sLabel)
End If
Next
End Sub
Public Sub MergeLetter(sSQL As String, sDocTemplate As String, sDocFinal As String, sFormalName As String)
Debug_Print "MergeLetter(" & sSQL & "," & sDocTemplate & "," & sDocFinal & "," & sFormalName & ")", 2
Dim rsCards As Recordset
Dim wdApp As New Word.Application
Dim x As Integer
Dim iI As Integer
Dim iMax As Integer
Dim iNoOfBrands As Integer
Dim iBrandNo As Integer
Dim sEmailBodytext As String
iNoOfBrands = 0
iBrandNo = 0
On Error Resume Next
LblAction.Caption = "Create letter: " & sFormalName
DoEvents
Set rsCards = DBTEMP.OpenRecordset(sSQL)
If Not rsCards.EOF Then
wdApp.Documents.Open (sDocTemplate)
wdApp.Application.Visible = gVisible
With wdApp.ActiveDocument.MailM
.OpenDataSource Name:= _
sTempDB, ConfirmConversions:=False,
False, LinkToSource:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", WritePasswordDocument:="",
"", Revert:=False, Format:=wdOpenFormatAuto, Connection:="TABLE Cards", _
SQLStatement:=sSQL
End With
wdApp.ActiveDocument.MailM
With wdApp.ActiveDocument.MailM
.Destination = wdSendToNewDocument
.MailAsAttachment = False
.MailAddressFieldName = ""
.MailSubject = ""
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=True
End With
Do Until sBrandImage = "unknown"
sBrandImage = GetINIString("Branding", "Brand" & iBrandNo & "Logo", "unknown")
iBrandNo = iBrandNo + 1
Loop
iNoOfBrands = iBrandNo - 1
iMax = iNoOfBrands - 1
For iI = 0 To iMax
sBrandImageRef = GetINIString("Branding", "Brand" & iI & "Reference", "unknown")
sBrandImage = GetINIString("Branding", "Brand" & iI & "Logo", "unknown")
With wdApp.Application.Selectio
.Text = sBrandImageRef
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While wdApp.Application.Selectio
wdApp.Application.Selectio
wdApp.Application.Selectio
Loop
Next iI
sDocFinal = sDocFinal & "-" & Format(sProcessDate, "YYYYMMDD") & "-" & Format(Now(), "HhNnSs") & ".doc"
wdApp.ActiveDocument.SaveA
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
Dim document
For Each document In wdApp.Documents
wdApp.ActiveDocument.Close
Next
sEmailBodytext = "The " & sFormalName & " letters are ready for pickup at: " & vbCrLf & sDocFinal
SendMail sFormalName & " letters - Ready for Pickup", sEmailBodytext, sMailDocsTo
Else
SendMail "NO " & sFormalName & " letters - No file to pickup", "", sMailDocsTo
End If
wdApp.Application.Quit SaveChanges:=wdDoNotSaveCh
Set wdApp = Nothing
rsCards.Close
Set rsCards = Nothing
DoEvents
End Sub
Public Sub Main()
Debug_Print "Main()", 2
Dim Dte$
Dim st As String
Dim x As Integer
Dim tmp As String
Dim sProgDataPath As String
tmp = String$(255, 32)
'=========================
sDBFile = GetINIString("Database", "myDBase", "c:\xx.mdb")
sProgDataPath = GetINIString("myPaths", "ProgDataPath", "c:\")
If Right$(sProgDataPath, 1) <> "\" Then
sProgDataPath = sProgDataPath & "\"
End If
sTempDB = sProgDataPath & kPROGNAME & ".mdb"
Debug_Print "stempdb: " & sTempDB, 3
sOutPutPath = GetINIString(kPROGNAME, "OutPutPath", "c:\")
If Right$(sOutPutPath, 1) <> "\" Then
sOutPutPath = sOutPutPath & "\"
End If
Debug_Print "soutputpath: " & sOutPutPath
'*************************
'debug purposes only
'sOutPutPath = App.Path & "\" & sOutPutPath
'*************************
sCardReportPath = GetINIString("FileManagerP
If Right$(sCardReportPath, 1) <> "\" Then
sCardReportPath = sCardReportPath & "\"
End If
sCardReport = sCardReportPath & "CORDR"
Debug_Print "sCardReport: " & sCardReport, 3
lDefaultBrNo = Val(GetINIString(kPROGNAME
Debug_Print "lDefaultBrNo: " & lDefaultBrNo
sTemplatePath = GetINIString("MISPaths", "WordTemplatePath", "c:\")
If Right$(sTemplatePath, 1) <> "\" Then
sTemplatePath = sTemplatePath & "\"
End If
Debug_Print "sTemplatePath: " & sTemplatePath
' Register template
sRegisterTemplateName = GetINIString(kPROGNAME, "RegisterTemplateName", "RegisterDummy.doc")
sRegisterTemplateName = sTemplatePath & sRegisterTemplateName
'Unicom Register template
sRegisterTemplateName2 = GetINIString(kPROGNAME, "RegisterTemplateName2", "RegisterDummy.doc")
sRegisterTemplateName2 = sTemplatePath & sRegisterTemplateName2
sErrorMailTo = GetINIString("Email", "ErrorMailTo", "")
sMailDocsTo = GetINIString(kPROGNAME, "MailDocsTo", "")
sBrandReference = GetINIString("Branding", "Brand" & lBrandNo & "Reference", "unknown")
sBrandWebAddress = GetINIString("Branding", "Brand" & lBrandNo & "WebAddress", "unknown")
sRegisterReport1 = sOutPutPath & "CardRegister"
sRegisterReport2 = sOutPutPath & "CardRegister"
On Error Resume Next
Set DBTEMP = OpenDatabase(sTempDB)
If DBTEMP Is Nothing Then
SendMail kPROGNAME & " - Error", "Unable to open Tempory database!" & vbCrLf & "It should be at: " & sTempDB, sErrorMailTo
End
Else
On Error GoTo 0
Set tblCards = DBTEMP.OpenTable("Cards")
End If
Set DBMIS = OpenDatabase(sDBFile)
If DBMIS Is Nothing Then
SendMail kPROGNAME & " - Error", "Unable to open database!" & vbCrLf & "It should be at: " & sDBFile, sErrorMailTo
End
Else
On Error GoTo 0
Set tblMember = DBMIS.OpenTable("Customer"
Set tblTitleCodes = DBMIS.OpenTable("TitleCode
Set tblBranchMaster = DBMIS.OpenTable("Branch Master")
Set tblBrand = DBMIS.OpenTable("Brand Master")
End If
End Sub
Public Sub CreateRegisterSheets()
Debug_Print "CreateRegisterSheets()", 2
Dim i As Long
Dim iMax
Dim sRegisterTemplateName As String
Dim sRegisterBrandName As String
Dim sProcessFlag As String
Dim sBrand As String
sReturnDate = Format(Date + 35, "dd mmm yyyy")
sSentDate = Format(Date, "dd mmm yyyy")
iMax = CLng(GetINIString(kPROGNAM
For i = 0 To iMax Step 1
sRegisterTemplateName = GetINIString(kPROGNAME, "RegisterTemplateName" & i, "RegisterDummy.doc")
sRegisterTemplateName = sTemplatePath & sRegisterTemplateName
sBrand = GetINIString(kPROGNAME, "RegisterTemplateBrand" & i, "Unknown")
sProcessFlag = LCase(GetINIString(kPROGNA
If sProcessFlag = "y" Then
CreateRegisterSheet i, sBrand, sRegisterTemplateName
End If
Next
End Sub
Private Sub CreateRegisterSheet(lBrand
Debug_Print "CreateRegisterSheet(" & lBrand & "," & sBrandname & "," & sTemplateName & ")", 2
Dim wdApp As New Word.Application
Dim rsCards As Recordset
Dim rsCards2 As Recordset
Dim sSQL As String
Dim sSQL2 As String
Dim bFirst As Boolean
Dim sFilename As String
Dim sEmailBodytext As String
LblAction.Caption = "Create Register Sheet: " & sBrandname
DoEvents
sSQL = "select * from cards where [Brand No] = " & lBrand & " order by [branch no],surname"
Set rsCards = DBTEMP.OpenRecordset(sSQL)
'DocumentSetup wdapp
If Not rsCards.EOF Then
wdApp.Documents.Open (sTemplateName)
wdApp.Application.Visible = gVisible
rsCards.MoveFirst
lHoldBRNo = -1
bFirst = True
Do Until rsCards.EOF
lBRNo = rsCards("Branch No")
If lBRNo <> lHoldBRNo Then
If bFirst Then
bFirst = False
Else
DocumentFooter wdApp
wdApp.Selection.InsertBrea
End If
sBranchName = rsCards("Branch Name")
DocumentHeader wdApp
lHoldBRNo = lBRNo
lCardCount = 0
End If
' Do While lBRNo = lHoldBRNo And Not (rsCards.EOF)
sCardNo = rsCards("Real Card No")
sMemberName = rsCards("Name on card")
lMemberNo = rsCards("Member No")
With wdApp.Selection
.MoveRight Unit:=wdCell
.TypeText Str(lBRNo)
.MoveRight Unit:=wdCell
.TypeText Str(lMemberNo)
.MoveRight Unit:=wdCell
.TypeText sCardNo
.MoveRight Unit:=wdCell
.TypeText sMemberName
'.MoveRight Unit:=wdCell
'.TypeText Str(lMemberNo)
.MoveRight Unit:=wdCell, Count:=3
End With
lCardCount = lCardCount + 1
rsCards.MoveNext
Loop
If lCardCount > 0 Then
DocumentFooter wdApp
End If
sFilename = sOutPutPath & "CardRegister" & "-" & sBrandname & "-" & Format(sProcessDate, "YYYYMMDD") & "-" & Format(Now(), "HhNnSs") & ".doc"
wdApp.ActiveDocument.SaveA
wdApp.ActiveDocument.Close
sEmailBodytext = "The " & sBrandname & " Register is available at: " & vbCrLf & sFilename
SendMail sBrandname & " Register", sEmailBodytext, sMailDocsTo
Else
SendMail "NO " & sBrandname & " Register - No cards on list", "", sMailDocsTo
End If
Dim document
For Each document In wdApp.Documents
wdApp.ActiveDocument.Close
Next
wdApp.Quit
Set wdApp = Nothing
rsCards.Close
Set rsCards = Nothing
bOK = True
DoEvents
End Sub
Function SizeInMeg(sFilePath As String) As Long
Debug_Print "SizeInMeg(" & sFilePath & ")", 2
Dim dCurrLengthBytes As Double
Dim dCurrLengthKilobytes As Double
dCurrLengthBytes = FileLen(sFilePath)
dCurrLengthKilobytes = dCurrLengthBytes / 1024
SizeInMeg = CLng(dCurrLengthKilobytes / 1024)
End Function
The tempDatabase opens when this line of code executes
wdApp.Documents.Open (sTemplateName)
which is line 17 inside the Sub
Public Sub MergeLetter(sSQL As String, sDocTemplate As String, sDocFinal As String, sFormalName As String)
I hope someone can help
**************************
Option Explicit
Dim sWorkLine1 As String
Dim sGiven As String
Dim sSurname As String
Dim sMemberName As String
Dim lMemberNo As Long
Dim lFullMemberNo As Double
Dim sCardNo As String
Dim sTitle As String
Dim lTranCode As Long
Dim sNewCardTranCode As String
Dim sAddress1 As String
Dim sAddress2 As String
Dim sAddress3 As String
Dim sAddress4 As String
Dim sPostCode As String
Dim sBranchName As String
Dim lBrandNo As Long
Dim sPLine As String
Dim sSP As String
Dim sOutFileHDR As String
Dim iPrintFlag As Integer
Dim bOK As Boolean
Dim sWorkLine2 As String
Dim sWorkLine3 As String
Dim sWorkLine4 As String
Dim iTempType As Integer
Dim iHdr As Integer
Dim sReportDate As String
Dim lCnt As Long
Dim sEmailDeleteInBox As String
Dim sTemplatePath As String
Dim sTemplateName As String
Dim sNewTemplateName As String
Dim sRenewalTemplateName As String
Dim sNewPostTemplateName As String
Dim sRenewalPostTemplateName As String
Dim sRegisterTemplateName As String
Dim sRegisterTemplateName2 As String
Dim sOutPutPath As String
Dim sRegisterReport1 As String
Dim sRegisterReport2 As String
Dim sNewCardDoc As String
Dim sRenewalCardDoc As String
Dim sNewCardPostDoc As String
Dim sRenewalCardPostDoc As String
Dim sBrandReference As String
Dim sBrandWebAddress As String
Dim sBrandname As String
Dim sEmailNewCardString As String
Dim sEmailRenewalCardString As String
Dim sEmailPostNewCardString As String
Dim sEmailPostRenewalCardStrin
Dim sCardReportPath As String
Dim sCardReport As String
Dim sDBFile As String
Dim sTempDB As String
Dim lBRNo As Long
Dim lHoldBRNo As Long
Dim sProcessDate As String
Dim sReturnDate As String
Dim sSentDate As String
Dim lCardCount As Long
Dim sRegisterNo As String
Dim sErrorMailTo As String
Dim sMailDocsTo As String
'Dim sEmailSubject As String
'Dim sEmailText As String
Dim sBrandImage As String
Dim sBrandImageRef As String
Dim Cnt As Long
Dim ErrorNo As Long
Dim a$
Dim CRLF$
Public Function RemoveChars(TempString)
Debug_Print "RemoveChars(" & TempString & ")"
Dim comma As Integer
If Left(TempString, 1) = Chr(34) And Right(TempString, 1) = Chr(34) Then
TempString = Mid$(TempString, 2, Len(TempString) - 2)
End If
If Left(TempString, 1) = "," Then
TempString = Mid$(TempString, 2, Len(TempString))
End If
If Right(TempString, 1) = "," Then
TempString = Mid$(TempString, 1, Len(TempString) - 1)
End If
comma = InStr(1, TempString, ",")
Do While comma
TempString = Mid$(TempString, 1, comma - 1) & " " & Mid$(TempString, comma + 1, Len(TempString))
comma = InStr(1, TempString, ",")
Loop
RemoveChars = TempString
End Function
Public Function ShellandWait(ExeFullPath As String, Optional TimeOutValue As Long = 0) As Boolean
Debug_Print "ShellAndWait(" & ExeFullPath & "," & TimeOutValue & ")", 2
Dim lInst As Long
Dim lStart As Long
Dim lTimetoQuit As Long
Dim sExeName As String
Dim lProcessId As Long
Dim lExitCode As Long
Dim bPastMidnight As Boolean
On Error GoTo ErrorHandler
lStart = CLng(Timer)
sExeName = ExeFullPath
'Deal with timeout being reset at Midnight
If TimeOutValue > 0 Then
If lStart + TimeOutValue < 86400 Then
lTimetoQuit = lStart + TimeOutValue
Else
lTimetoQuit = (lStart - 86400) + TimeOutValue
bPastMidnight = True
End If
End If
lInst = Shell(sExeName, vbMinimizedNoFocus)
lProcessId = OpenProcess(PROCESS_QUERY_
Do
Call GetExitCodeProcess(lProces
DoEvents
If TimeOutValue And Timer > lTimetoQuit Then
If bPastMidnight Then
If Timer < lStart Then Exit Do
Else
Exit Do
End If
End If
Loop While lExitCode = STATUS_PENDING
ShellandWait = True
Exit Function
ErrorHandler:
ShellandWait = False
On Error Resume Next
End Function
Private Sub ProcessFile()
Debug_Print "ProcessFile()", 2
'*************************
' This procedure will process the CORDR report file
' and creates register sheets and creates letters to be sent to members.
' (For card holders ONLY)
' The register sheets and letters are 'mailed' to nominated staff.
'*************************
Dim bFirst As Boolean
Dim x As String
On Error Resume Next
Dim sModCardNo As String
Dim sVerifiedByA As String
bFirst = True
iPrintFlag = False
Err.Clear
'Stop
'sCardReport
'sTemplateName = "c:\temp.doc"
tblCards.Index = "Card No"
tblMember.Index = "Customer No"
tblTitleCodes.Index = "PrimaryKey"
tblBranchMaster.Index = "PrimaryKey"
tblBrand.Index = "PrimaryKey"
If tblCards.RecordCount > 0 Then
Debug_Print "ProcessFile() - tblCards RecordCount > 0", 3
tblCards.MoveFirst
LblAction.Caption = "Clearing Cards Table"
Do Until tblCards.EOF
tblCards.Delete
tblCards.MoveNext
Loop
End If
On Error Resume Next
bOK = True
Open sCardReport For Input As #1
If Err = 0 Then
Debug_Print "ProcessFile() - Opened Card Report: " & sCardReport, 3
On Error GoTo 0
Line Input #1, sWorkLine1
Debug_Print "ProcessFile() - Workline: " & sWorkLine1, 3
Do Until EOF(1)
If bFirst Then
Debug_Print "ProcessFile() - First Line", 3
If Left$(sWorkLine1, 11) = "REPORT NAME" Then
sProcessDate = Format(Mid$(sWorkLine1, 156, 10), "DD MMM YYYY")
bFirst = False
End If
End If
'If IsNumeric(Left$(sWorkLine1
'If Mid$(sWorkLine1, 9, 6) <> "584002" Then
'sCardNo = Mid$(sWorkLine1, 9, 19)
'lMemberNo = Val(Mid$(sWorkLine1, 30, 17))
'sMemberName = Mid$(sWorkLine1, 65, 26)
'lTranCode = Val(Mid$(sWorkLine1, 93, 6))
'lBRNo = Val(Mid$(sWorkLine1, 103, 6))
'Stop
If IsNumeric(Left$(sWorkLine1
If Mid$(sWorkLine1, 9, 6) <> "584002" Then
sCardNo = Mid$(sWorkLine1, 9, 19)
Debug_Print "ProcessFile() - Card: " & sCardNo, 3
sModCardNo = Left(sCardNo, 4) & " XXXX XXXX " & Right(sCardNo, 4)
lFullMemberNo = Val(Mid$(sWorkLine1, 30, 17))
sMemberName = Mid$(sWorkLine1, 65, 26)
lTranCode = Val(Mid$(sWorkLine1, 93, 6))
lBRNo = Val(Mid$(sWorkLine1, 103, 6))
sVerifiedByA = Mid(sWorkLine1, 143, 11)
If lBRNo = 0 Then
lBRNo = lDefaultBrNo
End If
tblCards.Seek "=", sCardNo
tblMember.Seek "=", lFullMemberNo
If tblMember.NoMatch Then
sTitle = ""
sGiven = ""
sSurname = ""
sAddress1 = ""
sAddress2 = ""
sAddress3 = ""
sPostCode = ""
Else
tblTitleCodes.Seek "=", tblMember("Title code")
If tblTitleCodes.NoMatch Then
sTitle = ""
Else
sTitle = tblTitleCodes("Description
If sTitle = "DEFAULT" Then
sTitle = ""
End If
End If
' added 20060619
' we've modified the customer table to include parsed brand and member no,
' and also have a brand master table, meaning less ini file stuff
lMemberNo = tblMember("memberno")
lBrandNo = tblMember("brand")
' end addition
sGiven = tblMember("Given Name")
sSurname = tblMember("Surname")
If tblMember("Customer Type") = 2 Then
sSurname = sGiven & sSurname
sGiven = ""
End If
' Address 1 code change - 20030930
If IsNull(tblMember("Address Line 1")) Then
sAddress1 = ""
Else
sAddress1 = tblMember("Address Line 1")
End If
' Address 2 code change - 30092003
If IsNull(tblMember("Address Line 2")) Then
sAddress2 = ""
Else
sAddress2 = tblMember("Address Line 2")
End If
' Address 3 code change - 30092003
If IsNull(tblMember("Address Line 3")) Then
sAddress3 = ""
Else
sAddress3 = tblMember("Address Line 3")
End If
' Address 4 code change - 30092003
If IsNull(tblMember("Address Line 4")) Then
sAddress4 = ""
Else
sAddress4 = tblMember("Address Line 4")
End If
' Postcode code change - 30092003
If IsNull(tblMember("PostCode
sPostCode = ""
Else
sPostCode = tblMember("PostCode")
End If
'sAddress2 = tblMember("Address line 2")
'sAddress3 = tblMember("Address line 3")
'sAddress4 = tblMember("Address line 4")
'sPostCode = tblMember("PostCode")
End If
If tblCards.NoMatch Then
tblCards.AddNew
Debug_Print "ProcessFile() - Adding new card record to db", 3
tblCards("Real Card No") = sCardNo
tblCards("Card No") = sModCardNo
tblCards("Full Member No") = lFullMemberNo '---------------------
tblCards("Member No") = lMemberNo
tblCards("Name On Card") = sMemberName
tblCards("Title") = sTitle
tblCards("Init") = Left$(sGiven, 1)
tblCards("Given") = sGiven
tblCards("Surname") = sSurname
tblCards("Address 1") = sAddress1
tblCards("Address 2") = sAddress2
tblCards("Address 3") = sAddress3
tblCards("Address 4") = sAddress4
tblCards("PostCode") = sPostCode
tblCards("Branch No") = lBRNo
tblCards("Tran Code") = lTranCode
tblCards("Brand No") = lBrandNo
tblCards("VerifiedByA") = sVerifiedByA
tblBrand.Seek "=", lBrandNo
If tblBrand.NoMatch Then
Debug_Print "ProcessFile() - Unknown Brand: " & lBrandNo, 3
tblCards("BrandImageRef") = "Unknown"
tblCards("BrandWebAddress"
tblCards("BrandName") = "Unknown"
tblCards("BrandAdd1") = "Unknown"
tblCards("BrandAdd2") = "Unknown"
tblCards("BrandAdd3") = "Unknown"
tblCards("BrandCorr1") = "Unknown"
tblCards("BrandCorr2") = "Unknown"
tblCards("BrandCorr3") = "Unknown"
tblCards("BrandPhone1") = "Unknown"
tblCards("BrandPhone2") = "Unknown"
tblCards("BrandFax") = "Unknown"
tblCards("BrandEmail") = "Unknown"
Else
tblCards("BrandImageRef") = tblBrand("imageRef")
tblCards("BrandWebAddress"
tblCards("BrandName") = tblBrand("LongName")
tblCards("BrandAdd1") = tblBrand("address1")
tblCards("BrandAdd2") = tblBrand("address2")
tblCards("BrandAdd3") = tblBrand("address3")
tblCards("BrandCorr1") = tblBrand("corradd1")
tblCards("BrandCorr2") = tblBrand("corradd2")
tblCards("BrandCorr3") = tblBrand("corradd3")
tblCards("BrandPhone1") = tblBrand("phone1")
tblCards("BrandPhone2") = tblBrand("phone2")
tblCards("BrandFax") = tblBrand("fax")
tblCards("BrandEmail") = tblBrand("email")
End If
tblBranchMaster.Seek "=", lBRNo
If tblBranchMaster.NoMatch Then
sBranchName = "Unknown"
Else
sBranchName = tblBranchMaster("Branch Name")
End If
tblCards("Branch Name") = sBranchName
tblCards.Update
Debug_Print "ProcessFile() - tblCards.Update Method", 3
End If
End If
End If
Line Input #1, sWorkLine1
Loop
Close #1
Else
bOK = False
End If
On Error Resume Next
Debug_Print "ProcessFile() - End", 3
End Sub
Private Sub Form_Load()
'*************************
'The forms is displayed in screen to
'show progress of processing
'*************************
Dim stemp As String
MousePointer = vbHourglass
lblVersion.Caption = "v " & App.Major & "." & App.Minor & "." & App.Revision
LblAction.Caption = "Processing Card Order report"
LblCnt.Caption = lCnt
Debug_Open
Me.Show
stemp = LCase(GetINIString(kPROGNA
If stemp = "y" Then
gVisible = True
Else
gVisible = False
End If
Debug_Print "gVisible = " & gVisible, 3
DoEvents
Main
ProcessFile
CreateRegisterSheets
CreateLetters
MousePointer = vbNormal
'close database - 2006-10-31 - did not fix problem
DBTEMP.Close
Set DBTEMP = Nothing
End
End Sub
'Currently unused - winnt doesnt support this version of CDO.
Sub SendMailNew(ByVal sEmailSubject, ByVal sEmailText, ByVal sEmailRecipient, Optional ByVal sEmailAttachment)
Debug_Print "SendMailNew()", 2
Dim sServerName As String
Dim iConf As New CDO.Configuration
Dim myMsg As New CDO.Message
Dim Flds As ADODB.Fields
Set Flds = iConf.Fields
Dim sPickupPath As String
sPickupPath = GetINIString("Email", "CDOPickupDir", "C:\InetPub\mailroot\Picku
If Right(sPickupPath, 1) = "\" Then
sPickupPath = Left(sPickupPath, Len(sPickupPath) - 1)
End If
sServerName = GetINIString("Email", "EmailFrom", "MisServer")
Flds(cdoLanguageCode) = "en-au"
Flds(cdoSendUsingMethod) = cdoSendUsingPickup
Flds(cdoSMTPServerPickupDi
Flds(cdoFlushBuffersOnWrit
'Flds(cdoSensitivity) = cdoCompanyConfidential
Flds.Update
'make the configuration just set up apply to this mail message
Set myMsg.Configuration = iConf
With myMsg
'example below = "Display Name" <email@address.com>
.From = """" & sServerName & """ <" & kPROGNAME & "@cu.com.au>"
'this should be a comma seperated list of emails
.To = sEmailRecipient
.Subject = App.Title & " - " & Format(Date, "yyyy/mm/dd") & " - " & sEmailSubject
.TextBody = sEmailText
If Not IsMissing(sEmailAttachment
.AddAttachment sEmailAttachment
End If
End With
myMsg.Send
End Sub
Public Function SendMail(ByVal sEmailSubject, ByVal sEmailText, ByVal sEmailRecipient, Optional ByVal sEmailAttachment)
Debug_Print "SendMail(" & sEmailSubject & "," & sEmailText & "," & sEmailRecipient & "optionalattachement)", 2
Dim sEmailFrom As String
Dim sEmailFromPW As String
Dim sEmailTo As String
'Exit Function
sEmailFrom = GetINIString("Email", "EmailFrom", "")
sEmailFromPW = GetINIString("Email", "EmailFromPW", "")
Dim iSemiColon As Integer
Dim lErrorNo As Long
sEmailText = sEmailText & " "
MAPISession.UserName = sEmailFrom
MAPISession.Password = sEmailFromPW
On Error Resume Next
MAPISession.SignOn
DoEvents
If Err = 0 Then
MAPIMessage.SessionID = MAPISession.SessionID
sEmailTo = sEmailRecipient
If sEmailRecipient = "" Then
Exit Function
Else
iSemiColon = InStr(1, sEmailTo, ";")
Do While iSemiColon
sEmailRecipient = Mid$(sEmailTo, 1, iSemiColon - 1)
GoSub ComposeMessage
sEmailTo = Mid$(sEmailTo, iSemiColon + 1, Len(sEmailTo))
iSemiColon = InStr(1, sEmailTo, ";")
Loop
sEmailRecipient = sEmailTo
GoSub ComposeMessage
End If
MAPISession.SignOff
Else
bOK = False
End If
Exit Function
ComposeMessage:
On Error Resume Next
'On Error GoTo 0
MAPIMessage.Compose
MAPIMessage.RecipType = 1
MAPIMessage.RecipAddress = sEmailRecipient
MAPIMessage.AddressResolve
MAPIMessage.ResolveName
lErrorNo = Err
If lErrorNo = 0 Then
MAPIMessage.MsgSubject = sEmailSubject
MAPIMessage.MsgNoteText = sEmailText
If Not IsMissing(sEmailAttachment
MAPIMessage.AttachmentPosi
MAPIMessage.AttachmentPath
End If
'Send the message
MAPIMessage.Send False
End If
On Error GoTo 0
Return
End Function
Public Sub DocumentSetup(wdApp As Word.Application)
Debug_Print "DocumentSetup(wdapp)"
With wdApp.Selection.Font
.Name = "Arial"
.Size = 12
.Bold = False
.Italic = False
.Underline = wdUnderlineNone
.StrikeThrough = False
.DoubleStrikeThrough = False
.Outline = False
.Emboss = False
.Shadow = False
.Hidden = False
.SmallCaps = False
.AllCaps = False
.ColorIndex = wdAuto
.Engrave = False
.Superscript = False
.Subscript = False
.Spacing = 0
.Scaling = 100
.Position = 0
.Kerning = 0
.Animation = wdAnimationNone
End With
End Sub
Public Sub DocumentHeader(wdApp As Word.Application)
Debug_Print "DocumentHeader(wdapp)", 2
sRegisterNo = lBRNo & "." & Format(Date, "dd.mm.yyyy")
'Stop
With wdApp.Selection
.ParagraphFormat.Alignment
'.TypeParagraph
.TypeText sBranchName & " (" & lBRNo & ")" & " - CORDR Report Date: " & sProcessDate '"Y(5) - 29/5/2002"
.TypeParagraph
.TypeParagraph
'.TypeText "Sent Date: " & sSentDate
'.TypeParagraph
'.TypeText "Return Date: " & sReturnDate
'.TypeParagraph
.TypeText "Register Number = " & sRegisterNo
.TypeParagraph
.TypeParagraph
.Font.Size = 10
'.Tables.Add .Range, 8, 8
.Tables.Add .Range, 1, 7
.Tables(1).Rows.SetLeftInd
.TypeText Text:="Branch Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Member Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Card Number"
.MoveRight Unit:=wdCell
.TypeText Text:="Card Name"
.MoveRight Unit:=wdCell
.TypeText Text:="Letter Completed and on file"
.MoveRight Unit:=wdCell
.TypeText Text:="Date/Branch Card forwarded to: (Complete if sending to another branch for collection)"
.MoveRight Unit:=wdCell
.TypeText Text:="Issuing Staff Member Sig & Op No"
.MoveRight Unit:=wdCell
.MoveUp Unit:=wdLine, Count:=1
'.MoveRight Unit:=wdCell, Count:=7, Extend:=wdExtend
.SelectRow
.Rows.HeadingFormat = wdToggle
.MoveRight Unit:=wdCell
.MoveDown Unit:=wdLine, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
.Rows.SpaceBetweenColumns = CentimetersToPoints(0.1)
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.Move Unit:=wdColumn, Count:=1
.SelectColumn
.Cells.SetWidth ColumnWidth:=CentimetersTo
'.Rows.SpaceBetweenColumns
.Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtL
.ParagraphFormat.RightInde
.MoveRight Unit:=wdCell
End With
End Sub
Public Sub DocumentFooter(wdApp As Word.Application)
Debug_Print "DocumentFooter(wdapp)"
With wdApp.Selection
.MoveRight Unit:=wdCell
.MoveRight Unit:=wdCell
'Stop
.TypeText Text:="* End of List *"
.MoveRight Unit:=wdCell, Count:=5
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveRight Unit:=wdCell, Count:=6
.MoveDown Unit:=wdLine, Count:=2
.InsertBreak Type:=wdPageBreak
.Font.Size = 10
.ParagraphFormat.Alignment
'Stop
.TypeParagraph
.TypeText Text:="Total cards on " & sBranchName & " Register for " & sProcessDate & " = " & lCardCount
.TypeParagraph
.TypeParagraph
.TypeText Text:="Total cards collected by Members with letters on file: _______"
.TypeText Text:=" Total cards NOT collected and security destroyed: _______"
.TypeParagraph
.TypeParagraph
.TypeText Text:="Total cards sent to other branches _______ and overall Total cards _______."
.TypeParagraph
.TypeParagraph
.TypeText Text:="Please return this register sheet to the Card Clerk"
.TypeText Text:=" 5 weeks after receipt on (" & sReturnDate & "), together with fully completed letters."
.TypeParagraph
.TypeParagraph
.TypeText Text:="Register and letters checked by: __________________________
End With
End Sub
Public Sub CreateLetters()
Debug_Print "CreateLetters()", 2
Dim i As Integer, j As Integer
Dim iMax As Integer
Dim sSQL As String
Dim sTemplateName As String
Dim sFinalDocName As String
Dim lTranCode As Long
Dim sLabel As String
Dim sMatchBranch As String
iMax = CInt(GetINIString(kPROGNAM
For i = 1 To iMax Step 1
sTemplateName = sTemplatePath & GetINIString(kPROGNAME, "Template" & i, "")
sFinalDocName = sOutPutPath & GetINIString(kPROGNAME, "FinalDoc" & i, "")
sSQL = GetINIString(kPROGNAME, "Query" & i, "0")
sLabel = GetINIString(kPROGNAME, "Label" & i, "")
If myFSO.FileExists(sTemplate
MergeLetter sSQL, sTemplateName, sFinalDocName, sLabel
Else
j = MsgBox("Cannot find template:" & vbCrLf & sTemplateName, vbCritical, "Skipping: " & sLabel)
End If
Next
End Sub
Public Sub MergeLetter(sSQL As String, sDocTemplate As String, sDocFinal As String, sFormalName As String)
Debug_Print "MergeLetter(" & sSQL & "," & sDocTemplate & "," & sDocFinal & "," & sFormalName & ")", 2
Dim rsCards As Recordset
Dim wdApp As New Word.Application
Dim x As Integer
Dim iI As Integer
Dim iMax As Integer
Dim iNoOfBrands As Integer
Dim iBrandNo As Integer
Dim sEmailBodytext As String
iNoOfBrands = 0
iBrandNo = 0
On Error Resume Next
LblAction.Caption = "Create letter: " & sFormalName
DoEvents
Set rsCards = DBTEMP.OpenRecordset(sSQL)
If Not rsCards.EOF Then
wdApp.Documents.Open (sDocTemplate)
wdApp.Application.Visible = gVisible
With wdApp.ActiveDocument.MailM
.OpenDataSource Name:= _
sTempDB, ConfirmConversions:=False,
False, LinkToSource:=True, AddToRecentFiles:=False, PasswordDocument:="", _
PasswordTemplate:="", WritePasswordDocument:="",
"", Revert:=False, Format:=wdOpenFormatAuto, Connection:="TABLE Cards", _
SQLStatement:=sSQL
End With
wdApp.ActiveDocument.MailM
With wdApp.ActiveDocument.MailM
.Destination = wdSendToNewDocument
.MailAsAttachment = False
.MailAddressFieldName = ""
.MailSubject = ""
.SuppressBlankLines = True
With .DataSource
.FirstRecord = wdDefaultFirstRecord
.LastRecord = wdDefaultLastRecord
End With
.Execute Pause:=True
End With
Do Until sBrandImage = "unknown"
sBrandImage = GetINIString("Branding", "Brand" & iBrandNo & "Logo", "unknown")
iBrandNo = iBrandNo + 1
Loop
iNoOfBrands = iBrandNo - 1
iMax = iNoOfBrands - 1
For iI = 0 To iMax
sBrandImageRef = GetINIString("Branding", "Brand" & iI & "Reference", "unknown")
sBrandImage = GetINIString("Branding", "Brand" & iI & "Logo", "unknown")
With wdApp.Application.Selectio
.Text = sBrandImageRef
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Do While wdApp.Application.Selectio
wdApp.Application.Selectio
wdApp.Application.Selectio
Loop
Next iI
sDocFinal = sDocFinal & "-" & Format(sProcessDate, "YYYYMMDD") & "-" & Format(Now(), "HhNnSs") & ".doc"
wdApp.ActiveDocument.SaveA
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
Dim document
For Each document In wdApp.Documents
wdApp.ActiveDocument.Close
Next
sEmailBodytext = "The " & sFormalName & " letters are ready for pickup at: " & vbCrLf & sDocFinal
SendMail sFormalName & " letters - Ready for Pickup", sEmailBodytext, sMailDocsTo
Else
SendMail "NO " & sFormalName & " letters - No file to pickup", "", sMailDocsTo
End If
wdApp.Application.Quit SaveChanges:=wdDoNotSaveCh
Set wdApp = Nothing
rsCards.Close
Set rsCards = Nothing
DoEvents
End Sub
Public Sub Main()
Debug_Print "Main()", 2
Dim Dte$
Dim st As String
Dim x As Integer
Dim tmp As String
Dim sProgDataPath As String
tmp = String$(255, 32)
'=========================
sDBFile = GetINIString("Database", "myDBase", "c:\xx.mdb")
sProgDataPath = GetINIString("myPaths", "ProgDataPath", "c:\")
If Right$(sProgDataPath, 1) <> "\" Then
sProgDataPath = sProgDataPath & "\"
End If
sTempDB = sProgDataPath & kPROGNAME & ".mdb"
Debug_Print "stempdb: " & sTempDB, 3
sOutPutPath = GetINIString(kPROGNAME, "OutPutPath", "c:\")
If Right$(sOutPutPath, 1) <> "\" Then
sOutPutPath = sOutPutPath & "\"
End If
Debug_Print "soutputpath: " & sOutPutPath
'*************************
'debug purposes only
'sOutPutPath = App.Path & "\" & sOutPutPath
'*************************
sCardReportPath = GetINIString("FileManagerP
If Right$(sCardReportPath, 1) <> "\" Then
sCardReportPath = sCardReportPath & "\"
End If
sCardReport = sCardReportPath & "CORDR"
Debug_Print "sCardReport: " & sCardReport, 3
lDefaultBrNo = Val(GetINIString(kPROGNAME
Debug_Print "lDefaultBrNo: " & lDefaultBrNo
sTemplatePath = GetINIString("MISPaths", "WordTemplatePath", "c:\")
If Right$(sTemplatePath, 1) <> "\" Then
sTemplatePath = sTemplatePath & "\"
End If
Debug_Print "sTemplatePath: " & sTemplatePath
' Register template
sRegisterTemplateName = GetINIString(kPROGNAME, "RegisterTemplateName", "RegisterDummy.doc")
sRegisterTemplateName = sTemplatePath & sRegisterTemplateName
'Unicom Register template
sRegisterTemplateName2 = GetINIString(kPROGNAME, "RegisterTemplateName2", "RegisterDummy.doc")
sRegisterTemplateName2 = sTemplatePath & sRegisterTemplateName2
sErrorMailTo = GetINIString("Email", "ErrorMailTo", "")
sMailDocsTo = GetINIString(kPROGNAME, "MailDocsTo", "")
sBrandReference = GetINIString("Branding", "Brand" & lBrandNo & "Reference", "unknown")
sBrandWebAddress = GetINIString("Branding", "Brand" & lBrandNo & "WebAddress", "unknown")
sRegisterReport1 = sOutPutPath & "CardRegister"
sRegisterReport2 = sOutPutPath & "CardRegister"
On Error Resume Next
Set DBTEMP = OpenDatabase(sTempDB)
If DBTEMP Is Nothing Then
SendMail kPROGNAME & " - Error", "Unable to open Tempory database!" & vbCrLf & "It should be at: " & sTempDB, sErrorMailTo
End
Else
On Error GoTo 0
Set tblCards = DBTEMP.OpenTable("Cards")
End If
Set DBMIS = OpenDatabase(sDBFile)
If DBMIS Is Nothing Then
SendMail kPROGNAME & " - Error", "Unable to open database!" & vbCrLf & "It should be at: " & sDBFile, sErrorMailTo
End
Else
On Error GoTo 0
Set tblMember = DBMIS.OpenTable("Customer"
Set tblTitleCodes = DBMIS.OpenTable("TitleCode
Set tblBranchMaster = DBMIS.OpenTable("Branch Master")
Set tblBrand = DBMIS.OpenTable("Brand Master")
End If
End Sub
Public Sub CreateRegisterSheets()
Debug_Print "CreateRegisterSheets()", 2
Dim i As Long
Dim iMax
Dim sRegisterTemplateName As String
Dim sRegisterBrandName As String
Dim sProcessFlag As String
Dim sBrand As String
sReturnDate = Format(Date + 35, "dd mmm yyyy")
sSentDate = Format(Date, "dd mmm yyyy")
iMax = CLng(GetINIString(kPROGNAM
For i = 0 To iMax Step 1
sRegisterTemplateName = GetINIString(kPROGNAME, "RegisterTemplateName" & i, "RegisterDummy.doc")
sRegisterTemplateName = sTemplatePath & sRegisterTemplateName
sBrand = GetINIString(kPROGNAME, "RegisterTemplateBrand" & i, "Unknown")
sProcessFlag = LCase(GetINIString(kPROGNA
If sProcessFlag = "y" Then
CreateRegisterSheet i, sBrand, sRegisterTemplateName
End If
Next
End Sub
Private Sub CreateRegisterSheet(lBrand
Debug_Print "CreateRegisterSheet(" & lBrand & "," & sBrandname & "," & sTemplateName & ")", 2
Dim wdApp As New Word.Application
Dim rsCards As Recordset
Dim rsCards2 As Recordset
Dim sSQL As String
Dim sSQL2 As String
Dim bFirst As Boolean
Dim sFilename As String
Dim sEmailBodytext As String
LblAction.Caption = "Create Register Sheet: " & sBrandname
DoEvents
sSQL = "select * from cards where [Brand No] = " & lBrand & " order by [branch no],surname"
Set rsCards = DBTEMP.OpenRecordset(sSQL)
'DocumentSetup wdapp
If Not rsCards.EOF Then
wdApp.Documents.Open (sTemplateName)
wdApp.Application.Visible = gVisible
rsCards.MoveFirst
lHoldBRNo = -1
bFirst = True
Do Until rsCards.EOF
lBRNo = rsCards("Branch No")
If lBRNo <> lHoldBRNo Then
If bFirst Then
bFirst = False
Else
DocumentFooter wdApp
wdApp.Selection.InsertBrea
End If
sBranchName = rsCards("Branch Name")
DocumentHeader wdApp
lHoldBRNo = lBRNo
lCardCount = 0
End If
' Do While lBRNo = lHoldBRNo And Not (rsCards.EOF)
sCardNo = rsCards("Real Card No")
sMemberName = rsCards("Name on card")
lMemberNo = rsCards("Member No")
With wdApp.Selection
.MoveRight Unit:=wdCell
.TypeText Str(lBRNo)
.MoveRight Unit:=wdCell
.TypeText Str(lMemberNo)
.MoveRight Unit:=wdCell
.TypeText sCardNo
.MoveRight Unit:=wdCell
.TypeText sMemberName
'.MoveRight Unit:=wdCell
'.TypeText Str(lMemberNo)
.MoveRight Unit:=wdCell, Count:=3
End With
lCardCount = lCardCount + 1
rsCards.MoveNext
Loop
If lCardCount > 0 Then
DocumentFooter wdApp
End If
sFilename = sOutPutPath & "CardRegister" & "-" & sBrandname & "-" & Format(sProcessDate, "YYYYMMDD") & "-" & Format(Now(), "HhNnSs") & ".doc"
wdApp.ActiveDocument.SaveA
wdApp.ActiveDocument.Close
sEmailBodytext = "The " & sBrandname & " Register is available at: " & vbCrLf & sFilename
SendMail sBrandname & " Register", sEmailBodytext, sMailDocsTo
Else
SendMail "NO " & sBrandname & " Register - No cards on list", "", sMailDocsTo
End If
Dim document
For Each document In wdApp.Documents
wdApp.ActiveDocument.Close
Next
wdApp.Quit
Set wdApp = Nothing
rsCards.Close
Set rsCards = Nothing
bOK = True
DoEvents
End Sub
Function SizeInMeg(sFilePath As String) As Long
Debug_Print "SizeInMeg(" & sFilePath & ")", 2
Dim dCurrLengthBytes As Double
Dim dCurrLengthKilobytes As Double
dCurrLengthBytes = FileLen(sFilePath)
dCurrLengthKilobytes = dCurrLengthBytes / 1024
SizeInMeg = CLng(dCurrLengthKilobytes / 1024)
End Function
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
"the golden rule is to close and Set = Nothing anything that uses a Set statement."
Good advice. Thanks to both of you.
it worked, but now I have the problem that It runs on my computer for testing, but doesnt work on the server its meant to run on. Got to love WinNT4 Server.
Good advice. Thanks to both of you.
it worked, but now I have the problem that It runs on my computer for testing, but doesnt work on the server its meant to run on. Got to love WinNT4 Server.
ASKER
fixed - one if the 9 sql statements were wrong in the server's INI file(which was fixed in my local test file). When this SQL Statement was executed, the access database was left open.
So there were 2 causes for the problem - not closing things and bad sql statements.
So there were 2 causes for the problem - not closing things and bad sql statements.
ASKER
Im working on Publicifying the code - it has a few things in it that I shouldnt post on the internet.
And I can only access 3 website from work, google, MSoft, and Experts-Exchange
I can google, but I cant view any of the websites i find.