I managed to add a table into the code. However, when I run the rest of the code, the text that is supposed to be after the table keeps appearing inside the table and not after it.
I want the result to be:
text
table
text
Const wdCharacter = 1
Const olMSGUnicode = 9
Const olMailItem As Long = 0
Dim oOutlook As Object
Dim myitem As Object
Dim ins As Object
Dim document As Object
Dim Word As Object
Dim selection As Object
Set oOutlook = CreateObject("Outlook.Application")
Set myitem = oOutlook.CreateItem(olMailItem)
myitem.To = DLookup("[ID]", "[RFQ]", "[RFQ No] = '" & Me.RFQText.Value & "'")
myitem.subject = "[PR Approval]_ " & Me.ItemDesText.Value & " (" & companynameshort & " Ref#" & Me.RFQText.Value & ")"
myitem.Display
Set ins = oOutlook.ActiveInspector
Set document = ins.WordEditor
Set Word = document.Application
Set selection = Word.selection
selection.TypeText Text:="Dear Requester,"
selection.TypeParagraph
selection.TypeParagraph
With selection
.Font.Bold = True
End With
selection.TypeText Text:="Please confirm that quotation of chosen vendor is suitable before proceeding with PR creation."
selection.TypeParagraph
selection.TypeParagraph
'add table here
With selection.Tables.Add(Range:=selection.Range, NumRows:=3, NumColumns:=2)
.Range.Font.Bold = True
.Cell(1, 1).Range.Text = "Initial quote"
.Cell(1, 2).Range.Text = "S$ 4080 (S$470/EA)"
.Cell(2, 1).Range.Text = "Discount rate"
.Cell(2, 2).Range.Text = "S$ 320 (7.8%)"
.Cell(3, 1).Range.Text = "Final quote"
.Cell(3, 2).Range.Text = "S$ 3760"
End With
selection.TypeParagraph
selection.Font.Reset
selection.TypeText Text:="1. Please assist to create SAP PR in ME51."
selection.TypeParagraph
selection.TypeText Text:="2. Note: Before deciding delivery date in SAP, please review vendor quotation lead time and provide ample time so that delivery can be met."
selection.TypeParagraph
selection.TypeText Text:="3. Attach this email including all relevant document in ME52."
selection.TypeParagraph
selection.TypeText Text:="4. Conduct <B0> Release for the PR created in ME54."
selection.TypeParagraph
selection.TypeText Text:="5. Once released, please inform relevant Managers to release the PR via email."
selection.TypeParagraph
selection.TypeParagraph
I tried adding line breaks using selection.TypeParagraph but it did not work
Related
I have a userform that allows users to insert an intentionally blank page after the cover page if they need to print the document. I can get this to work just fine when i only need to insert 1 or 2 blank pages throughout the document, however I now have a new document where i need to insert a total of 14 blank pages if the userform combobox is changed to "Printable Format"
The code i use for the current document is below as reference but I think for adding so many blank pages i'm better to use a loop or find instead of this.
All of my bookmarks for where blank pages are to be added are named "Print" with sequential numbers (ie. "Print 1", Print2" etc) so i was hoping to be able to search through the document for all bookmarks containing the name "Print" but i can't seem to figure it out!
Dim answer As Integer
Dim BMBreak As Range
Dim BMBreak2 As Range
With ActiveDocument
'Insert bookmarks applicable to Printable Format
If CbxPrint.Value = "Printable Format" Then
answer = MsgBox("You have changed the document to Printable Format." & vbNewLine _
& "This will add intentionally blank pages throughout the document " & vbNewLine _
& "Do you wish to continue?", vbOKCancel, "WARNING")
If answer = vbOK Then
'Intentional blank page after title page
Set BMRange = ActiveDocument.Bookmarks("Print1").Range
BMRange.Collapse wdCollapseStart
BMRange.InsertBreak wdPageBreak
BMRange.Text = "THIS PAGE IS INTENTIONALLY BLANK"
BMRange.ParagraphFormat.SpaceBefore = 36
BMRange.ParagraphFormat.Alignment = wdAlignParagraphCenter
ActiveDocument.Bookmarks.Add "Print1", BMRange
With BMRange
.Collapse Direction:=wdCollapseEnd
.InsertBreak Type:=wdSectionBreakContinuous
End With
With ActiveDocument.Sections(3)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
End With
With ActiveDocument.Sections(2)
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterPrimary).Range.Delete
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).Range.Delete
End With ```
Code like the following will process any number of Print# bookmarks (presently limited to 20, which need not all exist):
Dim i As Long, BMRange As Range
With ActiveDocument
If CbxPrint.Value = "Printable Format" Then
If MsgBox("You have changed the document to Printable Format." & vbCr & _
"This will add intentionally blank pages throughout the document " & vbCr _
& "Do you wish to continue?", vbOKCancel, "WARNING") = vbOK Then
'Process bookmarks applicable to Printable Format
For i = 20 To 1 Step -1
If .Bookmarks.Exists("Print" & i) = True Then
'Intentional blank page
Set BMRange = .Bookmarks("Print" & i).Range
With BMRange
.Collapse wdCollapseEnd
.InsertBreak Type:=wdSectionBreakNextPage
.InsertBreak Type:=wdSectionBreakNextPage
.Start = .Start - 1
.Sections.Last.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Sections.Last.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
With .Sections.First
.Headers(wdHeaderFooterPrimary).LinkToPrevious = False
.Footers(wdHeaderFooterPrimary).LinkToPrevious = False
.Headers(wdHeaderFooterPrimary).Range.Delete
.Footers(wdHeaderFooterPrimary).Range.Delete
.Range.InsertBefore "THIS PAGE IS INTENTIONALLY BLANK"
.Range.ParagraphFormat.SpaceBefore = 36
.Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
End With
.Start = .Start - 1
.Bookmarks.Add "Print" & i, .Duplicate
End With
End If
Next
End If
End If
End With
I feel I must be missing something obvious. I'm using VBA to build a Word document by writing lines to it one at a time. Once I've written a line, I need to format it - this could be bolding, setting tabstops, etc. But in order to format a line, I have to be able to refer to it. All the formatting facilities operate on a Range or a Selection - how do I identify the line I've just inserted as the Range I want to operate on? (Also, same question for table rows, as the doc also includes tables I'm building one row at a time, and I need to format cells as I go).
This is how to insert text and format it as you go, using a Range object. It's better to not try to simulate how a user works by using Selection and TypeText. The code runs more slowly and it's more difficult to work precisely. There can be only one Selection, but code can work with many Ranges...
The other important point to remember is to declare and instantiate objects as they're created - tables and table rows, for example.
Dim rng1 as Word.Range, rng2 as Word.Range
Set rng1 = ActiveDocument.Content
rng1.Text = "line one" & vbCr
rng1.Font.Bold = True
rng1.Collapse wdCollapseEnd
rng1.Text = "line two" & vbCr
rng1.Font.Bold = False
rng1.Collapse wdCollapseEnd
Set rng2 = rng1.Duplicate
rng2.Text = "line three" & vbCr
rng2.Font.Italic = True
'You can still work with the first range
rng1.ParagraphFormat.Alignment = wdAlignParagraphCenter
'
Dim tbl as Word.Table, rw1 as Word.Row, rw2 as Word.Row
Set tbl = ActiveDocument.Tables.Add
Set rw1 = tbl.Rows(1)
Set r2 = tbl.Rows.Add
Sub FormatBold()
Dim StartWord As String, EndWord As String
StartWord = "STARTSTART"
EndWord = "ENDEND"
With ActiveDocument.Content.Duplicate
.Find.Execute Findtext:=StartWord & "*" & EndWord, MatchWildcards:=True
.MoveStart wdCharacter, Len(StartWord)
.MoveEnd wdCharacter, -Len(EndWord)
.Font.Bold = True ' Or whatever you want to do
End With
End Sub
Format the text while you write it:
Sub StartTyping()
Selection.TypeText Text:="This is the "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="sentence"
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=" I am inserting." & vbCr
End Sub
I want to add many hyperlinks via VBA for my MS-Word file, for 1st paragraph the hyperlink is "./index/1.doc", 2nd paragraph is "./index/2.doc", and so on. The simpilfied procedure is 1)select one paragraph 2)add hyperlink, just as the following code says. However, the VBA code gives every paragraph same hyperlink which only should be for the last paragraph. So, is there any way to deselect in VBA to perform this case? Thanks
btw, the VBA can be tested on any MS-Word file with more than 1 paragraphs.
Sub addHypertext()
For countParagraph = 1 To ActiveDocument.Paragraphs.Count
Selection.Collapse Direction:=wdCollapseEnd
set para = ActiveDocument.Paragraphs(countParagraph)
para.Select
Set paraStyle = para.Style
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, \
Address:="./index/" & countParagraph & ".doc"
Rem this does not work
Rem Selection.Range.Style = paraStyle
Rem this does not work
Selection.Style = paraStyle
Rem this does not work too
Rem para.Style = paraStyle
Rem this produces "run-time error"
Rem para.Range.Style = "text"
Next
End Sub
I see what's happening. It is highlighting the paragraph tag and making it part of the hyperlink. I am curious if maybe you might just want to add a reference at the end of each paragraph instead. See if this is something you might want to try:
Sub addHypertext()
Dim para As Paragraph
For countParagraph = 1 To ActiveDocument.Paragraphs.Count
Selection.Collapse Direction:=wdCollapseEnd
Set para = ActiveDocument.Paragraphs(countParagraph)
para.Range.Select
Selection.MoveRight 1
Selection.MoveLeft 1
Selection.Font.Superscript = True
Selection.TypeText "[" + Trim(Str(countParagraph)) + "]"
Selection.MoveLeft Count:=Len("[" + Trim(Str(countParagraph)) + "]"), Extend:=wdExtend
para.Range.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="./index/" & countParagraph & ".doc"
Selection.Font.Superscript = False
Next
End Sub
The above will put a reference link at the end of each paragraph like wikipedia does on their site.
The following will get the whole paragraph as the link as it looks like you initially wanted:
Sub addHypertext()
Dim para As Paragraph
For countParagraph = 1 To ActiveDocument.Paragraphs.Count
Selection.Collapse Direction:=wdCollapseEnd
Set para = ActiveDocument.Paragraphs(countParagraph)
para.Range.Select
Selection.MoveEnd Count:=-1
para.Range.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="./index/" & countParagraph & ".doc"
Next
End Sub
EDIT
To answer your addition as to styles, the following still keeps the link and changes the style.
Sub addHypertext()
Dim para As Paragraph
For countParagraph = 1 To ActiveDocument.Paragraphs.Count
Selection.Collapse Direction:=wdCollapseEnd
Set para = ActiveDocument.Paragraphs(countParagraph)
para.Range.Select
Selection.MoveEnd Count:=-1
para.Range.Hyperlinks.Add Anchor:=Selection.Range, _
Address:="./index/" & countParagraph & ".doc"
para.Range.Select
Selection.MoveEnd Count:=-1
'Per your comments below for future visitors
Selection.Style = "Normal"
Selection.Style = "My Custom Style"
Next
End Sub
I have never used VBA for mailmerge before and recently inherited a docm created a few years ago. My two issues are:
1. How do I get the email to be sent as HTML? Have tried wdMailFormatHTML but it does not work.
2. The data source is in an excel file with headers. The "table" header does not align with the text below. What I want is for the header to adjust width to match the data below. Have tried numerous ways to fix the alignment within the document but to no avail. Also tried to add Column width to the code but I am probably doing it wrong as nothing seem to be working.
Below is the original code. Would appreciate if someone could help.
Sub RunMerge()
Application.ScreenUpdating = False
Dim Doc1 As Document, Doc2 As Document, Doc3 As Document, StrDoc As String
Set Doc1 = ThisDocument
StrDoc = ThisDocument.Path & "\EmailDataSource.doc"
If Dir(StrDoc) <> "" Then Kill StrDoc
With Doc1.MailMerge
If .State = wdMainAndDataSource Then
.Destination = wdSendToNewDocument
.Execute
Set Doc2 = ActiveDocument
End If
End With
Call EmailMergeTableMaker(Doc2)
With Doc2
.SaveAs FileName:=StrDoc, AddToRecentFiles:=False, FileFormat:=wdFormatDocument
StrDoc = .FullName
.Close
End With
Set Doc2 = Nothing
Set Doc3 = Documents.Open(FileName:=Doc1.Path & "\Email Merge Main Document.doc", _
AddToRecentFiles:=False)
With Doc3.MailMerge
.MainDocumentType = wdEMail
.OpenDataSource Name:=StrDoc, ConfirmConversions:=False, ReadOnly:=False, _
LinkToSource:=True, AddToRecentFiles:=False, Connection:="", SQLStatement:="", _
SQLStatement1:="", SubType:=wdMergeSubTypeOther
If .State = wdMainAndDataSource Then
.Destination = wdSendToEmail
.MailAddressFieldName = "Recipient"
.MailSubject = "TrackView follow-up - Missing timesheets/approvals"
.MailFormat = wdMailFormatPlainText
.Execute
End If
End With
Doc3.Close SaveChanges:=False
Set Doc3 = Nothing
Application.ScreenUpdating = True
End Sub
Sub EmailMergeTableMaker(DocName As Document)
Dim oTbl As Table, i As Integer, j As Integer, oRow As Row, oRng As Range, strTxt As String
With DocName
.Paragraphs(1).Range.Delete
Call TableJoiner
For Each oTbl In .Tables
j = 2
With oTbl
i = .Columns.Count - j
For Each oRow In .Rows
Set oRng = oRow.Cells(j).Range
With oRng
.MoveEnd Unit:=wdCell, Count:=i
.Cells.Merge
strTxt = Replace(.Text, vbCr, vbTab)
On Error Resume Next
If Len(strTxt) > 1 Then .Text = Left(strTxt, Len(strTxt) - 2)
End With
Next
End With
Next
For Each oTbl In .Tables
For i = 1 To j
oTbl.Columns(i).Cells.Merge
Next
Next
With .Tables(1)
.Rows.Add BeforeRow:=.Rows(1)
.Cell(1, 1).Range.Text = "Recipient"
.Cell(1, 2).Range.Text = "Data"
End With
.Paragraphs(1).Range.Delete
Call TableJoiner
End With
Set oRng = Nothing
End Sub
Private Sub TableJoiner()
Dim oTbl As Table
For Each oTbl In ActiveDocument.Tables
With oTbl.Range.Next
If .Information(wdWithInTable) = False Then .Delete
End With
Next
End Sub
Use the HTMLBody property of the mailitem
Dim OutMail As Object
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.Attachments.Add
.body = ""
.CC = ""
.HTMLBody = ""
.subject = ""
.to = emailTo
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
There are at least two potential problems here.
One is that the wdMailFormatHTML parameter will only work with the full version of Outlook, not Outlook Express, etc. etc., i.e. Outlook must be the default email client on the relevant system for this to work. (Other email clients obviously "do" HTML emails - it's just that none of them are known to work with the mechanism Word uses to send HTML emails).
Assuming that you are using Outlook, the second problem is that the email merge process is just emailing the text that has been placed in the Data column in the EmailDataSource.doc, which is the data source for the merge to email. The way that the EmailMergeTableMaker routine works at present, that data will be a tab-separated block of text. Word will probably expand the tabs into some white space, but it will not generate an HTML table. So that is probably the origin of the alignment problem. If so, you need to ensure that that each cell contains a table instead.
It would probably be better to do that by rethinking the way that EmailMergeTableMaker works. The following "quick fix" worked on some sample data here, but I did not test situations where for example the cell is empty.
After this code...
With .Tables(1)
.Rows.Add BeforeRow:=.Rows(1)
.Cell(1, 1).Range.Text = "Recipient"
.Cell(1, 2).Range.Text = "Data"
End With
.Paragraphs(1).Range.Delete
Call TableJoiner
...insert the following:
' you should really move this Dim statement to the top
' of the Sub and merge it with the existing Dim
Dim oCellRng as Range
With .Tables(1)
For i = 2 To .Rows.Count
Set oCellRng = .Cell(i, 2).Range
oCellRng.MoveEnd wdCharacter, -1
oCellRng.ConvertToTable vbTab
Set oCellRng = Nothing
Next
End With
If you are not using Outlook, then you will not be able to use MailMerge directly to create HTML format message, and you obviously won't be able to use the Outlook object model to do it, so I think you then have to think in terms of generating HTML format emails and sending them some other way (e.g. directly via SMTP), but that is a whole other story.
The other way to send emails via Outlook is to automate Outlook, as Thomas Inzina suggests. However, that will also require you to make other changes to the way your merge works.
FWIW the routines you are using come from a tutotial by "macropod" - I don't have a link for it but a search for "macropod Catalogue MailMerge Tutorial" may lead you to it and to other ways to solve this type of problem.
I am generating a word document from excel using VBA. I have a for loop that I would like to add a [1 row, 1 column, bordered] table to. This is an area where the user can put their comments inside a word document. When I try to add .table.add I have been getting different errors ranging from object errors. This is what I have so far:
Sub GenDocumentables()
Worksheets("checklist").Activate
Dim wdApp As Word.Application
Set wdApp = New Word.Application
Dim saveName As String
Dim NumberOfCells As Integer
With wdApp
.Visible = True
.Activate
'Debug.Print .Version
.Documents.Add
With .Selection
.InsertBreak Type:=wdPageBreak
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.BoldRun
.Font.Size = 13
.TypeText "Documentable Items for "
.TypeText Range("d4").Value
.BoldRun
.TypeParagraph
End With
NumberOfCells = Range("a4", Range("a3").End(xlDown)).Count
For loopcounter = 1 To 2 ' NumberOfCells
With .Selection
.Font.Bold = False
.Style = wdStyleHeading3
.TypeText Range("a3").Offset(loopcounter, 0).Value & " - "
.TypeText Range("a3").Offset(loopcounter, 4).Value
.TypeParagraph
.Font.Size = 10
.TypeText Range("a3").Offset(loopcounter, 5).Value
.TypeParagraph
.Font.Italic = True
.TypeText "<<Please enter your commentary here. Ensure all aspects of the check content are met>>"
.TypeParagraph
'-------------------ADD TABLE HERE-------------------
End With
Next
Set myRange = ActiveDocument.Range(0, 0)
ActiveDocument.TablesOfContents.Add Range:=myRange, UseFields:=False, UseHeadingStyles:=True, LowerHeadingLevel:=3, UpperHeadingLevel:=1
With .Selection
.GoTo What:=wdGoToSection, Which:=wdGoToFirst
.InsertBreak Type:=wdPageBreak
End With
saveName = Environ("UserProfile") & "\Desktop\My Word Doc_" & Format(Now, "yyyy-mm-dd hh-mm-ss") & ".docx"
.ActiveDocument.SaveAs2 saveName
'.ActiveDocument.Close
'.Quit
End With
MsgBox "done!"
End Sub
You are getting object errors due to the fact that Selection does not have a method .Table
To get around this, you'll want to use the line:
Set newTable = wdApp.ActiveDocument.Tables.Add(SomeRange,1,1)
Tables is a member of Document, which you can retrieve using the section wdApp.ActiveDocument.
Here, SomeRange needs to be defined for this to work properly.
To try and get this code running, lets try and add a few variables to make this easier.
Back where you declare your other variables add these:
Dim myRange As Word.Range
Dim wdDoc As Word.Document
Dim newTable As Word.Table
and before you enter your loop, AFTER you create the document add:
Set wdDoc = wdApp.ActiveDocument
Next, inside of your loop, but after your End With (.Selection) you could add:
Set myRange = wdDoc.Range(wdDoc.Content.End - 1, wdDoc.Content.End)
Set newTable = wdDoc.Tables.Add(myRange, 1, 1)
newTable.Cell(1, 1).Range.Text = "Hello"
Set myRange = wdDoc.Range(wdDoc.Content.End - 1, wdDoc.Content.End)
myRange.Select
Let's go through what this does.
First, it sets out custom variable myRange to be the last character in the document. This allows us to place the Table underneath everything that's already been created,
Next, it creates a table at this location, with the size 1x1.
The value of the first cell in this table is set to "Hello"
The next line then AGAIN sets the range to the bottom of the file, then selects it. This is neccessary because creating a table changes the selection to be inside of the new table. Skipping this line would have you then run the next iteration of the loop INSIDE of the table.
Hope this helps.