I currently have a VBA script that works as it should apart from the position of the command button in the MS word documant. Currently the button is positioned as the very first thing on the document pushing the existing text to the right.
The VBA code I have use for the button is:
Dim doc As Word.Document
Dim shp As Word.InlineShape
Set doc = ActiveDocument
Set shp = doc.Content.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
shp.OLEFormat.Object.Caption = "Create PDF and print"
How do I position the button? On the same line but centered would do fine. Centered but at the very end of the document (following the letter as it is typed), even better.
Thank you.
You must add the button to a specific paragraph of the document. For example:
doc.Content.InsertParagraphAfter
Set shp = doc.Content.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1", _
Range:=doc.Paragraphs.Last.Range)
Thus you can format the button paragraph as you want. For example:
doc.Paragraphs.Last.Alignment = wdAlignParagraphCenter
Sub Add_InlineShapes_To_EachLine()
Dim shp As Word.InlineShape
Dim NbOfLines, cpt As Integer
'Count the number of non blank lines in current document
NbOfLines = ActiveDocument.BuiltInDocumentProperties(wdPropertyLines)
cpt = 1
Set p = ActiveDocument.Paragraphs.First
For Lin = 1 To NbOfLines
Set shp = p.Range.InlineShapes.AddOLEControl(ClassType:="Forms.CommandButton.1")
With shp.OLEFormat.Object
.Caption = cpt
.FontSize = 8
.Width = 20
.Height = 20
End With
Set p = p.Next
cpt = cpt + 1
Next Lin
End Sub
Related
This is my first time writing macro in VBA. My goal is to write a VBA macro that will automatically align (distribute) all images in a Word document horizontally (next to each other) with a small margin on each side of every image. If there is not enough space to fit another image, I need it to go to the next row(just below previous images) and continue with the horizontal alignment of images.
I have searched a lot on the internet, but I haven't found a way to achieve this...
NOTE: My macro already contains code for making all images have the same height(while keeping the same aspect ratio), so I think dimensions shouldn't be a problem...
Here is a small example of what I want to achieve:
I tried using code for Horizontal alignment from this link: https://www.excelcampus.com/vba/align-space-distribute-shapes/
But I got the following result:
Margins are weird and shapes are aligned infinitely instead of going into the next row...
My Code:
Dim lCnt As Long
Dim dTop As Double
Dim dLeft As Double
Dim dWidth As Double
Const dSPACE As Double = 8 'Set space between shapes in points
lCnt = 1
Dim image As Shape
If ActiveDocument.Shapes.Count > 0 Then
For Each image In ActiveDocument.Shapes
With image
.WrapFormat.Type = wdWrapSquare
.LockAspectRatio = msoTrue
.Height = InchesToPoints(3)
If lCnt > 1 Then
.Top = dTop
.Left = dLeft + dWidth + dSPACE
End If
dTop = .Top
dLeft = .Left
dWidth = .Width
End With
lCnt = lCnt + 1
Next
End If
End Sub
Thanks in advance!
Inserting your images into a table with fixed cell dimensions won't achieve what you say you want, since the images clearly don't have the same aspect ratio. What you need to do is to convert them to inlineshapes so that Word can handle the line wrapping. For example:
Sub Demo()
Application.ScreenUpdating = False
Dim iShp As InlineShape
With ActiveDocument
Do While .Shapes.Count > 0
.Shapes(1).ConvertToInlineShape
Loop
For Each iShp In .InlineShapes
With iShp
.LockAspectRatio = True
.Height = InchesToPoints(3)
If .Range.Characters.Last.Next <> " " Then .Range.InsertAfter " "
End With
Next
End With
Application.ScreenUpdating = True
End Sub
You can adjust the vertical spacing between the images by changing the paragraph line spacing. Note too, that the horizontal alignment can be played around with by switching between left, centered and justified paragraph formats.
Since you are new to VBA I wanted to share a bit of code if you were to pursue a Table approach. The code below creates a single-row table that is fixed in width and will not expand width-wise unless you alter the individual cells. For demo purposes only, I insert the same picture into each cell to demonstrate that the image resizes automatically based on cell width.
Sub TableOfPictures()
Dim doc As Word.Document, rng As Word.Range
Dim Tbl As Word.Table, C As Long
Set doc = ActiveDocument
Set rng = Selection.Range
Set Tbl = rng.Tables.Add(rng, 1, 2, Word.WdDefaultTableBehavior.wdWord8TableBehavior)
Tbl.rows(1).Cells(1).Width = InchesToPoints(2)
Tbl.rows(1).Cells(2).Width = InchesToPoints(4.5)
For C = 1 To 2
Tbl.rows(1).Cells(C).Range.InlineShapes.AddPicture ("Y:\Pictures\Mk45 Gun Proj_Blast.jpg")
Next
End Sub
I have created a macro in Powerpoint that will search for slides that are using a textbox for their title and are replacing them with a Title box. The steps are
1) find the slides that have a textbox in the title area
2) Copy the text in the textbox to a variable called slTitle.
3) Delete the texbox
4) Create a Title Holder for the current slide
5) Copy the text into the Title holder
6) Move on to the next slide
My macro currently is able to get as far as step 4 but I can't figure out how to get the text in slTitle into the Title box. This should be fairly easy to do but I've tried several ways and nothing seems to work. If anyone can help me figure out this step it would be much appreciated.
I am getting a compile error "Invalid Qualifier" on the line:
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
Here is my current macro.
Sub AddMiMissingTitles()
Dim shpCurrShape As Object
Dim x As Integer
Dim sl As PowerPoint.Slide
Dim sld As Slide
Dim ctr As Integer
Dim s As Shape
'x = ActivePresentation.Slides.Count
'counter ctr used to count number of slides that needed titles added
ctr = 0
'**************************************************************
Set sourcePres = ActivePresentation
x = 1 ' slide counter
'get the title text
For Each sl In sourcePres.Slides
'delete all the empty title text boxes first
For Each s In sl.Shapes
If s.Top < 45 Then ' it's in the title area
'MsgBox s.PlaceholderFormat.Type
If s.Type <> ppPlaceholderTitle Then ' it isn't a proper Title placeholder
If s.HasTextFrame = msoTrue Then
If Trim(s.TextFrame.TextRange.Text) = "" Then
s.Delete ' delete empty text holders
Else
slTitle = s.TextFrame.TextRange.Text
s.Delete
sl.CustomLayout = sl.CustomLayout 'reset the slide
Set ppPlaceholderTitle.TextFrame.TextRange.Text = slTitle
End If
End If
End If
End If
Next
'Is there a title placeholder on the current layout?
If sl.CustomLayout.Shapes.HasTitle Then
lngType = sl.CustomLayout.Shapes.Title.PlaceholderFormat.Type
'*********************************
' With ActivePresentation.Slides()
End If
Next
MsgBox "Done! " & vbCrLf & ctr & " Slides needed Titles."
'*********************************
'sl.Shapes.AddPlaceholder lngType
sl.Shapes.Title.TextFrame.TextRange = slTitle
End Sub
Ok, here is what I am looking for (Im new, so be gentle):
Copy and paste (default format) from excel to powerpoint (from just the one sheet)
I can only fit so many rows in ppt - so after a slide fills, I want ppt to create a new slide
Same title for each slide is fine!
I only need columns B:K copied over
That's it, however I am stuck :( I know the below code is NOT the best way to write this and it contains errors in which I am sure will be easy to spot. I cannot find how to do this anywhere on the net.
This is what I have so far:
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
Dim i As Integer
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
For i = 1 To 6
'need to set focus to slde 1
PowerPointApp.ActiveWindow.View.GotoSlide (1)
'Deletes Title
'mySlide.Shapes.Title.Delete
'builds new title
mySlide.Shapes.AddShape Type:=msoShapeRectangle, left:=9, Top:=6, Width:=702, Height:=30
mySlide.Shapes(mySlide.Shapes.Count).Line.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Size = 20
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
mySlide.Shapes(mySlide.Shapes.Count).TextFrame.TextRange.Text = "Current Full Initiative Details – Branded Book as of " & Date
mySlide.Shapes(mySlide.Shapes.Count).Name = "I am TITLE"
mySlide.Shapes(mySlide.Shapes.Count).Line.ForeColor.RGB = RGB(0, 0, 0)
mySlide.Shapes(mySlide.Shapes.Count).Line.Weight = 1
mySlide.Shapes(mySlide.Shapes.Count).Fill.Visible = msoTrue
mySlide.Shapes(mySlide.Shapes.Count).Fill.ForeColor.RGB = RGB(255, 255, 255)
'Copy Range from Excel
Set rng = ActiveWorkbook.Worksheets("RAW").Range("B1:K23")
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
PowerPointApp.ActiveWindow.View.PasteSpecial DataType:=ppPasteDefault
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShapeRange.left = 10
myShapeRange.Top = 42
myShapeRange.Height = 492
myShapeRange.Width = 702
ActiveWorkbook.Sheets("RAW").Rows("2:23").Delete
Call myPresentation.Slides.Add(1, PpSlideLayout.ppLayoutTitleOnly)
'Clear The Clipboard
Application.CutCopyMode = False
Next i
End Sub
As requested in comments, here is the code I use to copy a slide from a master PPT template to the report PPT.
There is some extraneous code in there to provide status updates on the form we use to drive the process, as well as a debugging flag that I can toggle on/off at run time - these can both be removed.
This will serve as a starting point to finding the proper solution for your situation, and is not a complete answer to the question as asked.
'I've chosen to declare these globally, though it's probably not the best way:
Dim PPTObj As PowerPoint.Application
Dim PPTMaster As PowerPoint.Presentation
Dim PPTClinic As PowerPoint.Presentation
Private Sub InsertPPT(ByVal SlideName As String, ByVal StatusText As String)
Dim Shp As PowerPoint.Shape
Dim Top As Single
Dim Left As Single
Dim Height As Single
Dim width As Single
PPTMaster.Slides(SlideName).Copy
PPTClinic.Slides.Paste
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT"
With PPTClinic.Slides(PPTClinic.Slides.count)
If Debugging Then
.Select
End If
.Design = PPTMaster.Slides(SlideName).Design 'this ensures we get all the right formatting - only seems to be necessary 1 time, but we'll just do it on all
.ColorScheme = PPTMaster.Slides(SlideName).ColorScheme
.FollowMasterBackground = PPTMaster.Slides(SlideName).FollowMasterBackground
For Each Shp In .Shapes 'loop through all the shapes on the slide
If Debugging Then
' .Select
Shp.Select
End If
Form_Master.ProcessStatus.Value = StatusText & " InsertPPT-" & Shp.Name
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
ReLinkShape Shp, TempVars!NewXLName
'need to store off top, left, width, height
Top = Shp.Top
Left = Shp.Left
Height = Shp.Height
width = Shp.width
Shp.LinkFormat.Update 'and force the link to refresh
MySleep 2, "S" 'hopefully, the 2 second pause will allow everything to update properly before moving on.
'then reset them here - they seem to change shape when I update them
Shp.LockAspectRatio = msoFalse
Shp.Top = Top
Shp.Left = Left
Shp.width = width
Shp.Height = Height
ElseIf Shp.Name = "SlideName" And Not Debugging Then 'if it's the "SlideName" tag
Shp.Delete 'delete it (unless we're debugging)
End If
Next
End With
Form_Master.ProcessStatus.Value = StatusText
End Sub
Private Sub ReLinkShape(ByRef Shp As PowerPoint.Shape, ByVal NewDestination As String)
Dim Link() As String
Dim link2() As String
If Shp.Type = msoLinkedOLEObject Then 'when we find a linked one
Link = Split(Shp.LinkFormat.SourceFullName, "!") 'update the link to point to the new clinic spreadsheet instead of the master
If InStr(1, Link(2), "]") > 0 Then
link2 = Split(Link(2), "]")
Link(2) = "[" & TempVars!ClinicName & ".xlsx]" & link2(1)
End If
Shp.LinkFormat.SourceFullName = NewDestination & "!" & Link(1) & "!" & Link(2)
End If
End Sub
Public Sub MySleep(ByRef Unit As Double, ByRef UOM As String)
Dim Pause As Date
Pause = DateAdd(UOM, Unit, Now())
While Now < Pause
DoEvents
Wend
End Sub
I'm working with PowerPoint 2007. I want to use a list to create a table on a slide. The first column of each row will have a hyperlink to a different slide in the presentation (like a summary slide).
I'm having trouble using VBA to insert a hyperlink into a cell. The error message is usually something like "object doesn't support that function".
Here is the offending line:
With pptPres.Slides(2).Shapes("Table Summary").Table.Cell(i - 1, 1).Shape.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = ThisWorkbook.Sheets(i).Range("B1")
.SubAddress = pptPres.Slides(i).SlideID
End With
You're almost there.
You need to access TextRange Object if you want to add a Link in the text within a table or shape.
Something like:
Sub marine()
Dim t As Table
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Set t = pptpres.Slides(1).Shapes(1).Table
With t.Cell(2, 1).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = "Link to Slide"
.SubAddress = pptpres.Slides(2).SlideNumber _
& ". " & pptpres.Slides(2).Name
End With
End Sub
And also, you cannot use SlideID property as SubAddress.
It should be in this format: <slide number><dot><space><slide name> (eg. #2. Slide2)
To get this done we used SlideNumber and Name property instead. HTH
thanks for the above. Below generates a hyperlinked TOC table for each slide into slide 2
Sub DeckTOC() ' Creates a hyperlinked TOC of each slide in deck
' Tip: add a return-to-TOC hyperlink on Slidemaster default layout
' assumes slide 1 is a cover slide, slides 2 is for TOC
' and #2 already includes a table And (important) no other shapes or title
' with col 1 for slide title and 2nd cloumn for slide no
' TOC can be formatted before/after macro has run
Dim slidecount As Integer
Dim t As Table
Dim TOCrow As Integer
Dim pptpres As Presentation
Set pptpres = ActivePresentation
slidecount = pptpres.Slides.Count
If slidecount < 3 Then Exit Sub ' nothing to do
Set t = pptpres.Slides(2).Shapes(1).Table ' grab= ther toc
TOCrow = 2
For i = 3 To slidecount Step 1 ' get slide references for each slide
If TOCrow > t.Rows.Count Then t.Rows.Add ' add rows on fly as needed
' create text entry in cell, then add hyperlink (doing in one step fails)
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange
.Text = pptpres.Slides(i).Shapes.Title.TextFrame.TextRange.Characters
End With
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange.Characters().ActionSettings(ppMouseClick).Hyperlink
.Address = ""
.SubAddress = pptpres.Slides(i).SlideNumber & ". " & pptpres.Slides(i).Name
End With
t.Cell(TOCrow, 2).Shape.TextFrame.TextRange.Text = i
TOCrow = TOCrow + 1
Next
End Sub
ex [enter image description here][1]
[1]: https://i.stack.imgur.com/gaMJK.png
I'm getting a "Object variable or With block variable not set" error in my code.
This is my first crack at macro writing. I do have programming knowledge but this is new to me.
Anyway, I want to go through the presentation, and for every page that has any text in the notes section, I want to add a new slide (following it) containing that text.
Here's what I tried:
Sub SlideSort()
Dim curSlide As Slide
Dim newSld As Slide
Dim curPres As Presentation
Dim curShape As Shape
Dim i As Integer
For i = 1 To ActivePresentation.Slides.Count
curSlide = ActivePresentation.Slides(i)
For Each curShape In curSlide.NotesPage.Shapes
If curShape.Type = msoPlaceholder Then
If curShape.PlaceholderFormat.Type = ppPlaceholderBody Then
If curShape.TextFrame.TextRange <> "" Then
Set newSld = ActivePresentation.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
newSld.Shapes(2).TextFrame.TextRange = curShape.TextFrame.TextRange
i = i + 1
End If
End If
End If
Next curShape
Next i
End Sub
The line that gives the error is curSlide = ActivePresentation.Slides(i)
Use Set curSlide = ActivePresentation.Slides(i) - it's an object, and should be operated via Set.
You need to use Set here, as you have with other objects:
Set curSlide = ActivePresentation.Slides(i)
Bingo. It's a bug in the Mac version of PowerPoint. I can repro the problem on the Mac.
.PlaceholderFormat.Type isn't supported on Mac PowerPoint, though it should be.
It's not 100% reliable, but you can pick up the second shape on the notes page as the body text placeholder instead:
Sub SlideSort()
Dim curSlide As Slide
Dim newSld As Slide
Dim curPres As Presentation
Dim curShape As Shape
Dim i As Integer
For i = 1 To ActivePresentation.Slides.Count
curSlide = ActivePresentation.Slides(i)
curShape = curSlide.NotesPage.Shapes(2)
If curShape.TextFrame.TextRange <> "" Then
Set newSld = ActivePresentation.Slides.Add(Index:=i + 1, Layout:=ppLayoutText)
newSld.Shapes(2).TextFrame.TextRange = curShape.TextFrame.TextRange
i = i + 1
End If
Next i
End Sub
I suspect you may also run into issues because you're looking at Slide.Count in the loop, but by adding slides, you're modifying Slide.Count.