VB.Net VSTO PowerPoint Addin - vba

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

Related

VBA in MS powerpoint to remove textbox on each slide

As title, I want to remove the page number text box in each slide which was created by old version of MS powerpoint 10 years old in following format
page 1 of 47
My 1st attempted code is
With ActivePresentation.Slides.Find
.Forward = True
.Wrap = wdFindStop
.Text = "*/47"
.Replacement.Text = ""
.Replace = wdReplaceAll
.MatchCase = False
End With
My 2nd attempted code is
Sub ClNumbers()
Dim oSl As Slide
Dim oSh As Shape
Dim oTxtRng As TextRange
Dim sTextToFind As String
sTextToFind = "*/47"
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
If InStr(oSh.TextFrame.TextRange.Text, sTextToFind) > 0 Then
Set oTxtRng = oSh.TextFrame.TextRange.Characters(InStr(oSh.TextFrame.TextRange.Text, sTextToFind), Len(sTextToFind))
Debug.Print oTxtRng.Text
With oTxtRng
.Font.Bold = True
End With
End If
End If
End If
Next
Next
End Sub
neither does work, would you please help to correct my code to remove all page number by VBA. thanks in advance.
please correct me vba code or provide your elegant method.
(1) As far as I know, there is no global find/replace in VBA for Powerpoint. At least there is no Find-method for the Application-object, the Presentation-Object or the Slides- or Shapes collection. Your attempt 1 fails with a compiler error.
(2) Powerpoint doesn't support wildcard or regular expressen search.
(3) In your 2nd attempt, you would mark the text in Bold rather than delete the shape or the text of the shape - if it was found (it isn't).
You will need to loop over all shapes of all slides and check if it contains a certain text pattern. You 2nd attempt is close, but the VBA function InStr doesn't work with wildcards either. Instead, you could use the VBA Like-operator.
You now need to make up your mind what you want to do with the shapes:
o You can delete them completly with oSh.Delete
o You can hide them with oSh.Visible = False
o You can just delete the text with oSh.TextFrame.TextRange.Characters.Delete
(4) If the shapes are defined on the slide master of the presentation, the code will not do anything as the shapes are not present on the slides at all. In that case, simply edit the slide master in Powerpoint - no code needed.
So your code could look like your 2nd attempt, just modify the inner part (and decide what you want to do)
If oSh.TextFrame.TextRange.Text Like sTextToFind Then
' oSh.Delete
' oSh.Visible = False
oSh.TextFrame.TextRange.Characters.Delete
End If
Thanks FunThomas, it works perfectly.
Here is the code:
Sub deletepagenumber()
' Remove the page number text box in each slide which was created by old version of MS powerpoint
' Before run this code, please check if the page number could be turned off in the slide master
' Thanks to FunThomas # stackoverflow
Dim oSl As Slide
Dim oSh As Shape
Dim oTxtRng As TextRange
Dim sTextToFind As String
' Before run this code, please input the format of the page number, e.g. page ?/47, can be searched as "*/47"
sTextToFind = "*/47"
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
If oSh.HasTextFrame Then
If oSh.TextFrame.HasText Then
If oSh.TextFrame.TextRange.Text Like sTextToFind Then
' oSh.Delete
' oSh.Visible = False
oSh.TextFrame.TextRange.Characters.Delete
End If
End If
End If
Next
Next
End Sub

Paste Special msoClipboardFormatPlainText creates unwanted line break on Mac

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.

PowerPoint vba BeforeSaveAs

I have a PowerPoint template, which is links up with Excel. Some of the areas in Excel has been copied with links, so that it will automatically update.
Whenever this PowerPoint template will be Saved As, I need to remove these links to external Excel Workbooks.
Is there somehow to do this in PowerPoint just like
Private Sub Workbook_Before Save(ByVal SaveAsUI As Boolean, Cancel As Boolean) in Excel?
So far
I tried the below-mentioned answer, without any luck. The code somehow seems to not run - here I don't know if I'm doing it wrong. I tried running it in a normal module and a class module - without any way of provoking it to happen. Then I tried running it as a normal sub, and here I got errors on the HasRevisionInfoand alsoApplication.PresentationBeforeSave.
Yes there is, look into Application.PresentationBeforeSave event which Occurs before a presentation is saved.
Here is vb example
Private Sub PPTApp_PresentationBeforeSave(ByVal Pres As Presentation, _
Cancel As Boolean)
Dim intResponse As Integer
Set Pres = ActivePresentation
If Pres.HasRevisionInfo Then
intResponse = MsgBox(Prompt:="The presentation contains revisions. " & _
"Do you want to accept the revisions before saving?", Buttons:=vbYesNo)
If intResponse = vbYes Then
Cancel = True
MsgBox "Your presentation was not saved."
End If
End If
End Sub
I got it to work after a lot of research, #0m3R provided me with some of the right answer.
Somehow I found somewhere, that I had to combine a class module with a regular module.
Here's the code for the Class Module:
Private Sub PPTApp_PresentationBeforeSave(ByVal Pres As Presentation, Cancel As Boolean)
Dim sld As Slide
Dim shp As Shape
Dim TextValue As String
Dim intResponse As Integer
Set Pres = ActivePresentation
TextValue = "You're about to save this PowerPoint." & Chr(10) & "This Powerpoint is programmed to break all links" & _
" meaning that all of the content will not be updated automatically anymore." & Chr(10) & Chr(10) & _
"Do you wish to break all links?"
If Pres.Name <> "A3.potm" Then
intResponse = MsgBox(TextValue, Buttons:=vbYesNo)
If intResponse = vbYes Then
For Each sld In Pres.Slides
For Each shp In sld.Shapes
On Error Resume Next
shp.LinkFormat.BreakLink
On Error GoTo 0
Next shp
Next sld
Else
MsgBox "You didn't break all links - the presentation may be overwritten in the future..."
End If
End If
End Sub
Here's the code for the regular Module
Option Explicit
Dim cPPTObject As New cEventClass
Sub InitializeApp()
Set cPPTObject.PPTApp = Application
End Sub
I chose to make a "Command Button" in my PowerPoint, to have the user run a code before viewing the presentation. Then whenever they will save this presentation, the have to choose if they want to delete the links or not :)
Thank you for your assistance :)

Word document : Set to landscape

I have this ridiculous problem on ms-word 2007. I have most of my macro working as intended but the orientation can't seem to stay in place. I set it to landscape using VBA but it will always go back to portrait. If I step into the code right after this line the document IS in landscape but as soon as I click even once only in the document it goes back to portrait.
Do you guys have an idea why this happens ? I can't seem to find anyone having this bug on Google.
Option Explicit
Sub créer_rapport()
Dim wdApp As Word.Application
Dim wdDoc As Word.Document
Set wdApp = New Word.Application
wdApp.Visible = True
Set wdDoc = wdApp.Documents.Open(Range("path_fichier").Value)
wdApp.Selection.WholeStory
wdApp.Selection.Font.Name = "Courier New"
wdApp.Selection.Font.Size = 7
wdDoc.PageSetup.Orientation = wdOrientLandscape
wdDoc.PageSetup.PaperSize = wdPaperLegal
wdDoc.SaveAs ActiveWorkbook.Path & "\test2", wdFormatXMLDocument
Do While wdApp.Selection.Find.Execute("Merge")
wdApp.Selection.MoveUp wdLine, 1
wdApp.Selection.InsertBreak wdPageBreak
wdApp.Selection.MoveDown wdLine, 2
Loop
With wdDoc
.SaveAs (ActiveWorkbook.Path & "\test")
.Close (True)
End With
wdApp.Quit False
End Sub
This is all there is to my macro (for now).
(Oh and you can highlight bad style, this is the first time I do VBA macros for Word (I do them all the time in Excel))
Thanks !
Instead of:
wdDoc.PageSetup.Orientation = wdOrientLandscape
Try this:
Selection.PageSetup.Orientation = wdOrientLandscape

Macro VBA to get selected text in Outlook 2003

I am trying to use this code snippet to get the selected text in outlook 2003
Sub SelectedTextDispaly()
On Error Resume Next
Err.Clear
Dim oText As TextRange
''# Get an object reference to the selected text range.
Set oText = ActiveWindow.Selection.TextRange
''# Check to see whether error occurred when getting text object
''# reference.
If Err.Number <> 0 Then
MsgBox "Invalid Selection. Please highlight some text " _
& "or select a text frame and run the macro again.", _
vbExclamation
End
End If
''# Display the selected text in a message box.
If oText.Text = "" Then
MsgBox "No Text Selected.", vbInformation
Else
MsgBox oText.Text, vbInformation
End If
End Sub
When running this macro I get the error
---------------------------
Microsoft Visual Basic
---------------------------
Compile error:
User-defined type not defined
Do I need to add any references to fix this up?
#Kusleika, I tried the option you had suggested and still the same errors came up.
Thanks for the help
May be I had not phrased my question in the proper way
Some more googling revealed that its not possible to get the selected text of a mail in preview pane. http://www.eggheadcafe.com/forumarchives/outlookprogram_VisualBasica/Aug2005/post23481044.asp
So I had to adjust the requirement so that I can do an action from an mail item window.
The following code helped me (had to make some changes to suit my needs)
Sub Blue_Code_Highlight()
Dim msg As Outlook.MailItem
Dim insp As Outlook.Inspector
Set insp = Application.ActiveInspector
If insp.CurrentItem.Class = olMail Then
Set msg = insp.CurrentItem
If insp.EditorType = olEditorHTML Then
Set hed = msg.GetInspector.HTMLEditor
Set rng = hed.Selection.createRange
rng.pasteHTML "<font style='color: blue; font-family:Times New Roman; font-size: 10pt;'>" & rng.Text & "</font><br/>"
End If
End If
Set insp = Nothing
Set rng = Nothing
Set hed = Nothing
Set msg = Nothing
End Sub
Source:http://www.outlookcode.com/threads.aspx?forumid=4&messageid=26992
#Kusleika thanks for the help, can I close this thread. Pls let me know.
Just in case someone is using the word editor instead of html, you can also insert this part:
If insp.EditorType = olEditorWord Then
Set hed = msg.GetInspector.WordEditor
Set word = hed.Application
Set rng = word.Selection
rng.Font.Name = "Times New Roman"
rng.Font.Size = 10
rng.Font.Color = wdColorBlack
End If
to get similar when word is the editor. i tried to paste this into a comment on the accepted answer, but it destroyed the formatting and was pretty useless, so posting as an answer.
Dim oText As Range
TextRange is a property of the TextFrame object. It returns a Range object. There is no TextRange object.