Hi
This is an unedited sub you can read. The excel text to go into the
letter is in a range called MyParagraphs.
See if it helps anyway!
regards
Paul
'Called by Make_Audit_Report to create a Word Document of Bullet
Points
'BulletCriteria is a Variant array of Booleans
Public Sub Make_The_Bullet_Point_Word_Document(BulletCriteria As
Variant, AuditReportName As String, DoctorName As Variant, AuditDate
As Variant, AuditDirectory As String)
Dim wrdApp As Word.Application
Dim WordWasRunning As Boolean
Dim ReportDoc As Word.Document
Dim BulletPoints As Variant, BulletCount As Integer
Dim FullName As String
Dim myParagraphs As Variant 'Text in "Bullet Point Criteria" sheet of
Methadone workbook
Dim k As Integer
Application.ScreenUpdating = False
'If Word is open, flag it and close Audit Report if it is open
On Error Resume Next
Err.Clear
Set wrdApp = GetObject(, "Word.Application") 'If Word is
already open, flag it with Boolean
If Err.Number <> 0 Then WordWasRunning = False Else
WordWasRunning = True
Err.Clear
'Close Word Audit Report File file with same name if it is
already open
FullName = "Audit Report for " & AuditReportName & ".doc"
Application.DisplayAlerts = False
wrdApp.Documents(FullName).Close
Application.DisplayAlerts = True
On Error GoTo 0
'Otherwise, open up Word
If Not WordWasRunning Then
Set wrdApp = New Word.Application 'fresh version of Word
End If
wrdApp.Visible = True
Set ReportDoc = wrdApp.Documents.Add
BulletPoints = ThisWorkbook.Worksheets("Bullet Point
Criteria").Range("BulletPoints").Value
With ReportDoc
.Activate
'Put in date, ref and introductory paragraph
.Content.InsertAfter Format(Date, "d-mmm-yy")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Doctor:" & vbTab & CStr(DoctorName)
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Re:" & vbTab & "Drug Misuse -
Methadone Treatment"
.Content.InsertParagraphAfter
.Content.InsertAfter vbTab & "Audit Report Period " &
Format(DateValue(AuditDate) - 28, "d-mmm-yy") & " to " &
Format(DateValue(AuditDate), "d-mmm-yy")
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Dear Doctor"
'insert some blurb
myParagraphs = ThisWorkbook.Worksheets("Bullet Point
Criteria").Range("Letter_Paragraphs").Value
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(1, 1) 'Thank you ...
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(2, 1) 'I wish...
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(3, 1) 'Enclosed is...
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
'Count the bullet points and insert into document if 1 or more
BulletCount = 0
For k = 1 To UBound(BulletCriteria)
If BulletCriteria(k) Then BulletCount = BulletCount + 1
Next k
If BulletCount <> 0 Then 'put in bullet points
.Content.InsertAfter myParagraphs(4, 1) 'There were...
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
For k = 1 To UBound(BulletCriteria)
If BulletCriteria(k) Then
.Content.InsertAfter BulletPoints(k, 1)
.Content.InsertParagraphAfter
End If
Next k
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(5, 1) &
Application.VLookup(CStr(DoctorName), ThisWorkbook.Worksheets("Doctors
Details").Range("DoctorsDetails"), 6, False) & myParagraphs(6, 1)
.Content.InsertParagraphAfter
End If
.Content.InsertAfter myParagraphs(7, 1) 'As you are aware
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter "Yours Sincerely"
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(8, 1)
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(9, 1)
.Content.InsertParagraphAfter
.Content.InsertAfter myParagraphs(10, 1)
'bold Re: lines and last two paragraphs
.Range(.Paragraphs(5).Range.Start, .Paragraphs(6).Range.End).Font.Bold
= True
.Range(.Paragraphs(.Paragraphs.Count -
1).Range.Start, .Paragraphs(.Paragraphs.Count).Range.End).Font.Bold =
True
'Bullet the Bullet points
On Error Resume Next 'gives an unexpected error sometimes!
If BulletCount <> 0 Then
.Range(.Paragraphs(16).Range.Start, .Paragraphs(16 +
BulletCount).Range.End).ListFormat.ApplyListTemplate
ListTemplate:=ListGalleries(wdBulletGallery).ListTemplates(1),
ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList
End If
On Error GoTo 0
'Save file
'Error generated by Kill if MyNewWordDoc is open, but it is
closed above
If Dir(AuditDirectory & "\" & FullName) <> "" Then
Kill AuditDirectory & "\" & FullName
End If
.SaveAs (AuditDirectory & "\" & FullName)
If WordWasRunning = False Then .Close ' close the document if
Word was originally not running
End With
If WordWasRunning = False Then wrdApp.Quit ' close the Word
application if it wasn't open already
Set ReportDoc = Nothing
Set wrdApp = Nothing
End Sub
