Solved

Access Remains open after a Mailmerge using Visual basic

Posted on 2006-10-30
6
245 Views
Last Modified: 2013-12-25
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.
0
Comment
Question by:aimeec
  • 4
6 Comments
 
LVL 142

Assisted Solution

by:Guy Hengel [angelIII / a3]
Guy Hengel [angelIII / a3] earned 45 total points
ID: 17840005
>I have tried DBase.close, recordSet.close, WordApp.close.
hopefully you did in the right order:

WordApp.quit
set wordApp = nothing
recordSet.close
set recordset = nothing
DBase.close
set dbase = nothing

anyhow, without a bit of code it will be difficult.
to upload code, see www.ee-stuff.com
0
 

Author Comment

by:aimeec
ID: 17840047
they are already set to nothing
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.
0
 

Author Comment

by:aimeec
ID: 17862992
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 sEmailPostRenewalCardString As String


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_INFORMATION, False, lInst)

   Do
       Call GetExitCodeProcess(lProcessId, lExitCode)
       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, 6)) Then
         '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, 6)) Then
         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")) Then
                  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") = "Unknown"
                    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") = tblBrand("URL")
                    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(kPROGNAME, "WordVisible", "y"))
    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\Pickup")
    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(cdoSMTPServerPickupDirectory) = sPickupPath
    Flds(cdoFlushBuffersOnWrite) = True
    '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) Then
            .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.AddressResolveUI = False
    MAPIMessage.ResolveName
   
    lErrorNo = Err
    If lErrorNo = 0 Then
        MAPIMessage.MsgSubject = sEmailSubject
        MAPIMessage.MsgNoteText = sEmailText
        If Not IsMissing(sEmailAttachment) Then
            MAPIMessage.AttachmentPosition = 0
            MAPIMessage.AttachmentPathName = sEmailAttachment
        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 = wdAlignParagraphCenter
        '.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.SetLeftIndent LeftIndent:=-15.25, RulerStyle:=wdAdjustNone
       
        .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:=CentimetersToPoints(2), RulerStyle:=wdAdjustNone
        .Rows.SpaceBetweenColumns = CentimetersToPoints(0.1)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
       
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(3), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
           
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(3.8), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
       
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(8), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
       
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(3.5), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
       
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(3), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
       
        .Move Unit:=wdColumn, Count:=1
        .SelectColumn
        .Cells.SetWidth ColumnWidth:=CentimetersToPoints(3.5), RulerStyle:=wdAdjustNone
        '.Rows.SpaceBetweenColumns = CentimetersToPoints(0.38)
        .Cells.SetHeight RowHeight:=20, HeightRule:=wdRowHeightAtLeast
        .ParagraphFormat.RightIndent = CentimetersToPoints(0)
        .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 = wdAlignParagraphLeft
        '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(kPROGNAME, "NumLetters", "0"))
    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(sTemplateName) Then
            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.MailMerge
            .OpenDataSource Name:= _
            sTempDB, ConfirmConversions:=False, ReadOnly:= _
            False, LinkToSource:=True, AddToRecentFiles:=False, PasswordDocument:="", _
            PasswordTemplate:="", WritePasswordDocument:="", WritePasswordTemplate:= _
            "", Revert:=False, Format:=wdOpenFormatAuto, Connection:="TABLE Cards", _
            SQLStatement:=sSQL
        End With

        wdApp.ActiveDocument.MailMerge.DataSource.QueryString = sSQL
       
        With wdApp.ActiveDocument.MailMerge
            .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.Selection.Find
                .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.Selection.Find.Execute
                wdApp.Application.Selection.Delete Unit:=wdCharacter, Count:=1
                wdApp.Application.Selection.InlineShapes.AddPicture FileName:=sBrandImage, LinkToFile:=False, SaveWithDocument:=True
            Loop
        Next iI
         
        sDocFinal = sDocFinal & "-" & Format(sProcessDate, "YYYYMMDD") & "-" & Format(Now(), "HhNnSs") & ".doc"
       
        wdApp.ActiveDocument.SaveAs FileName:=sDocFinal, FileFormat:= _
            wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
            True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
            False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
            SaveAsAOCELetter:=False
       
        Dim document
        For Each document In wdApp.Documents
            wdApp.ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
        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:=wdDoNotSaveChanges
    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("FileManagerPaths", "DefaultLocalArchivePath", "c:\")
   If Right$(sCardReportPath, 1) <> "\" Then
      sCardReportPath = sCardReportPath & "\"
   End If
   sCardReport = sCardReportPath & "CORDR"
   Debug_Print "sCardReport: " & sCardReport, 3
   
   lDefaultBrNo = Val(GetINIString(kPROGNAME, "BranchNo", "410"))
   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("TitleCodes")
       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(kPROGNAME, "NumTemplates", "0")) - 1 'because its zero counted, we take one off
    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(kPROGNAME, "Process" & i, "y"))
        If sProcessFlag = "y" Then
            CreateRegisterSheet i, sBrand, sRegisterTemplateName
        End If
    Next
End Sub

Private Sub CreateRegisterSheet(lBrand As Long, sBrandname As String, sTemplateName As String)
    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.InsertBreak Type:=wdSectionBreakNextPage
              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.SaveAs (sFilename)
        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 SaveChanges:=wdDoNotSaveChanges
    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




0
Highfive + Dolby Voice = No More Audio Complaints!

Poor audio quality is one of the top reasons people don’t use video conferencing. Get the crispest, clearest audio powered by Dolby Voice in every meeting. Highfive and Dolby Voice deliver the best video conferencing and audio experience for every meeting and every room.

 
LVL 39

Accepted Solution

by:
stevbe earned 80 total points
ID: 17883205
the golden rule is to close and Set = Nothing anything that uses a Set statement. You have multiple recordsets that you are not doing that with. Also the use of On Error Resume Next and On Error GoTO 0 are not good ideas ... I bet you end up hiding lots of errors that you don't see until it is too late to either do anything about them or you may actually capture as a different error.

Steve
0
 

Author Comment

by:aimeec
ID: 17893647
"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.
0
 

Author Comment

by:aimeec
ID: 17894737
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.
0

Featured Post

How to improve team productivity

Quip adds documents, spreadsheets, and tasklists to your Slack experience
- Elevate ideas to Quip docs
- Share Quip docs in Slack
- Get notified of changes to your docs
- Available on iOS/Android/Desktop/Web
- Online/Offline

Join & Write a Comment

Introduction While answering a recent question about filtering a custom class collection, I realized that this could be accomplished with very little code by using the ScriptControl (SC) library.  This article will introduce you to the SC library a…
Enums (shorthand for ‘enumerations’) are not often used by programmers but they can be quite valuable when they are.  What are they? An Enum is just a type of variable like a string or an Integer, but in this case one that you create that contains…
Show developers how to use a criteria form to limit the data that appears on an Access report. It is a common requirement that users can specify the criteria for a report at runtime. The easiest way to accomplish this is using a criteria form that a…
This lesson covers basic error handling code in Microsoft Excel using VBA. This is the first lesson in a 3-part series that uses code to loop through an Excel spreadsheet in VBA and then fix errors, taking advantage of error handling code. This l…

759 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

22 Experts available now in Live!

Get 1:1 Help Now