In VBA for Microsoft Word, I am trying writing a subroutine that will search through all shapes on a document, find the ones that are textboxes, and will move them to a newly created document by means of cut-and-paste.
My problem is that the sub will only move the first textbox it finds to a new doc. If I run it again it will move the next one, etc. Is there a way that I can select multiple textboxes, similar to the Shift-Left_Click ability that exists in the normal word document? I will post my code below:
Option Explicit
Public shp As Shape
Public Count As Integer
Public OldDoc As String
Public NewDoc As String
Sub BringTextBoxesToDoc()
Dim Count As Integer
Dim i As Integer
Count = 0
OldDoc = ActiveDocument.Name
Documents.Add
ActiveDocument.ActiveWindow.Caption = "Comment Textboxes"
NewDoc = ActiveDocument.Name
Documents(OldDoc).Activate
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
Count = Count + 1
shp.Name = "Textbox" & Count
shp.Select
With Selection
.Cut
End With
Documents(NewDoc).Activate
Selection.Paste
End If
Next shp
End Sub
Related
The following VBA code selects textboxes in a word document that contain a specific text. How can I programmatically move every textbox to another page (let's say the first page) preserving it's position relative to the page. The original textboxes are positioned absolute to the page they are on.
Sub searchTexboxes()
'
' searchTexboxes Macro
'
'
Dim shp As Shape
Dim sTemp As String
Dim nrTextboxes As Integer
nrTextboxes = 0
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
shp.Select
Selection.ShapeRange.TextFrame.TextRange.Select
sTemp = Selection.Text
sTemp = Left(sTemp, 1)
If sTemp = "." Then
nrTextboxes = nrTextboxes + 1
End If
End If
Next
MsgBox ("Found " & nrTextboxes & " textboxes.")
End Sub
The following code works for me.
The only way to do this, really (aside from recreating the text box from scratch), is copy/paste. That will carry across all the formatting.
Key aspects about this approach:
Setting the target page: Word doesn't have "page" objects, due to its dynamic layout behavior. Selection.GoTo is the simplest method to get a page. Since the text boxes are formatted relative to the page, it doesn't matter where on the page the anchor is attached. (Unless there's going to be a lot of subsequent editing that could push the anchoring range to a different page.) So this code assigns the first paragraph's range to be the anchor.
Identifying the text box(es) to be copied: It's not necessary to select a text box in order to work with its content. The text can be read from TextFrame.TextRange.Text.
Looping with multiple text boxes: As soon as a text box is created (pasted) in the target range, Word will say "Aha! there's another text box!" and will try to loop that, too, which is not what is wanted. So the code in the question has been modified to add the text boxes which should be copied to an array (shps()). Once all the text boxes that need to be copied have been identified, the code then loops this array, copies each text box and paste it to the target range.
Sub searchTexboxes()
Dim shp As Shape
Dim shps() As Shape
Dim sTemp As String
Dim nrTextboxes As Integer
Dim target As Word.Range
Dim targetPage As Long, i As Long
nrTextboxes = 0
targetPage = 1
Selection.GoTo What:=Word.wdGoToPage, Which:=targetPage
Set target = Selection.Paragraphs(1).Range
For Each shp In ActiveDocument.Shapes
If shp.Type = msoTextBox Then
sTemp = shp.TextFrame.TextRange.Text
sTemp = Left(sTemp, 1)
If sTemp = "." Then
nrTextboxes = nrTextboxes + 1
ReDim Preserve shps(nrTextboxes - 1)
Set shps(nrTextboxes - 1) = shp
End If
End If
Next
For i = LBound(shps) To UBound(shps)
shps(i).Select
Selection.Copy
target.Paste
Next
MsgBox ("Found " & nrTextboxes & " textboxes.")
End Sub
I want to select a range of slides in Powerpoint by vba. For Excel you simply write
Range("A1:A100")
I want to select from slide number 5 to 10, how do I code that? My code just selects two slides:
ActivePresentation.Slides.Range(Array(5,10)).Select
Here is an example. This will depend on which type of Text box you are using. I am assuming standard textbox you select which is a shape. I am using some test textboxes which you would need to adjust to suit your needs.
You call the sub SelectSlides to generate the array of slides numbers for the slides to select between the two text box numbers.
You use the Range method to return any number of shapes or slides.
To specify an array of integers or strings for Index, you can use the Array function or, I believe, pass an array into the Range.
I will be upfront, whilst this worked once, powerpoint the crashed and since then the code has selected only the last item.
However, you can assign ppt.Slides.Range(slidesArray) to a Slides object and work with that e.g.
Dim slidesObject As Slides
Set slidesObject = ppt.Slides.Range(slidesArray)
Code:
Option Explicit
Public Sub SelectSlideArray()
Dim ppt As Presentation
Dim sld As Slide
Dim textBox1 As Shape
Dim textBox2 As Shape
Set ppt = ActivePresentation
Set sld = ppt.Slides(1) ' slide with text boxes in
Set textBox1 = sld.Shapes("TextBox 3") 'change as required
Set textBox2 = sld.Shapes("TextBox 4") 'change as required
textBox1.TextFrame.TextRange = 5 ' you can say TextRange.Text but .Text is defaut
textBox2.TextFrame.TextRange = 10
Dim startSlideNumber As Integer
Dim endSlideNumber As Integer
startSlideNumber = Int(textBox1.TextFrame.TextRange)
endSlideNumber = Int(textBox2.TextFrame.TextRange)
SelectSlides ppt, startSlideNumber, endSlideNumber
'PrintShapeNames sld
End Sub
Public Sub SelectSlides(ByVal ppt As Presentation, ByVal startSlideNumber As Long, ByVal endSlideNumber As Long)
Dim outputSlideNumber As Long
outputSlideNumber = startSlideNumber
If ppt.Slides.Count < endSlideNumber Then
MsgBox "You don't have enough slides in the presentation!"
End
ElseIf endSlideNumber < startSlideNumber Then
MsgBox "End slide is before start slide!"
End
Else
Dim slidesArray()
ReDim slidesArray(0 To endSlideNumber - startSlideNumber)
Dim currentSlide As Long
For currentSlide = LBound(slidesArray) To UBound(slidesArray)
slidesArray(currentSlide) = outputSlideNumber
outputSlideNumber = outputSlideNumber + 1
Next currentSlide
End If
ppt.Slides.Range(slidesArray).Select
End Sub
Private Sub PrintShapeNames(ByVal sld As Slide)
Dim shp As Shape
For Each shp In sld.Shapes
Debug.Print shp.Name
Next shp
End Sub
I have many Excel objects are there embedded in a MS-Word Document.
I want to calculating the grand total: with summing the totals are there in the each specified excel object and return that grand total in the MS-Word document.
Macro holder is MS-Word Document's VBA module.
Means: I need to access to an specified embedded Excel object, form the MS-Word module, then perform it active, then assign to an object-variable by -For example:- ExcelApplication = GetObject(, "Excel.Application") statement. Then try to access its appropriated total values , by -For example:- Total = Range("Table1[[#Totals],[Amount]]").Value. Point is all tables Name are in the Excel objects is Table1 which contains the Amount Columns and the Total Row.
Note is in above Excel objects, The first row which contains the Table Header is Hided.
Example
Sample File
This document have extending daily.
I need a macro in the Normal.dotm Which calculating the grand total of all specified Excel object (specified with assigning a name to them or ...) and perform returning this value with Selection.TypeText Text:= where is selected in picture below: (at the end of document)
Why I insist to have embedded Excel object?
Because I have formula for calculating Column1: A, B, C, ....
Because I have a hided Data base Sheet for data validation Items
I have Formula in Amount column for multiplying the rates and the
amount of each item-unit which is in Data base sheet
In that case, try something along the lines of:
Sub TallyXLVals()
Application.ScreenUpdating = False
Dim Rng As Range, objOLE As Word.OLEFormat, objXL As Object
Dim i As Long, lRow As Long, sValA As Single, sValB As Single, sValC As Single
Const xlCellTypeLastCell As Long = 11
With ActiveDocument
.ActiveWindow.Visible = False
For i = .InlineShapes.Count To 1 Step -1
With .InlineShapes(i)
If Not .OLEFormat Is Nothing Then
If Split(.OLEFormat.ClassType, ".")(0) = "Excel" Then
Set Rng = .Range
Set objOLE = .OLEFormat
objOLE.Activate
Set objXL = objOLE.Object
With objXL.ActiveSheet
lRow = .UsedRange.Cells.SpecialCells(xlCellTypeLastCell).Row
sValA = sValA + .Range("A" & lRow).Value
sValB = sValB + .Range("B" & lRow).Value
sValC = sValC + .Range("C" & lRow).Value
End With
objXL.Application.Undo
End If
End If
End With
Next
Call UpdateBookmark("BkMkA", Format(sValA, "$#,##0.00"))
Call UpdateBookmark("BkMkB", Format(sValB, "$#,##0.00"))
Call UpdateBookmark("BkMkC", Format(sValC, "$#,##0.00"))
.ActiveWindow.Visible = True
End With
Set objXL = Nothing: Set objOLE = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub
Sub UpdateBookmark(StrBkMk As String, StrTxt As String)
Dim BkMkRng As Range
With ActiveDocument
If .Bookmarks.Exists(StrBkMk) Then
Set BkMkRng = .Bookmarks(StrBkMk).Range
BkMkRng.Text = StrTxt
.Bookmarks.Add StrBkMk, BkMkRng
End If
End With
Set BkMkRng = Nothing
End Sub
where the locations you want the outputs to appear are bookmarked, with the names BkMkA, BkMkB, & BkMkC, respectively.
Note: Because you're activating embedded objects, there is unavoidable screen flicker.
Your own effort is insufficent. Here is code to start you off. The code will loop through all the InlineShapes in your Word document, select the first one which represents an Excel worksheet and opens that item for editing. It is the same action which you can recreate in the document by right-clicking on the embedded Excel table, selecting "Worksheet Object" and "Edit".
Private Sub OpenEmbeddedExcelInWord()
' 08 Jan 2018
Dim Shp As InlineShape
For Each Shp In ActiveDocument.InlineShapes
With Shp
If Shp.Type = wdInlineShapeEmbeddedOLEObject Then Exit For
End With
Next Shp
Shp.OLEFormat.Edit
End Sub
I have several PowerPoints with a great deal of text in the notes. I need to search the note text and delete any paragraphs that start with "A."
Here is what I tried - but am getting type mismatch error
Dim curSlide As Slide
Dim curNotes As Shape
Dim x As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes.TextFrame.TextRange
For x = 1 To Len(curNotes.TextFrame.TextRange)
If Mid(curNotes.TextFrame.TextRange, x, 2) = "A." Then
curNotes.TextFrame.TextRange.Paragraphs = ""
End If
Next x
End With
Next curSlide
End Sub
Thanks for your help!!
You get a mismatch error whenever you try to assign data of a different type specified by your variable. This is happening in your code because you defined curNotes as type Shape and then tried to set that object variable to a different data type, TextRange. You are then trying to process the object TextRange as a string. You need to work on the .Text child of .TextRange The use of Mid is not checking the start of the string and finally, when you set the text to "", you are deleting all the text in the Note but that's not what you said you're trying to do.
This is the corrected code to delete only paragraphs starting with "A."
' PowerPoint VBA macro to delete all slide note paragraphs starting with the string "A."
' Rewritten by Jamie Garroch of youpresent.co.uk
Option Explicit
Sub DeleteNoteParagraphsStartingA()
Dim curSlide As Slide
Dim curNotes As TextRange
Dim iPara As Long
For Each curSlide In ActivePresentation.Slides
Set curNotes = curSlide.NotesPage.Shapes(2).TextFrame.TextRange
With curNotes
' Count backwards in any collection when deleting items from it
For iPara = .Paragraphs.Count To 1 Step -1
If Left(.Paragraphs(iPara), 2) = "A." Then
.Paragraphs(iPara).Delete
Debug.Print "Paragraph " & iPara & " deleted from notes pane on slide " & curSlide.SlideIndex
End If
Next
End With
Next curSlide
End Sub
My Word document has many ActiveX labels. [Not textboxes: my original title was in error.]
I'd like a macro to loop through them to perform an action on each of them (changing the captions), but I don't know how to identify them.
If they were on a userform, I'd say:
For each aLabel in UserForm1.Controls
But that doesn't apply in my case.
Assuming it is textboxes you're working with, per the title but not the question, the document's Shapes collection may be what you're after:
Sub ShapeLoop()
Dim shp As Shape
For Each shp In ThisDocument.Shapes
' Test if shp is one you're interesed in, perhaps using shp.Name
Debug.Print shp.Name
' Do Stuff
Next shp
End Sub
Edit:
Same again for the fields collection
Sub FieldLoop()
Dim fld As Field
For Each fld In ThisDocument.Fields
If TypeName(fld.OLEFormat.Object) = "Label" Then
Debug.Print fld.OLEFormat.Object.Caption
fld.OLEFormat.Object.Caption = "New Caption"
End If
Next
End Sub