Maybe I am trying to do too much but the idea was:
I have a database query of contacts. Email Address, Name
and Type and is sorted in that order.
The routine is supposed to be run once a year and send
contacts an application form for each Type based upon 1 of
7 different Word Templates either by email or post.
1/. Select the template associated to the Type and edit it.
2/. If the contact does not have an email address then
save it in a folder to be printed at the end, else save it
in another folder ready to be attached to an email
3/. If the next contact has a different email address then
send the saved attachments to the last email contact,
clear the folder and save this attachment
4/. At the same time keep a text log
This means I have to write VBA in Access to access emails
in Outlook, using 7 Templates in Word and keep a Text log.
The 2 main problems are when to set things up as Public
and addressing applications explicitly
I have copied the routine below, if you can help that
would be great, if not I will understand, it has become a
complete mess.
Option Compare Database
Public Const DocsMail As String = "C:\DocsMail\"
Public Const DocsEmail As String = "C:\DocsEmail\"
Public Const WordDot As String = "c:\Test.dot"
Public Const WordDot2 As String = "c:\Test2.dot"
Public Const XlLog As String = "c:\Log.xls"
Public strName As String
Public strMail As String
Public strEmail As String
Public strEmail2 As String
Public strType As String
Public Const strMStar As String = DocsMail & "*.doc"
Public Const strEStar As String = DocsEmail & "*.doc"
Public intXl As Integer
Public Const TxtFileName As String = "c:\MailLog.txt"
Public intFileNo As Integer
Public olApp As Outlook.Application '####Need to add MS
Outlook reference #####
Public objWord As Word.Application
Public docType1 As Word.Document
Public docType2 As Word.Document
Sub Start_Proc()
intFileNo = FreeFile
Open TxtFileName For Output As #intFileNo
Set olApp = New Outlook.Application
Dim fs As Object 'Do folders exist, if not, create them
and delete any docs
Set fs = CreateObject("Scripting.FileSystemObject")
If fs.folderexists(DocsMail) Then
Else: MkDir DocsMail
End If
If fs.folderexists(DocsEmail) Then
Else: MkDir (DocsEmail)
End If
Set fs = Nothing
If Dir(strMStar) <> "" Then Kill strMStar
If Dir(strEStar) <> "" Then Kill strEStar
Set objWord = CreateObject("Word.Application")
'objWord.ScreenUpdating = False
Set docType1 = objWord.Documents.Open(WordDot, , ReadOnly)
Set docType2 = objWord.Documents.Open(WordDot2, , ReadOnly)
docType1.Activate
Dim cnn As New ADODB.Connection, rst As New ADODB.Recordset
frmStatus.Show
frmStatus.lblStatus.Caption = "Starting process, Please
wait..."
frmStatus.Repaint
Set cnn = CurrentProject.Connection
rst.Open ("QryEmailName"), cnn, adOpenStatic,
adLockPessimistic
Do Until rst.EOF
strName = rst.Fields("Name")
strType = rst.Fields("Type")
Select Case strType
Case Is = "Type 1"
' select template 1
Case Is = "Type 2"
' select template 2
Case Else
' give error ? ? ?
End Select
docType1.Select
Selection.HomeKey Unit:=wdStory 'Edit template
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.TypeText Text:=strName
Selection.EndKey Unit:=wdStory
Selection.HomeKey Unit:=wdLine, Extend:=wdExtend
Selection.TypeText Text:=strName
Selection.HomeKey Unit:=wdLine
Selection.MoveUp Unit:=wdLine, Count:=5
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.TypeText Text:=strName
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.MoveRight Unit:=wdCell, Count:=2
Selection.HomeKey Unit:=wdLine
If rst.Fields("EmailAddress") <> "" Then 'Send email
from here
strEmail = rst.Fields("EmailAddress")
frmStatus.lblStatus.Caption = "Emailing " &
strEmail
frmStatus.Repaint
If strEmail = strEmail2 Then 'Add email to folder
ready to be sent
SaveEmail
Else 'New contact so send existing email and kill
If Dir(strEStar) <> "" Then 'If there are
docs, send them
EmailDoc
Kill strEStar ' Del *.doc
End If 'Save email att
SaveEmail
strEmail2 = strEmail
End If
Else 'Save doc from here
strMail = DocsMail & strName & strType & ".doc"
frmStatus.lblStatus.Caption = "Printing " & strMail
frmStatus.Repaint
SaveDoc
End If
rst.MoveNext
Loop
ActiveDocument.Close (wdDoNotSaveChanges)
If Dir(strEStar) <> "" Then 'If there are attachments
left, send them
EmailDoc
Kill strEStar ' Del *.doc
End If
Unload frmStatus
Set docType1 = Nothing
Set docType2 = Nothing
'objWord.ScreenUpdating = True
objWord.Quit
Set objWord = Nothing
cnn.Close
Set cnn = Nothing
Close #intFileNo
Set olApp = Nothing
End Sub
Sub SaveEmail()
Stop
ActiveDocument.SaveAs DocsEmail & strName & strType
& ".doc"
ActiveDocument.Close (wdDoNotSaveChanges)
Documents.Open WordDot, , ReadOnly ' may not need ? ? ?
ActiveDocument.Select ' may not need ? ? ?
Print #intFileNo, _
Chr$(34) & strType & Chr$(34) & Chr$(9) _
& Chr$(34) & "emailed to" & Chr$(34) & Chr$(9) _
& Chr$(34) & strEmail & Chr$(34)
End Sub
Sub SaveDoc()
ActiveDocument.SaveAs strMail
'ActiveDocument.PrintOut
ActiveDocument.Close (wdDoNotSaveChanges)
Documents.Open WordDot, , ReadOnly ' may not need ? ? ?
ActiveDocument.Select ' may not need ? ? ?
Print #intFileNo, _
Chr$(34) & strType & Chr$(34) & Chr$(9) _
& Chr$(34) & "printed to" & Chr$(34) & Chr$(9) _
& Chr$(34) & strName & Chr$(34)
End Sub
Sub EmailDoc()
Dim DocstoEmail As String
DocstoEmail = Dir(strEStar)
Dim olMail As MailItem
Set olMail = olApp.CreateItem(olMailItem)
With olMail
.To = strEmail2
.Subject = "Send email to " & strEmail2
Do While DocstoEmail <> ""
.Attachments.Add DocsEmail & DocstoEmail
DocstoEmail = Dir
Loop
.Send
End With
Set olMail = Nothing
End Sub
