I am trying to make a vba code in word to automating of insertion of tabels when a checkbox is cheked (True). But I get different type of error, deppending on whether I use the Boolean varable Checkbox1 or the ContentControl varable Checkbox1 in the IF statement, see the code below.
I have many of these checkboxes, in my document, så when the user click and chose one (or more) checkboxes the program shall insert a table for that specific checkbox.
Sub CheckBox_Click()
'Dim CheckBox1 As Boolean
Dim nytbl As Table
Dim CheckBox1 As ContentControl
Set CheckBox1 = Selection.Range.ContentControls.Add(wdContentControlCheckBox)
' CheckBox1.Checked = False
If (CheckBox1.Checked = True) Then
Set MyRange = ActiveDocument.Content
MyRange.Collapse Direction:=wdCollapseEnd
Set nytbl = ActiveDocument.Tables.Add(Range:=MyRange, NumRows:=3, NumColumns:=1)
nytbl.Select
nytbl.AutoFormat Format:=wdTableFormatList3
' formating of the table
With nytbl
.Cell(1, 1).Height = 30
.Cell(1, 1).Shading.BackgroundPatternColor = -738132173
.Cell(1, 1).Range.Font.Name = "Arial"
.Cell(1, 1).Range.Font.Size = 12
.Cell(1, 1).Range.Font.Bold = True
.Cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Cell(1, 1).Range.Font.TextColor = wdColorBlack
.Cell(1, 1).Range.InsertAfter " APPLIKATIONER "
.Cell(1, 1).VerticalAlignment = wdCellAlignVerticalCenter
.Cell(2, 1).Height = 30
.Cell(2, 1).Shading.BackgroundPatternColor = RGB(226, 239, 217)
.Cell(2, 1).Range.Font.Name = "Arial"
.Cell(2, 1).Range.Font.Size = 10
.Cell(2, 1).Range.Font.Bold = False
.Cell(2, 1).Range.Font.Italic = True
.Cell(2, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.Cell(2, 1).Range.Font.TextColor = wdColorBlack
.Cell(2, 1).Range.InsertAfter " Applikationer kan indeholde data vedr. installerede applikationer. "
.Cell(2, 1).VerticalAlignment = wdCellAlignVerticalCenter
End With
End If
ActiveDocument.Paragraphs.Add 'insert new empty line
ActiveDocument.Paragraphs.Add 'insert new empty line
ActiveDocument.Paragraphs.Add 'insert new empty line
End Sub
Related
I want to insert 2 column and one row in header using vba. I tried the following code but it works one time and gives the error 6028 (the range cannot be deleted) other time. Can any one suggest me any solution.
Sub UpdateHeader()
Dim oDoc As Word.Document, oSec As Word.Section, rng As Word.Range
Set oDoc = ActiveDocument
For Each oSec In oDoc.Sections
Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterFirstPage).Range
AddHeaderToRange rng
Set rng = oSec.Headers(Word.WdHeaderFooterIndex.wdHeaderFooterPrimary).Range
AddHeaderToRange rng
Next oSec
End Sub
Private Sub AddHeaderToRange(rng As Word.Range)
With rng
.Tables.Add Range:=rng, NumRows:=1, NumColumns:=2
With .Tables(1)
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
.Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
.Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
.Cell(1, 2).Range.Font.Name = "Arial"
.Cell(1, 2).Range.Font.Size = 9
.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Cell(1, 2).Range.Text = "Test header" & vbNewLine & "Second Line"
End With
End With
End Sub
Try:
Sub UpdateHeaders()
Application.ScreenUpdating = False
Dim Tbl As Table, Sctn As Section
With ActiveDocument
Set Tbl = .Tables.Add(Range:=.Range(0, 0), NumRows:=1, NumColumns:=2)
With Tbl
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleNone
.Rows.SetLeftIndent LeftIndent:=-37, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=300, RulerStyle:=wdAdjustNone
.Cell(1, 1).Range.InlineShapes.AddPicture FileName:="Your Pic Solution", LinkToFile:=False, SaveWithDocument:=True
.Cell(1, 2).Range.Font.Name = "Arial"
.Cell(1, 2).Range.Font.Size = 9
.Cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
.Cell(1, 2).Range.Text = "Test header" & vbCr & "Second Line"
End With
For Each Sctn In .Sections
With Sctn
With .Headers(wdHeaderFooterPrimary)
If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
End With
With .Headers(wdHeaderFooterFirstPage)
If .LinkToPrevious = False Then .Range.FormattedText = Tbl.Range.FormattedText
End With
End With
Next
Tbl.Delete
End With
Application.ScreenUpdating = True
End Sub
From an subroutine in Excel, I am trying to create a header in a Word document with two words each with different font formatting however the last font formatting wins. Any help would be appreciated! Below is my current code snippet.
With myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
.Font.Name = "Courier New"
.Font.Size = 10
.Font.Bold = True
.Font.Color = wdColorGreen
.text = "TEXT LINE 1" & vbLf
.Font.Name = "Calibri Light"
.Font.Size = 16
.Font.Bold = False
.Font.Color = wdColorBlack
.text = .text & "TEXT LINE 2"
....the rest of the code....
UPDATE: I solved the issue by explicitly setting the range. See code snippet below.
With myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
.Start = 0
.text = "TEXT LINE 1" & vbLf
.End = Len(.text)
.Font.Name = "Courier New"
.Font.Size = 10
.Font.Bold = True
.Font.Color = wdColorGreen
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Start = Len(.text) + 1
.text = "TEXT LINE 2"
.End = Len(.text) + .Start
.Font.Name = "Calibri Light"
.Font.Size = 16
.Font.Bold = False
.Font.Color = wdColorBlack
This can be done a bit more efficiently / elegantly than the code posted in the "update". Relying on Start and End values is always a bit chancy with Word since Word can stick "hidden" content into the text flow. To get to the beginning or end of a Range it's more reliable to use Collapse. This will also be faster than doing calculations with values.
Dim rng as Word.Range
Set rng = myDoc.Sections(1).Headers(wdHeaderFooterPrimary).Range
With
'.Start = 0 'Not necessary as this will be the default position
.text = "TEXT LINE 1" & vbLf
'.End = Len(.text) 'Also not necessary, see further down...
.Font.Name = "Courier New"
.Font.Size = 10
.Font.Bold = True
.Font.Color = wdColorGreen
.ParagraphFormat.Alignment = wdAlignParagraphCenter
.Collapse wdCollapseEnd 'put focus at end of range
'.Start = Len(.text) + 1 'calculation not necessary as range has been collapsed
.text = "TEXT LINE 2"
'.End = Len(.text) + .Start 'not necessary
.Font.Name = "Calibri Light"
.Font.Size = 16
.Font.Bold = False
.Font.Color = wdColorBlack
End With
I wrote the code below to add an image to header. I placed the .png file in a network file. The following code works in my PC, but not in a different PC which also has access to the same network drive. It does import the image into the header but throws an error at the (.addpicture) line as shown in attached image. Wondering why the same code which works in one computer is bombing in the other one. Appreciate any directions. Thanks
Private Sub AddHeaderToRange(rng As Word.Range)
Dim sFindText As String
With rng
.Tables.Add Range:=rng, NumRows:=1, NumColumns:=2 'DefaultTableBehavior:=wdWord8TableBehavior,
AutoFitBehavior:=wdAutoFitFixed
With .Tables(1)
.PreferredWidth = Application.InchesToPoints(7)
.Rows.Alignment = wdAlignRowCenter
.Borders.InsideLineStyle = wdLineStyleNone
.Borders.OutsideLineStyle = wdLineStyleSingle
.Rows.SetLeftIndent LeftIndent:=0, RulerStyle:=wdAdjustNone
.Columns(1).SetWidth ColumnWidth:=200, RulerStyle:=wdAdjustNone
.Columns(2).SetWidth ColumnWidth:=225, RulerStyle:=wdAdjustNone
.cell(1, 1).Range.InlineShapes.AddPicture
Filename:="\\srv2\gv1\eng\strss\Pics\Testlogo.png", LinkToFile:=False,
SaveWithDocument:=True
.cell(1, 2).Range.Font.name = "Arial"
.cell(1, 2).Range.Font.Size = 12
.cell(1, 1).Range.ParagraphFormat.Alignment = wdAlignParagraphLeft
.cell(1, 2).Range.Text = Sheets("Start").Range("P9").Value & " " &
Sheets("Start").Range("P10").Value
sFindText = Sheets("Start").Range("P9").Value & " " & Sheets("Start").Range("P10").Value
.cell(1, 2).Range.ParagraphFormat.Alignment = wdAlignParagraphRight
For Each r In .Rows
r.Borders(wdBorderLeft) = wdLineStyleNone
r.Borders(wdBorderRight) = wdLineStyleNone
r.Borders(wdBorderTop) = wdLineStyleNone
Next
.Rows(1).Cells.VerticalAlignment = wdAlignVerticalBottom
.AutoFitBehavior (wdAutoFitWindow)
'.Rows.WrapAroundText = True
End With
.ParagraphFormat.SpaceBefore = 0
.ParagraphFormat.SpaceAfter = 0
End With
With rng.Find
.Text = sFindText
If .Execute(Forward:=True) = True Then
rng.Fields.Add rng, _
wdFieldEmpty, _
"DocProperty TitleReference", PreserveFormatting:=True
End If
End With
Exit Sub
eh:
Call Errorhandler("AddHeaderToRange", Err)
End Sub
The syntax is:
Activedocument.Tables(1).Rows(1).Cells(1).Range.InlineShapes.AddPicture
After you fix that, you'll also get errors for the following lines that use .cell instead of Rows(1).Cells(1).
I am doing a document using a userform. In the userform I setup radiobuttons when clicked I want the text from a macro that I did to be inserted at a specific bookmark in my document. Help please
This is my macro:
Sub ordonnance()
'
' ORDONNANCE Macro
'
'
Dim bmSignet As Bookmark
Dim rgPlageDuSignet As Range
Set bmSignet = ActiveDocument.Bookmarks("ORDONNANCE_DE")
Set rgPlageDuSignet = bmSignet.Range
rgPlageDuSignet.Select
ActiveDocument.Tables.Add rgPlageDuSignet, 1, 1
With Selection.Tables(1)
If .Style <> "Grille du tableau" Then
.Style = "Grille du tableau"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Selection.Font.Name = "Arial"
Selection.Font.Size = 12
Selection.Font.Bold = wdToggle
Selection.TypeText Text:="ORDONNANCE DE NON-PUBLICATION ..."
Set bmSignet = Nothing
Set rgPlageDuSignet = Nothing
End Sub
This is my radiobutton:
Private Sub OptionButton3_Click()
If Me.OptionButton3.Value = True Then
Call RemplaceSignet("ORDONNANCE_DE", "ORDONNANCE DE NON-PUBLICATION ...")
Else
Call RemplaceSignet("ORDONNANCE_DE", " ")
End If
End Sub
Try:
Sub ordonnance(StrBkMk As String, StrTxt As String)
'
' ORDONNANCE Macro
'
'
Dim Tbl As Table
With ActiveDocument
Set Tbl = .Tables.Add(.Bookmarks(StrBkMk).Range, 1, 1)
With Tbl
.Style = "Grille du tableau"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
With .Cell(1, 1).Range
With .Font
.Name = "Arial"
.Size = 12
.Bold = True
End With
.Text = StrTxt
End With
End With
End With
Set Tbl = Nothing
End Sub
Note that there is no need to select anything.
I am using this code which specifically places the text in the precise cell I want using this code:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr & myText2
End With
The problem I am having is "myText2" is not supposed to be underlined or bold.
I have tried this:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr
.Font.Bold = False
.Font.Underline = False
.Text = myText2
End With
But what happens is the first myText1 gets deleted and all I am left with is myText2.
and this
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.InsertAfter myText1 & vbCr & vbCr
.Font.Bold = False
.Font.Underline = False
.InsertAfter myText2
While this appends the text, the formatting for the entire post is no underline or bold, when the end result is supposed to look like
Header
Body
How can I reformat myText2, have it post, without losing the formatted myText1 above?
In your code you have set the With statement to work with the entire range of the cell. This results in the formatting being applied to the entire cell.
You don't have to use the Selection object to apply formatting, you just need to make sure that you are working with the correct range. Using the Selection object makes the code run more slowly as it moves the cursor around.
I have rewritten your code below.
Sub AddTextToCell()
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Text = myText1 & vbCr & vbCr & myText2
With .Font
.Name = "Times New Roman"
.Size = 12
.Bold = False
.Underline = False
End With
With .Paragraphs.First.Range.Font
.Bold = True
.Underline = True
End With
End With
End Sub
Normally it is better to enter text the way you do, without using Select, but when applying different formats to different parts of a cell I think you have to use it. I had to change the order of the formatting and step around a bit in the document to make it work:
Dim myText1 As String
Dim myText2 As String
myText1 = "Header"
myText2 = "Body"
With ActiveDocument.Tables(1).Cell(2, 2).Range
.Font.Name = "Times New Roman"
.Font.Size = 12
.Font.Bold = True
.Font.Underline = True
.Text = myText1 & vbCr & vbCr
End With
'Select the whole cell
ActiveDocument.Tables(1).Cell(2, 2).Select
'Move to the right
Selection.Collapse Direction:=wdCollapseEnd
'Move back to the left
Selection.MoveLeft wdCharacter, 1
'Add the text (using the myText1 format)
Selection.Range.Text = myText2
'Select the on word the right (myText2)
Selection.MoveRight wdWord, 1, True
'Format myText2
Selection.Range.Font.Underline = False
Selection.Range.Font.Bold = False