I'm trying to insert an autotext item into a header, and then move the autotext item only if it is on an even page that's also the first page in a section.
My code will insert the autotext, but I can't figure out how to move it.
Sub InsertHeader()
Dim oShape As Shape
Dim PageNumber As Integer
Dim oSection As Section
Dim oHeader As HeaderFooter
For Each oSection In ActiveDocument.Sections
If oSection.Index > 1 Then
For Each oHeader In oSection.Headers
oHeader.Range.Select
PageNumber = Selection.Information(wdActiveEndPageNumber)
If oHeader.Exists Then
Select Case oHeader.Index
Case Is = wdHeaderFooterFirstPage
If PageNumber Mod 2 = 0 Then
ActiveDocument.AttachedTemplate.AutoTextEntries("HeaderFirst"). _
Insert Where:=Selection.Range
End If
End Select
End If
Next oHeader
End If
Next oSection
End Sub
I tried putting Insert Where:=Selection.Range Left:=CentimetersToPoints(2.26) but the VBA editor won't accept that. I also tried finding all shapes in the header and moving them:
ActiveDocument.AttachedTemplate.AutoTextEntries("HeaderFirst"). _
Insert Where:=Selection.Range
For Each oShape In oHeader.Shapes
oShape.Left = CentimetersToPoints(2.26)
''oHeader.Range.Shape(1).Left = CentimetersToPoints(1)
Next oShape
But that moves the shapes in every header in the document, not just the shape I inserted.
Found it!
After inserting the header, I have to select it, then move the selection:
oHeader.Range.Select
Selection.Range.ShapeRange.Left = CentimetersToPoints(2.26)
Also, I needed to make sure the header existed before inserting anything. I solved that by having the program that generates the Word file (Author-it) insert a temporary header.
Related
I have messed cross-references to pictures in my word document. The label shows only part of the figure name:
Figure 5-
I have found out that bookmark responsible for that has narrowed range than the full figure name:
[Figure 5-] 62: Caption text
I would like to extend the bookmark label up to ":" using VBA, but I have no idea how to go further with the code.
Bookmark.Start and Bookmark.End refer to the whole picture text so how to refer only to label? my code is as follow:
Sub extend_bookmarks()
Dim bmk As Bookmark
Dim msg As String
Dim pos As Integer
For Each bmk In ActiveDocument.Range.Bookmarks
If (InStr(1, bmk.Range.Text, "Figure") And IsNumeric(Mid(bmk.Range.Text, 8, 1))) Then
pos = InStr(1, bmk.Range.Text, ":")
If ((pos < 12) And (pos > 0)) Then
Debug.Print bmk.Name
Debug.Print bmk.Range.Text
Debug.Print bmk.End - bmk.Start; pos
End If
End If
Next bmk
End Sub
You could just reapply the bookmark using the paragraph it sits in as the range.
Sub extend_bookmarks()
Dim bmk As Variant
For Each bmk In ActiveDocument.Range.Bookmarks
ActiveDocument.Bookmarks.Add Range:=bmk.range.Paragraphs(1).range, Name := bmk.Name
Next
End Sub
Update, When I tested the code above I only stepped through the loop twice and so missed the obvious, that you cannot use 'for each' when you are changing the content of a collection.
The code below correctly extends the bookmarks as intended and does not crash word.
Sub extend_bookmarks()
Dim myCount As Long
myCount = ActiveDocument.Bookmarks.Count
Dim myIndex As Long
With ActiveDocument.Bookmarks
For myIndex = myCount To 1 Step -1
.Add Range:=.Item(myIndex).Range.Paragraphs(1).Range, Name:=.Item(myIndex).Name
Next
End With
End Sub
I am migrating a lot of old presentations to a new design using VBA. I have created the new file from a template, copied each slide across and applied the correct custom layout that I need to each one. Once done, I am left with a load of the old custom layouts that are not used, and want to delete them all. The new design uses 50 custom layouts. Is there a way to find the ones after that 50 and delete them? Or delete all layouts after a layout of a specific name?
Here is the code I'm using at the moment. This doesn't remove them all, for some reason. Any help is welcome.
Dim colUsedLayouts As New Collection
For Each sld In NewPres.Slides
colUsedLayouts.Add sld.CustomLayout
Next
Dim UsedLayout As CustomLayout
Dim LayoutHasBeenUsed As Boolean
Dim EndPointLogoFound As Boolean
For Each lay In NewPres.Designs(1).SlideMaster.CustomLayouts
If Trim(LCase(lay.name)) = "blank no logo" Then 'Used the else statement so it doesn't delete the Blank No logo layout
EndPointLogoFound = True
Else
If EndPointLogoFound Then
LayoutHasBeenUsed = False
For Each UsedLayout In colUsedLayouts
If UsedLayout Is lay Then
LayoutHasBeenUsed = True
End If
Next
If Not LayoutHasBeenUsed Then
lay.Delete
End If
End If
End If
Next
PowerPoint doesn't really track the order of slide layouts, so trying to delete layouts after a certain one isn't reliable. I would go by the layout name. Create a Select Case statement based on the layout name. In the first Case statement, place the names of all 50 good layouts. This Select Case statement will have no commands. Then create a Case Else statement that deletes any layout not found in in the first:
Select Case lay.name
Case "Title Slide", "Title and Content", "Comparison" 'etc. place all 50 names
'do nothing
Case Else
lay.Delete
End Select
When deleting things from a collection (slides, shapes, layouts, whatever), you need to step through the collection in reverse order otherwise you end up with this situation:
You delete the first one.
The second item in the collection is now item 1, so when you move to the second item and delete it, you're actually deleting what WAS item 3, leaving what WAS item 2 alone.
Instead:
For x = Collection.Count to 1 step -1
Collection(x).Delete
Next
In this case, you'd use Designs in place of Collection.
This macro deletes any unused custom layouts in a presentation, provided they are not set to "Preserved":
Sub RemoveUnusedCustomLayouts(newPres As Presentation)
On Error GoTo RemoveUnusedCustomLayouts_Error
Dim oLayout As CustomLayout
Dim tLayout As CustomLayout
Dim oSld As Slide
Dim delLayoutCnt As Integer
Dim delLayoutArray() As CustomLayout
Dim layoutUsed As Boolean
Dim i As Integer
delLayoutCnt = 0
' We're assuming the deck only has one slide master.
' This sub is only called by other subs that have already
' collapsed the deck into one slide master.
ReDim delLayoutArray(newPres.SlideMaster.CustomLayouts.Count)
For Each oLayout In newPres.SlideMaster.CustomLayouts
layoutUsed = False
If oLayout.Preserved = msoFalse Then
' Can't delete a layout if it's in use, so we check
' for that and add any unused, un-preserved layouts
' to Delete array.
For Each oSld In newPres.Slides
If oSld.CustomLayout.Name = oLayout.Name Then
layoutUsed = True
Exit For
End If
Next
If layoutUsed = False Then
delLayoutCnt = delLayoutCnt + 1
Set delLayoutArray(delLayoutCnt) = oLayout
End If
End If
Next
If delLayoutCnt > 0 Then
For i = 1 To delLayoutCnt
Set tLayout = delLayoutArray(i)
tLayout.Delete
Next
End If
On Error GoTo 0
Exit Sub
RemoveUnusedCustomLayouts_Error:
Debug.Print "Error " & Err.Number & " (" & Err.Description & ") in procedure RemoveUnusedCustomLayouts, line " & Erl & "."
End Sub
Every CustomLayout in a Design must have a unique name (this is why you'll often see "Title and Content_2" in a bloated deck), so checking against the CustomLayout name is the best way to get at the ones you want to delete.
I have a presentation to split into several smaller ones depending on the text in the header.
I've managed to find and compile a code that finds the last slide that has the text), then it selects several previous slides, copies them to a new presentation, saves it, and repeats that for the next value.
This would be fine if number of slides with every text was the same (and all the slides with the same text were in the same order), but it's not always the case in my presentation. I need to modify the function.
Basically, it should return not just a slide, but a slide range, and it should be resized with every loop where if function is true. I know how to get all the slide indexes as a string, but I don't know how to use that string to select those slides.
Function FindSlideByTitle(sTextToFind As String) As slide
For Each oSl In ActivePresentation.slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If InStr(1, .TextRange.Text, sTextToFind, vbTextCompare) > 0 Then
Set FindSlideByTitle = oSl
End If
End If
End With
Next
I don't see an advantage to creating a slide range in this instance. A function for this isn't going to work, since it can only return one slide at a time, as you've discovered.
Instead, create a Sub using your loop, then replace
Set FindSlideByTitle = oSl
with a routine to add the found slide to an array:
Option Base 1
Dim FoundSlide() As Integer
Dim oSl As Slide
Sub FindSlideByTitle()
ReDim Preserve FoundSlide(1)
For Each oSl In ActivePresentation.Slides
With oSl.Shapes.Title.TextFrame
If .HasText Then
If InStr(1, .TextRange.Text, "Ham", vbTextCompare) > 0 Then
Count% = UBound(FoundSlide)
ReDim Preserve FoundSlide(Count% + 1)
FoundSlide(Count% + 1) = oSl.SlideNumber
End If
End If
End With
Next
End Sub
Then process that subset of slides one at a time:
Sub DoSomethingWithSlide()
For X = 1 To UBound(FoundSlide)
With ActivePresentation.Slides(FoundSlide(X))
'Process each slide here
End With
Next X
End Sub
Anyway, this is what I came up with in the end, and it (almost) seems to be working.
Dim sSlides() As String
sSlides() = Split(FindSlide(sCountry), ";|;")
Dim n As Long
Dim iSlides() As Integer
ReDim iSlides(LBound(sSlides) To UBound(sSlides))
For n = LBound(sSlides) To UBound(sSlides)
iSlides(n) = CInt(sSlides(n))
Next n
Dim rCountrySlides As SlideRange
Set rCountrySlides = ActivePresentation.slides.range(iSlides)
rCountrySlides.Select
i have a bunch of textboxes in a powerpoint slide.
They all contain text.
I need to sort those textboxes in order,
so i can loop through those textboxes,
capture the text,
and export it to a CSV file, IN ORDER, from top-left to bottom-right.
For example, if i have 4 textboxes in a slide, i need to capture text in
the textbox, in the order of
TOP-LEFT textbox
TOP-RIGHT textbox
BOTTOM-LEFT textbox
BOTTOM-RIGHT textbox
The part of the code (i got from internet) that exports the textbox's text to a CSV file works. Except that they are out of order.
Sub ExportTextToCSV()
Dim oPres As Presentation
Dim oSlides As Slides
Dim oSld As Slide 'Slide Object
Dim oShp As Shape 'Shape Object
Dim sTempString As String
Dim Quote As String
Dim Comma As String
Dim myText As String
Dim myFilePath As String
myFilePath = ".\Export_Textbox.CSV"
Quote = Chr$(34)
Comma = ","
Set oPres = ActivePresentation
Set oSlides = oPres.Slides
For Each oSld In oSlides 'Loop thru each slide
For Each oShp In oSld.Shapes 'Loop thru each shape on slide
'Check to see if shape has a text frame and text
If oShp.HasTextFrame And oShp.TextFrame.HasText Then
myText = Replace(oShp.TextFrame.TextRange.Text, vbCr, vbCrLf)
sTempString = sTempString & Quote & myText & Quote & Comma
End If
Next oShp
'Add new line in CSV
sTempString = sTempString & vbCrLf
'Print the result to file:
Call WriteToTextFileADO(myFilePath, sTempString, "UTF-8")
'Clear the string
sTempString = ""
Next oSld
End Sub
Sub WriteToTextFileADO(filePath As String, strContent As String, CharSet As String)
Set stm = CreateObject("ADODB.Stream")
'if file exist, append
If Len(Dir(filePath)) > 0 Then
stm.Type = 2
stm.Mode = 3
stm.Open
stm.CharSet = CharSet
stm.LoadFromFile filePath
stm.Position = stm.Size
stm.WriteText strContent
stm.SaveToFile filePath, 2
stm.Close
Else
stm.Type = 2
stm.Mode = 3
stm.Open
stm.CharSet = CharSet
stm.WriteText strContent
stm.SaveToFile filePath, 2
stm.Close
End If
Set stm = Nothing
End Sub
According to stackoverflow's post "VBA For each - loop order", it says:
"A shape's position in the z-order corresponds to the shape's index
number in the Shapes collection."
I'm thinking of first creating and running a macro to re-set all the shapes z-order, base on "Top" and "Left" property of the textbox shape, before i run the ExportTextToCSV() macro.
I'm having trouble on using ShapeRange or Collection, to add reference to EXISTING SHAPES in a slide, and on sorting them base on their "Top" and "Left" property.
Please help. Thanks!
Create a disconnected recordset using ADO, populate it with textbox
name, text, top and left properties, then sort it by top then left
position. Use that to populate your text file. See for example:
developer.rhino3d.com/guides/rhinoscript/… – Tim Williams 23 hours ago
It worked. Thanks for pointing me in the right direction!
If you don't mind, please re-post your comment as an answer, so i can mark it as an answer.
I am trying to insert tables marked with a Name via a bookmark so I can later recognize them again.
Below I have added my source code in question. At pos3 I created a table with 2 rows and add a bookmark for its range. But when repeating the Sub I always end up in the case of pos1 .. my bookmark is not found in the table selection. (trying to reach pos2)
The bookmark itself is added, but maybe not to the table. I suspect the error to be there.
I can see the bookmark in the bookmark-list of Word. But if I do a manual "go to" the cursor seems to end up off screen somewhere, so I suspect its not added correctly to the table range.
Private Sub PrepareFooter()
Dim oSection As Section
Dim oFooter As HeaderFooter
Dim oRng As Range
Dim tbl As Table
Dim cell As cell
Dim foundFooterTable As Boolean
For Each oSection In ActiveDocument.Sections
For Each oFooter In oSection.Footers
With oFooter.Range
For Each tbl In .Tables
tbl.Select
If Selection.Bookmarks.Count <> 1 Then
tbl.Delete ' <-- pos1
ElseIf Selection.Bookmarks(1).Name <> "FooterTable" Then
tbl.Delete
Else
foundFooterTable = True ' <-- pos2
FormatFooterTable tbl
End If
Next
End With
oFooter.Range.Select
Selection.Collapse wdCollapseStart
If Not foundFooterTable Then
Set tbl = ActiveDocument.Tables.Add(Selection.Range, 2, 1)
tbl.Select
ActiveDocument.Bookmarks.Add Range:=Selection.Range
, Name:="FooterTable" ' <- pos3
FormatFooterTable tbl
End If
Next oFooter
Next oSection
End Sub
thanks for any ideas about what I might do wrong!
Try to work without Selection as much as you can. Whenever possible, use a Range object. That will make your code clearer and more reliable.
In order to put a bookmark "around" a table (pos 3):
ActiveDocument.Bookmarks.Add Range:=tbl.Range, Name:="FooterTable"
When this works, you should be able to get the table using:
Dim sFooterTable as String
sFooterTable = "FooterTable"
If ActiveDocument.Bookmarks.Exists(sFooterTable) Then
Set tbl = ActiveDocument.Bookmarks(sFooterTable).Range.Tables(1)
found my mistake:
I was applying the same bookmark name on all tables that were found .. this way deleting the previous bookmarks as they need a unique name.
adding a unique identifier in the end (I used an integer now) made the code work.