I am having some difficulty working out a few of the issues in my code and I'm hoping someone may be able to assist.
Here is my code:
- At section marked 'Name, address, contact' - I want the hyperlink to be in a different font (Times New Roman and bold, if that makes any difference).
- At section marked 'Send commands To Word' - My PageSetup is not being applied to the document.
- At section marked 'data' - I had tried using tabstops to position some text at 3.5", but it didn't work out well. Is there a way to position the text over without using tabstops?
Here is my code:
Code:
Sub AddData2()
' Creates Word document
Dim WordApp As Object
Dim LastRow As Integer, i As Integer, r As Integer, Records As Integer
On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
'data sort -- will need for For/i loop to begin after this statement
' Cycle through all records on Sheet1
Records = ActiveSheet.UsedRange.Rows.Count - 1
For i = 1 To Records
' Start Word And create an Object
Set WordApp = CreateObject("Word.Application")
With WordApp
.Documents.Add
End With
' Determine the file name
SaveAsName = ThisWorkbook.Path & "\" & "Test-" & i & ".docx" 'replace with company/city/state
' Information from worksheet
Set Data = Sheets("Sheet1").Range("A2")
' Update status bar progress message
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.StatusBar = "Processing Record " & i & " of " & Records
' Assign current data To variables
APPLICANT = Data.Offset(i - 1, 0).Value 'letter
CITY = Data.Offset(i - 1, 1).Value 'number
State = UCase(Data.Offset(i - 1, 2).Value) 'title
'Descript = Data.Offset(i - 1, 3).Value
'FMV = Format(Data.Offset(i - 1, 4).Value, "#,000")
'FMText = Data.Offset(i - 1, 5).Value
'Donor = Data.Offset(i - 1, 6).Value
' Send commands To Word
With WordApp
With .Selection
With .Section.PageSetup '***not being applied***
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.5)
.BottomMargin = InchesToPoints(0.5)
.LeftMargin = InchesToPoints(0.5)
.RightMargin = InchesToPoints(0.5)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.5)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
'Name, address, contact
.ParagraphFormat.Alignment = 2
.Font.Name = "Times New Roman"
.Font.Size = 14
.Font.Bold = True
.TypeText Text:="Name" & Chr(11)
.Font.Size = 12
.Font.Bold = False
.TypeText Text:="Address" & Chr(11)
.TypeText Text:="City, State Zip" & Chr(11)
.TypeText Text:="Phone" & Chr(11)
.TypeText Text:="Email: " '***hyperlink still in wrong font***
.Hyperlinks.Add Anchor:=.Range, _
Address:="mailto:joe@shmoe[URL="http://cnn.com"].com[/URL]", _
ScreenTip:="joe@shmoe.com", _
TextToDisplay:="jo[EMAIL="e@shmoe.com"]e@shmoe.com[/EMAIL]"
'horizontal line
.TypeParagraph
With .ParagraphFormat
.Alignment = 0
With .Borders(wdBorderTop)
.LineStyle = wdLineStyleThinThickSmallGap
.LineWidth = wdLineWidth300pt
.Color = wdColorAutomatic
End With
With .Borders
.DistanceFromTop = 1
.DistanceFromLeft = 4
.DistanceFromBottom = 1
.DistanceFromRight = 4
.Shadow = False
End With
End With
'date
.TypeText Text:=Chr(11) & Format(Date, "mmmm d, yyyy") & Chr(11)
'title
.TypeParagraph
.ParagraphFormat.Alignment = 1
.Font.Size = 18
.Font.Bold = True
.Font.Underline = True
.TypeText Text:="Document Title"
.Font.Size = 12
.Font.Bold = False
.Font.Underline = False
'body
.TypeParagraph
.ParagraphFormat.Alignment = 0
.TypeText Text:="blahblah...more text." & Chr(11) & Chr(11)
.TypeText Text:="blahblah...more text." & Chr(11) & Chr(11)
.TypeText Text:="blahblah...more text." & Chr(11) & Chr(11)
'data
.TypeParagraph
.TypeText Text:=APPLICANT & vTab & "AAA"
'.TypeText Text:=AAA
.TypeParagraph 'for each location
.TypeText Text:="blahblah...more text."
.TypeParagraph
.TypeText Text:="blahblah...more text." & Chr(11) & Chr(11)
.TypeParagraph 'for each location
.TypeText Text:="blahblah...more text."
End With
End With
' Save the Word file And Close it -- will need to move Word creation/save to within For/i loop
With WordApp
.ActiveDocument.SaveAs Filename:=SaveAsName
.ActiveWindow.Close
' Kill the Object
.Quit
End With
Set WordApp = Nothing
Next i
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub