So, after running the code bellow, i want to send users back to the top of the first page. Tried to use Selection.HomeKey Unit:=wdStory and the GoTo metod, but nothing seen to work properly.
Now, after the code runs, the user is always back to the end of the first page.
Some clue on why is this happening?
This is the code.
Private Sub OptionButton5_Click()
'Orange
Dim sShapes As Shape
Dim Orange
Dim Green
Dim DarkOrange
Dim DarkGreen
Dim White
DarkOrange = RGB(252, 138, 74)
Orange = RGB(253, 189, 153)
Green = RGB(70, 184, 160)
DarkGreen = RGB(28, 76, 66)
White = RGB(255, 255, 255)
Application.ScreenUpdating = False
If OptionButton5.Value = True Then
If MsgBox("Deseja mudar para Santa Lucia?" & vbNewLine & vbNewLine & "Isso pode levar algum tempo", vbYesNo, "Mudança de Modelo") = vbYes Then
GoTo Label2
Else
GoTo Label1
End If
Label2:
ActiveDocument.Bookmarks("TabelaConta").Select
Selection.Tables(1).Style = "Tabela de Grade 2 - Ênfase 2"
ActiveDocument.Bookmarks("ListaEspecie").Select
Selection.Style = "Tabela de Grade 2 - Ênfase 2"
ActiveDocument.Bookmarks("ListaEspecie").Range.Rows.LeftIndent = -37.15
Selection.Collapse wdCollapseEnd
Selection.GoTo wdGoToPage, wdGoToAbsolute, 1
ActiveDocument.Bookmarks("santa").Range.Font.Hidden = False
ActiveDocument.Bookmarks("ultrafarma").Range.Font.Hidden = True
End If
For Each sShapes In ActiveDocument.Shapes
If InStr(sShapes.Name, "Rectangle") Then
sShapes.Fill.ForeColor.RGB = DarkOrange
ElseIf InStr(sShapes.Name, "TagAmarelaEscura") Then
sShapes.Fill.ForeColor.RGB = DarkOrange
ElseIf InStr(sShapes.Name, "TagAmarelaClara") Then
sShapes.Fill.ForeColor.RGB = Orange
ElseIf InStr(sShapes.Name, "LinhaGrossa") Then
sShapes.Fill.ForeColor.RGB = Orange
ElseIf InStr(sShapes.Name, "Quad") Then
sShapes.Fill.ForeColor.RGB = Orange
ElseIf InStr(sShapes.Name, "BolaCor") Then
sShapes.Fill.ForeColor.RGB = Green
ElseIf InStr(sShapes.Name, "Reta") Then
sShapes.Line.ForeColor.RGB = Green
ElseIf InStr(sShapes.Name, "Titulo") Then
sShapes.Fill.Visible = msoFalse
sShapes.TextFrame.TextRange.Font.Fill.ForeColor.RGB = White
ElseIf InStr(sShapes.Name, "Oval") Then
sShapes.Fill.ForeColor.RGB = DarkGreen
End If
Next sShapes
Application.ScreenUpdating = True
Selection.HomeKey Unit:=wdStory
Label1:
End Sub
Related
I want to add, via VBA in MS Word, a Textbox at the current cursor position.
This works but if the cursor is located within a table (whatever cell), a Textbox gets added in the wrong location.
Sub AddTextBox()
Dim oShape As Shape
Dim x As Long
Dim y As Long
'get Cursorposition
x = Selection.Information(wdHorizontalPositionRelativeToPage)
y = Selection.Information(wdVerticalPositionRelativeToPage)
Set oShape = ActiveDocument.Shapes.AddTextBox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x, Top:=y, Width:=200, Height:=12)
With oShape
With .TextFrame
With .TextRange
.Text = "TEXT"
.Font.Name = "Segoe Script"
.Font.Size = 10
.Font.ColorIndex = wdRed
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
.MarginBottom = Application.CentimetersToPoints(0.15)
.MarginTop = Application.CentimetersToPoints(0.15)
.MarginLeft = Application.CentimetersToPoints(0.1)
.MarginRight = Application.CentimetersToPoints(0.1)
.WordWrap = False
.AutoSize = True
End With
.LockAnchor = False
.WrapFormat.Type = wdWrapNone
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Height = Application.CentimetersToPoints(0.8)
End With
End Sub
How do I place the TextBox at the cursor position, when the cursor is placed in a table?
When you add a shape the position defaults to being relative to the margin, so you need to set the required relative position after you have added the shape.
Sub AddTextBox()
Dim oShape As Shape
Dim x As Long
Dim y As Long
'get Cursorposition
x = Selection.Information(wdHorizontalPositionRelativeToPage)
y = Selection.Information(wdVerticalPositionRelativeToPage)
Set oShape = ActiveDocument.Shapes.AddTextBox( _
Orientation:=msoTextOrientationHorizontal, _
Left:=x, Top:=y, Width:=200, Height:=12, Anchor:=Selection.Range)
With oShape
.LeftRelative = wdRelativeHorizontalPositionPage
.TopRelative = wdRelativeVerticalPositionPage
.LockAnchor = False
.WrapFormat.Type = wdWrapNone
With .TextFrame
With .TextRange
.Text = "TEXT"
.Font.Name = "Segoe Script"
.Font.Size = 10
.Font.ColorIndex = wdRed
.ParagraphFormat.Alignment = wdAlignParagraphLeft
End With
.MarginBottom = Application.CentimetersToPoints(0.15)
.MarginTop = Application.CentimetersToPoints(0.15)
.MarginLeft = Application.CentimetersToPoints(0.1)
.MarginRight = Application.CentimetersToPoints(0.1)
.WordWrap = False
.AutoSize = True
End With
.Fill.Visible = msoFalse
.Line.Visible = msoFalse
.Height = Application.CentimetersToPoints(0.8)
End With
End Sub
I am seeking a way to insert a watermark into Word documents. Here is the code I get by recording Macros,
Sub add_watermark()
'
' Macro2 Macro
'
'
ActiveDocument.Sections(1).Range.Select
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.HeaderFooter.Shapes.AddTextEffect( _
PowerPlusWaterMarkObject354239640, "PAID", "arial", 1, False, False, 0, 0 _
).Select
Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640"
Selection.ShapeRange.TextEffect.NormalizedHeight = False
Selection.ShapeRange.Line.Visible = False
Selection.ShapeRange.Fill.Visible = True
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
Selection.ShapeRange.Fill.Transparency = 0
Selection.ShapeRange.Rotation = 315
Selection.ShapeRange.LockAspectRatio = True
Selection.ShapeRange.Height = CentimetersToPoints(9.31)
Selection.ShapeRange.Width = CentimetersToPoints(13.96)
Selection.ShapeRange.WrapFormat.AllowOverlap = True
Selection.ShapeRange.WrapFormat.Side = wdWrapNone
Selection.ShapeRange.WrapFormat.Type = 3
Selection.ShapeRange.RelativeHorizontalPosition = _
wdRelativeVerticalPositionMargin
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionMargin
Selection.ShapeRange.Left = wdShapeCenter
Selection.ShapeRange.Top = wdShapeCenter
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
But I have an "out of range" error after running the Macro in another document. When I debug it, this line
"Selection.ShapeRange.Name = "PowerPlusWaterMarkObject354239640" is highlighted.
Does anyone know how to tackle it?
Thanks,
Try something based on:
Sub AddPaidWatermark()
Application.ScreenUpdating = False
Dim sWdth As Single, Shp As Shape
With ActiveDocument.Sections(1)
With .PageSetup
sWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With .Headers(wdHeaderFooterPrimary)
If .Range.Characters.First.Information(wdWithInTable) = True Then
With .Range.Tables(1)
.Rows.Add .Rows(1)
.Split .Rows(2)
End With
.Range.Tables(1).Delete
.Range.Paragraphs(1).Range.Font.Hidden = True
End If
Set Shp = .Shapes.AddTextEffect(msoTextEffect1, "PAID", "Arial", 1, False, False, 0, 0)
End With
With Shp
.WrapFormat.Type = wdWrapBehind
.ZOrder msoBringToFront
.Height = sWdth / 2 ^ 0.5
.Width = .Height
.Rotation = 315
.RelativeHorizontalPosition = wdRelativeVerticalPositionMargin
.RelativeVerticalPosition = wdRelativeVerticalPositionMargin
.Left = wdShapeCenter
.Top = wdShapeCenter
With .Fill
.Visible = True
.Solid
.ForeColor.RGB = RGB(192, 192, 192)
End With
End With
End With
Application.ScreenUpdating = True
End Sub
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 want to create a VBA script in Microsoft Word to find inside a txt file if exist some line with ":" character. If this is true, I want to get this line, split it and insert this information in a table that is in main file. To this objetive, I want to go through all found lines to get this information.
For this, I have this code:
Dim arrNames
Dim cont As Integer
cont = 0
strPath = ActiveDocument.name
Documents.Open path & "Mails.txt"
strPath2 = ActiveDocument.name
With Selection.Find
.Text = ":"
Do While .Execute(Forward:=True, Format:=True) = True
Selection.Find.Execute FindText:=(":")
Selection.Expand wdLine
arrNames = Split(Selection.Text, ":")
Documents(strPath).Activate
If cont = 0 Then
Call gestOSINT("Pwd")
Selection.Find.Execute FindText:=("[Pwd]")
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=1, NumColumns:= _
3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed
With Selection.Tables(1)
If .Style <> "Tabla con cuadrícula" Then
.Style = "Tabla con cuadrícula"
End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
End With
Set tblNew = Selection.Tables(1)
tblNew.Style = "Tabla de lista 1 clara - Énfasis 1"
Selection.TypeText Text:="Correo electrónico"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="Tipo de filtrado"
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:="Plataforma"
End If
Set rowNew = tblNew.Rows.Add
rowNew.Cells(1).Range.Text = arrNames(0)
rowNew.Cells(2).Range.Text = arrNames(1)
rowNew.Cells(3).Range.Text = arrNames(2)
cont = cont + 1
Documents(strPath2).Activate
Selection.Text = arrNames(0) & vbCrLf
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.Collapse wdCollapseEnd
Loop
End With
Documents(strPath2).Activate
ActiveDocument.Close SaveChanges:=wdDoNotSaveChanges
Documents(strPath).Activate
If cont = 0 Then
pwdMails = False
Else
pwdMails = True
End If
And Mails.txt file contain the following:
mail#mail.com
mail2#mail.com
mail3#mail.com:word1:word2
mail4#mail.com
mail5#mail.com:word3:word4
The first line which contain ":", line 3 in Mails.txt, was found but the second line, line 5 in Mails.txt, wasn't found.
Why occur this? How can I fix it?
Here is a version that reads the file via FileSystemObject and avoids using Selection. PLease note that I commented out lines that do not work for me (style names, custom functions).
Also: you are applying two styles to the table, first one then the other. Please pick one. ;-)
Const ForReading = 1
Dim arrNames
Dim cont As Integer
Dim fso, MyFile, FileName, TextLine, tblNew As Table, newRow As Row
Set fso = CreateObject("Scripting.FileSystemObject")
cont = 0
If cont = 0 Then
'Call gestOSINT("Pwd")
'Selection.Find.Execute FindText:=("[Pwd]")
Set tblNew = ActiveDocument.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:= _
3, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed)
With tblNew
' If .Style <> "Tabla con cuadrícula" Then
' .Style = "Tabla con cuadrícula"
' End If
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
.ApplyStyleRowBands = True
.ApplyStyleColumnBands = False
' .Style = "Tabla de lista 1 clara - Énfasis 1"
End With
With tblNew.Rows(1)
.Cells(1).Range.text = "Correo electrónico"
.Cells(2).Range.text = "Tipo de filtrado"
.Cells(3).Range.text = "Plataforma"
End With
End If
FileName = path & "Mails.txt"
Set MyFile = fso.OpenTextFile(FileName, ForReading)
Do While MyFile.AtEndOfStream <> True
TextLine = MyFile.ReadLine
If InStr(1, TextLine, ":") > 0 Then
arrNames = VBA.split(TextLine, ":")
Set rowNew = tblNew.Rows.Add
rowNew.Cells(1).Range.text = arrNames(0)
rowNew.Cells(2).Range.text = arrNames(1)
rowNew.Cells(3).Range.text = arrNames(2)
End If
Loop
MyFile.Close
If cont = 0 Then
pwdMails = False
Else
pwdMails = True
End If
I want a textbox where the first line and subsequent lines of text have different formatting, but they must be in the same textbox. This is what I currently have, which applies the same formatting to all text.
Sub geberateSlide()
...
With currSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=0, Top:=0, Width:=headerWidth, Height:=headerHeight)
.TextFrame.TextRange.Text = "Test Box" & vbCrLf & "Description"
.TextFrame.AutoSize = ppAutoSizeNone
.Height = headerHeight
.Line.ForeColor.RGB = RGB(0,0,0)
.Line.Visible = True
End With
...
End Sub
The text should be Arial 8. Line 1 should be black and bold, while subsequent text should be blue.
.TextFrame.TextRange.Lines(0, 1) will target the first line.
%300 Zoom
With currSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=0, Top:=0, Width:=headerWidth, Height:=headerHeight)
.Height = headerHeight
.TextFrame.AutoSize = ppAutoSizeNone
With .TextFrame.TextRange
.Text = "Test Box" & vbCrLf & "Description"
With .Font
.Color = vbBlue
.Size = 8
.Name = "Arial"
End With
With .Lines(1).Font
.Color = vbBlack
.Bold = msoTrue
End With
End With
End With