I'm trying to make my vba macros for PowerPoint work on a Mac, too. A lot of them do, but there are little things going wrong here or there.
One macro is for copying text from one selected shape to other selected shapes without formatting.
I use
.TextFrame2.TextRange.PasteSpecial msoClipboardFormatPlainText
The macro does as it should on Windows machines, and so it does on the Mac, only with one little problem: It creates an unwanted line break at the end of the text in the target shapes. Does anyone know a way to avoid this?
The option
.TextFrame2.TextRange.PasteSpecial msoClipboardFormatRTF
does not create this break, but it keeps the font color of the source shape, and same to
.TextFrame2.TextRange.PasteSpecial msoClipboardFormatNative
which keeps font color and font size of the source shape. The PlainText option is closest to my aim at the moment. But of course I wish I could have a perfect solution.
Any hint is appreciated. Thank you!
Edit: This is the complete code. After John's suggestion I added the Line starting with .text, but it made no difference on my Mac.
Sub DubTextOnly()
Dim shp As Shape
Dim shp1 As Shape
Dim i As Integer
On Error GoTo err
If ActiveWindow.Selection.ShapeRange.Count < 2 Then
MsgBox "Please select at least two shapes (no tables)"
Exit Sub
End If
Set shp1 = ActiveWindow.Selection.ShapeRange(1)
shp1.TextFrame2.TextRange.Copy
DoEvents
shp1.Tags.Add "Deselect", "yes"
For Each shp In ActiveWindow.Selection.ShapeRange
If shp.Tags("Deselect") = "yes" Then
Else
With shp
With .TextFrame
For i = 1 To 9
With .Ruler
.Levels(i).FirstMargin = 0
.Levels(i).LeftMargin = 0
End With
Next
End With
With .TextFrame2
With .TextRange
.ParagraphFormat.Bullet.Type = ppBulletNone
.PasteSpecial msoClipboardFormatPlainText
.Text = Replace(.Text, vbCr & vbCr, vbCr)
End With
End With
End With
DoEvents
End If
Next shp
For Each shp In ActiveWindow.Selection.ShapeRange
If shp.Tags("Deselect") = "yes" Then
shp.Tags.Delete "Deselect"
End If
Next shp
Exit Sub
err:
MsgBox "Please select at least two shapes (no tables)"
End Sub
You're seeing the effect of different line endings in macOS and Windows. Windows uses a carriage return plus a line feed (vbCrLf in VBA), while macOS uses only a line feed vbLf. When you paste into PowerPoint, the program translates both characters into separate paragraphs, with the second one being empty.
Give this code a try:
Sub PasteTest()
With ActivePresentation.Slides(1).Shapes(1).TextFrame2.TextRange
.PasteSpecial msoClipboardFormatPlainText
.Text = Replace(.Text, vbCr & vbCr, vbCr)
End With
End Sub
It shouldn't affect operations in Windows, because double returns aren't created there.
Related
I would like to use VBA to change the width of the images on-by-one in the doc. I need to manually judge wether the current image should be changed or not with a yes-or-no message box when looping through.
The current code is listed below, it works, but the problem is that WORD does not indicate which image is the current one.
Thanks!
Sub change_images()
Dim iShp As InlineShape
For Each iShp In ActiveDocument.InlineShapes
With iShp
If .Type = wdInlineShapePicture Then
iShp.Select
CarryOn = MsgBox("Change current image?", vbYesNo, "")
If CarryOn = vbYes Then
.LockAspectRatio = msoTrue
.Width = 28.345 * 12
End If
End If
End With
Next
End Sub
I tried to add a .Select before the MsgBox line, but the usually selection mark can not be viewed when the code is running.
iShp.Select
Application.ScreenRefresh
You can be solved by using ScreenRefresh method.
I try to use a selected picture on the slide and copy/paste it into the Placeholder (I can not load the picture from a file, it has to be from the slide itself.)
It works fine when I go through the code with F8 step by step. But when I run the macro, the placeholder stays empty.
I tried to set Delays in order to give PPT enough time but no matter how high I make the delay, it won't work (Placeholder doesn't get filled)
Any ideas, what could cause this weird behavior? Better ideas how to place the selected image into the template Placeholder (should work on Mac too though). Thank you for your time!
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
Dim oPl As Shape
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case oPl.PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
Delay 4
oPl.Select
Delay 4
ActiveWindow.View.Paste
Delay 5
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
'Delay 1.5
'sImage.Delete
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
ErrorHandler:
'Resume Next
End Sub
Try adding DoEvents after you copy and after you paste. Also, try separating your copy and paste operations into separate procedures. VBA should wait until the operations are complete before entering and exiting a procedure. I haven't tested it, but maybe something like this . . .
Option Explicit
Sub SetImageIntoPlaceholder()
Dim sImage As Shape
Dim iSl As Integer
Dim oSl As Slide
On Error GoTo ErrorHandler
If ActiveWindow.Selection.ShapeRange().Count <> 1 Then
MsgBox "Please select only the picture you wish to place in the Placeholder", vbOKOnly Or vbCritical, Application.Name
Exit Sub
End If
iSl = ActiveWindow.View.Slide.SlideIndex
Set oSl = ActivePresentation.Slides(iSl)
Set sImage = ActiveWindow.Selection.ShapeRange(1)
sImage.Copy
DoEvents
PastePictureInSlide oSl
ErrorHandler:
'Resume Next
End Sub
Private Sub PastePictureInSlide(ByVal oSl As Slide)
Dim oPl As Shape
For Each oPl In oSl.Shapes
If oPl.Type = msoPlaceholder Then
With oPl
Select Case .PlaceholderFormat.Type
Case Is = 18
'Its a picture placeholder
.Select
ActiveWindow.View.Paste
'oSl.Shapes.Paste
Application.CommandBars.ExecuteMso ("SlideReset")
DoEvents
Exit Sub
Case Else
' ignore other shape types
End Select
End With
End If
Next oPl
End Sub
I have a Word document with a number of AutoShapes.
I loop through the shapes by a for loop, and select those with a specific foreColor in order to delete them:
For each sh in ActiveDocument.Shapes
if sh.fill.foreColor = myColor then
sh.delete
end if
next i
This does not work. However if I replace sh.fill.foreColor with another color for example, it works perfectly.
The more odd is that if I put sh.delete after sh.fill.foreColor = newColor, the first line doesn't execute !! :
For each sh in ActiveDocument.Shapes
if sh.fill.foreColor = myColor then
sh.fill.forecolor = newColor
sh.delete
end if
next i
According to the documentation, the delete method requires an index argument representing the index of the shape. I tried entering an index, but it doesn't work.
Does anyone know why this happens?
Tank you very much
Try this and see if the output is what you expect:
Sub Tester()
Dim i As Long
For i = activedocument.Shapes.Count To 1 Step -1
With activedocument.Shapes(i)
Debug.Print "#: " & i, "Name: " & .Name, "Color: " & .Fill.ForeColor
If .Fill.ForeColor = 12874308 Then .Delete '<< works fine for me...
End With
Next i
End Sub
Edit: it's pretty straightforward to demonstrate the problem with using the For Each approach. For example this code only deletes half of the shapes in a document on each run:
Dim shp
For Each shp In ActiveDocument.Shapes
shp.Delete
Next shp
I'm making an Add-in for PowerPoint 2013. My goal is to convert all equations that I find on slides to normal text, to change the font of those equations.
Because it won't let me change font while they are equations. I managed to find the equations, by iterating through text ranges and finding font name, they use "Cambria Math". So my question is how can programmatically change equations to normal text, Like the button in equation tools does? And it seems for some reason they removed "record macro" from PowerPoint, so I couldn't get help from that.
I tried recording macro in word and doing the same thing, and i got: Selection.OMaths(1).ConvertToMathText, but it doesn't seem to be OMaths in PowerPoint.
Dim Application As PowerPoint.Application = New PowerPoint.Application
Dim Presentation As PowerPoint.Presentation = Application.ActivePresentation
Dim Windows As PowerPoint.DocumentWindows = Application.Windows
For Each Slide As PowerPoint.Slide In Presentation.Slides
For Each Shape As PowerPoint.Shape In Slide.Shapes
For Each Paragraph As PowerPoint.TextRange In Shape.TextFrame.TextRange
For Each Line As PowerPoint.TextRange In Paragraph.Lines
If Line.Font.Name = "Cambria Math" Then
With Line.Font
.Name = "Calibri"
.Bold = True
End With
ElseIf Line.Font.Name = "Calibri" Then
With Line.Font
.Name = "Palatino"
End With
End If
Next Line
Next Paragraph
Next Shape
Next Slide
End Sub
Other text here is changed normally, but equations the ones with "Math Cambria" font, are unchanged.
I also tried to get selection, then something with OMaths, like in Word Vsto, but, it seems OMaths is not part of the PowerPoint. This next code is actually supposed to change it to equation, but i guess if it worked, could have find a way to reverse it.
For Each Window As PowerPoint.DocumentWindow In Windows
Selection.OMaths(1).ConvertToMathText
Next Window
I got it to work with PowerPoint 2016 in VBA. I didn't have "Calibri" in my list of fonts, so I changed it to "Calibri (Body)" and it works. It may be the same issue you're having with the .NET VSTO Addin. If I have time, I'll build a example of the VSTO Addin and post the results as well.
Video
VBA Code
Public Sub UpdateShapeFont()
On Error GoTo ErrTrap
Dim Application As PowerPoint.Application: Set Application = New PowerPoint.Application
Dim Presentation As PowerPoint.Presentation: Set Presentation = Application.ActivePresentation
Dim Windows As PowerPoint.DocumentWindows: Set Windows = Application.Windows
Dim Slide As PowerPoint.Slide
Dim Shape As PowerPoint.Shape
Dim Paragraph As PowerPoint.TextRange
Dim line As PowerPoint.TextRange
For Each Slide In Presentation.Slides
For Each Shape In Slide.Shapes
For Each Paragraph In Shape.TextFrame.TextRange
For Each line In Paragraph.Lines
Select Case line.Font.Name
Case "Cambria Math"
With line.Font
.Name = "Calibri (Body)" 'check if the font exists in your list of fonts; it did not work for "Calibri"
.Bold = True
End With
Case "Calibri"
With line.Font
.Name = "Palatino"
End With
End Select
Next line
Next Paragraph
Next Shape
Next Slide
ExitProcedure:
On Error Resume Next
Exit Sub
ErrTrap:
Select Case Err.number
Case Else
Debug.Print "Error #: " & Err.number & " |Error Description: " & Err.description
End Select
Resume ExitProcedure
Resume 'for debugging
End Sub
My macro throws an "index out of range" error as it goes through ActiveWindow.Selection.shapeRange on one particular group of shapes only.
The specific presentation can be found at http://free-editable-worldmap-for-powerpoint.en.softonic.com (select any larger group of shapes, i.e. South America, and run the code to replicate error)
The code is below:
Dim shp As Shape
For Each shp In ActiveWindow.Selection.shapeRange
shp.Fill.Transparency = 0 'Or any other code
Next shp
I also tried using For loop with no success ('For i=1 To ActiveWindow.Selection.shapeRange.Count Step 1'). Notably, there is no particular index at which the error is thrown- sometimes it's i=3, sometimes i=35, sometimes more.
There are some msoLine shapes in this slide (shp.Type = 9). This will raise an error:
The specified value is out of range.
If you have inadvertently selected them. (I would expect an Object does not support this property or method error, since the msoLine does not have a .Fill member -- but sometimes the error messages are cryptic. In any case, this error can be trapped).
All of the other shapes on that slide are type 5 or 6, which support the .Fill.
I used this to debug, although I am unable to replicate your specific error (unless you simply mistyped the error description), perhaps it will be of some assistance to you. It attempts to set the Fill.Forecolor for all shapes in the slide, and will print some information about errors to the Immediate Window in the VBE.
Sub Test()
'Determine there are shapes which do not have a .Fill.ForeColor
Dim shp As Shape
For Each shp In ActivePresentation.Slides(1).Shapes
On Error Resume Next
shp.Fill.ForeColor.RGB = 43506
If Err.Number <> 0 Then
Debug.Print Err.Description & " >> " & _
shp.Name & " is shape type " & shp.Type
On Error GoTo 0
Else:
shp.Fill.Transparency = 0
shp.Fill.ForeColor.RGB = 12632256
End If
Next
End Sub