I've created a custom Powerpoint add-in (ppam) using the following code (from this tutorial https://www.rdpslides.com/pptfaq/FAQ00031_Create_an_ADD-IN_with_TOOLBARS_that_run_macros.htm):
Sub Auto_Open()
Dim oToolbar As CommandBar
Dim oButton As CommandBarButton
Dim MyToolbar As String
MyToolbar = "My toolbar"
On Error Resume Next
Set oToolbar = CommandBars.Add(Name:=MyToolbar, _
Position:=msoBarFloating, Temporary:=True)
If Err.Number <> 0 Then
Exit Sub
End If
On Error GoTo ErrorHandler
Set oButton = oToolbar.Controls.Add(Type:=msoControlButton)
With oButton
'repeat code for each button'
End With
oToolbar.Visible = True
NormalExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & vbCrLf & Err.Description
Resume NormalExit:
End Sub
It works well, and I've been able to add multiple buttons to the Add-in toolbar. However, all buttons crowd on the same row, and I would really like to have a row-break, in order to fit more buttons in the toolbar overview.
I've tried to create separate add-in's for them to display on separate rows, but that just leads to one of the add-ins not showing. Is there a way to add a row-break to the add-in?
Related
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 :)
In a small Powerpoint application I'm coding I use the .FileDialog method to enable the user to select the target file for the app. Everything works fine, except if the user wants to cancel the dialog by either clicking the cancel button or the X in the upper RH corner, an error is generated and execution fails.
So, what are the PowerPoint error traps if the user wants to cancel? I tried using Excel VBA code ('On Error', vbCancel, and If statements) to trap the error with no luck.
Any suggestions?
Sub ShowFileDialog()
Dim dlgOpen As FileDialog
Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = True
.Show
[meta code] If selection = "" then exit sub
or
if vbCancel = True then exit sub
End With
End Sub
Show returns a value.
Sub ShowFileDialog()
Dim dlgOpen As FileDialog`
Set dlgOpen = Application.FileDialog(Type:=msoFileDialogOpen)
With dlgOpen
.AllowMultiSelect = True
If .Show Then
Dim I As Integer
For I = 1 To .SelectedItems.Count
Debug.Print .SelectedItems(I)
Next
Else
Debug.Print "User cancelled"
End If
End With
End Sub
This macro is one that was not written by me, so I'm having trouble understanding the source of the error. I have a macro that's supposed to run on startup to adjust the ribbon to add a button, and another part to remove styles when you select that button. Currently, I get the message: Object variable or With block variable not set. When I select "Debug" it goes to the VBA screen and immediately gives me 3 more error pop-ups that say: Can't execute code in break mode.
The first part of this is the two subs that are to run on startup, which are:
Dim WithEvents app As Application
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
Module1.MyRibbon.Invalidate
End Sub
Private Sub Workbook_Open()
Set app = Application
End Sub
It highlights the Module1.MyRibbon.Invalidateas the problematic bit. Personally I don't see anything wrong with this per se, but perhaps the problem is in the Module 1? That code contains three subs, as follows:
Public MyRibbon As IRibbonUI
'Callback for customUI.onLoad
Sub CallbackOnLoad(Ribbon As IRibbonUI)
Set MyRibbon = Ribbon
End Sub
'Callback for customButton getLabel
Sub GetButtonLabel(control As IRibbonControl, ByRef returnedVal)
If ActiveWorkbook Is Nothing Then
returnedVal = "Remove Styles"
Else
returnedVal = "Remove Styles" & vbCr &
Format(ActiveWorkbook.Styles.Count, "#" & Application.International(xlThousandsSeparator) & "##0")
End If
End Sub
Sub RemoveTheStyles(control As IRibbonControl)
Dim s As Style, i As Long, c As Long
On Error Resume Next
If ActiveWorkbook.MultiUserEditing Then
If MsgBox("You cannot remove Styles in a Shared workbook." & vbCr & vbCr & _
"Do you want to unshare the workbook?", vbYesNo + vbInformation) = vbYes Then
ActiveWorkbook.ExclusiveAccess
If Err.Description = "Application-defined or object-defined error" Then
Exit Sub
End If
Else
Exit Sub
End If
End If
c = ActiveWorkbook.Styles.Count
Application.ScreenUpdating = False
For i = c To 1 Step -1
If i Mod 600 = 0 Then DoEvents
Set s = ActiveWorkbook.Styles(i)
Application.StatusBar = "Deleting " & c - i + 1 & " of " & c & " " & s.Name
If Not s.BuiltIn Then
s.Delete
If Err.Description = "You cannot use this command on a protected sheet. To use this command, you must first unprotect the sheet (Review tab, Changes group, Unprotect Sheet button). You may be prompted for a password." Then
MsgBox Err.Description & vbCr & "You have to unprotect all of the sheets in the workbook to remove styles.", vbExclamation, "Remove Styles AddIn"
Exit For
End If
End If
Next
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
I've never written any Activation or Ribbon-related macro, so I have no idea where the error could be. The addin works just find regardless of this message, as the button gets added and it functions as it should when the file isn't a blank file, but I get the error pop-up and the button doesn't get created right on new, blank files. How could I fix this?
I simply deleted:
Private Sub App_WorkbookActivate(ByVal Wb As Workbook)
Module1.MyRibbon.Invalidate
End Sub
No runtime errors on start of excel and no issues when using the script; counts fine and deletes fine. Windows 7, Excel 2010.
I am experiencing an issue with Outlook automation,
To keep it simple I will first show you a shorter version of my code :
Sub test()
Dim GetOutlookApp As Object
Set GetOutlookApp = CreateObject("Outlook.Application")
End Sub
First, I do want to keep the late binding solution.
This sub launch Outlook in the taskbar (small icon). When I double click on it, a message pops up: "No active explorer object found" (title of the window: "Error"). Then the Outlook Inbox window opens when I click on OK.
My script is for end users so I don't want this message appears even if the user just has to click on OK (the rest of the main sub has no one issue).
I have to solve this problem to be able to send an email with outlook and to make sure the email is not in the Outbox folder.
What I am looking for is a way to open outlook, without this message, using late binding.
Below is the full code to open outlook before sending the email (source: ron de bruin). It works perfectly except the outlook message. The message pops up on this line:
obj.Session.GetDefaultFolder(olFolderInbox).Display
I tried AppActivate and others stuffs but I did not succeed and can't find any info on google about that!
Thanks for your help
Sub send_mail ()
Dim OutApp As Object
Set OutApp = OutlookApp() 'OPEN OUTLOOK
'Set OutApp = CreateObject("Outlook.Application") 'OPEN OUTLOOK simple solution
With ActiveSheet.MailEnvelope
...
End With
End sub
Public Function OutlookApp( _
Optional WindowState As Long = olMaximized, _
Optional ReleaseIt As Boolean = True _
) As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
Static obj As Object
On Error GoTo ErrHandler
Select Case True
Case obj Is Nothing, Len(obj.Name) = 0
Set obj = GetObject(, "Outlook.Application")
If obj.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
obj.Session.GetDefaultFolder(olFolderInbox).Display
obj.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set obj = Nothing
End Select
Set OutlookApp = obj
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set obj = Nothing
Case 429, 462
MsgBox "Err.Number OutlookApp: " & Err.Number
Set obj = GetOutlookApp()
If obj Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function
Private Function GetOutlookApp() As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
'On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function
Use the Add method of the Explorers class to create a new instance of the explorer window. Then you need to call the Display method of the Explorer class (not Folder).
Sub DisplayDrafts()
Dim myExplorers As Outlook.Explorers
Dim myOlExpl As Outlook.Explorer
Dim myFolder As Outlook.Folder
Set myExplorers = Application.Explorers
Set myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set myOlExpl = myExplorers.Add(myFolder, olFolderDisplayNoNavigation)
myOlExpl.Display
End Sub
This sub launch Outlook in the taskbar (small icon). When I double click on it, a message pops up: "No active explorer object found" (title of the window: "Error"). Then the Outlook Inbox window opens when I click on OK.
Typically you shouldn't see any icons in the task bar. Make sure that you have all the latest updates and service packs installed for the OS and Outlook. Also check out the list of running processes before automating Outlook - make sure that no Outlook instances running at the moment.
See How to automate Outlook from another program for more information.
Using the Eugene Astafiev code I have solved my issue! Thanks Eugene!
Here is the code:
Sub that send the email:
Sub Send_Mail()
'**This sub aims to send the mail that contains the job sheet
'Deactivate the screen updating : increase the speed and looks better
Application.ScreenUpdating = False
'Select the range of data
ActiveSheet.Range(FirstCol_JS & 1 & ":" & LastCol_JS & Firstrow_JS + nb_item_scanned - 1).Select
'Show the envelope on the ActiveWorkbook. This line prevents a bug (Method 'MailEnveloppe' of object '_Worksheet' failed. -2147467259, 80004005)
ActiveWorkbook.EnvelopeVisible = True
'Make sure outlook is opened or open it *****HERE IS WHY MY QUESTION*****
Call OutlookApp <------------------------------------------------
'Email error handling
On Error GoTo ErrorManagement
With ActiveSheet.MailEnvelope
'Subject is the title of the mail
.Item.Subject = "Job Sheet"
'Introduction is the content of the mail
.Introduction = "Hi John," & vbCrLf & _
"..." & vbCrLf & _
"Regards, The computer"
.Item.To = "alias#domain.com"
.Item.Send
End With
'Select the home page (main sheet)
'It is needed to activate the screenupdating so that the userform can be displayed on the sheet1
Application.ScreenUpdating = True
Else
'Normally, this message should never appear
MsgBox "You can't create a job sheet without any item. Nothing was done.", , "Action not allowed"
End If
'Exit sub before the error handling codes
Exit Sub
ErrorManagement:
'Activate the screen updating : be able to show that the outlook interface disappears
Application.ScreenUpdating = True
'Hide the outlook interface
ActiveWorkbook.EnvelopeVisible = False
'Activate the Excel windows so that the msgbox does not appear in the Windows taskbar
'This line is mandatory because the outlook interface is in front of the Excel workbook when it appears, so we have to activate again the Excel worbook
Call ActivateExcel
End Sub
Principal sub that manage to open Outlook
Sub OutlookApp(Optional ReleaseIt As Boolean = True)
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode, and Eugene Astafiev http://stackoverflow.com/questions/31198130/vba-outlook-no-active-explorer-found
'Declaration of an object for outlook. The static mode allows to keep the object when this sub is launched more than one time
Static olObject As Object 'Early binding: Outlook.Application
'Declaration of variable objects to open the outlook window (prevent the email to be stuck in the Outbox folder)
Dim myExplorers As Object 'Early binding: Outlook.Explorers
Dim myOlExpl As Object 'Early binding: Outlook.Explorer
Dim myFolder As Object 'Early binding: Outlook.Folder
'Error handling
On Error GoTo ErrHandler
Select Case True
'If the olObject is nothing then try to create it
Case olObject Is Nothing, Len(olObject.Name) = 0
'This line will work if outlook is already opened, otherwise it will create an error and the code will go to ErrHandler
Set olObject = GetObject(, "Outlook.Application")
'If there is not already one opened windows of outlook
If olObject.Explorers.Count = 0 Then
InitOutlook:
'Open outlook window to prevent the email to be stucked in the Outbox folder (not sent)
Set myExplorers = olObject.Explorers
Set myFolder = olObject.GetNamespace("MAPI").GetDefaultFolder(6) 'olFolderInbox: 6
Set myOlExpl = myExplorers.Add(myFolder, 0) 'olFolderDisplayNoNavigation: 2, olFolderDisplayNormal:0
'Early binding code:
'Set myExplorers = Application.Explorers
'Set myFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Set myOlExpl = myExplorers.Add(myFolder, olFolderDisplayNoNavigation)
myOlExpl.Display
End If
End Select
'Delete the olObject variable is the ReleaseIt boolean is true
If ReleaseIt = True Then
Set olObject = Nothing
End If
'Possibility to set the OutlookApp function as the outlook object, if OutlookApp is declared like this: "Function OutlookApp(Optional ReleaseIt As Boolean = True) as Object"
'Set OutlookApp = olObject
ExitProc:
Exit Sub
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set olObject = Nothing
Case 429, 462 '429: outlook was not opened, the Set olObject = GetObject(, "Outlook.Application") code line above did not work
Set olObject = CreateOutlook() 'Launch the CreateOutlook function: CreateOutlook = CreateObject("Outlook.Application")
If olObject Is Nothing Then 'If the outlook object is still empty it means that there is a more serious issue (outlook not installed on the computer for example)
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else 'If olObject is no more nothing, go back to the code above and open the outlook window
Resume InitOutlook
End If
Case Else 'For any other error numbers
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume 'For debugging
End Sub
Second sub that manage to open outlook
Private Function CreateOutlook() As Object
'***This sub is a part to the global way to open outlook before sending an email (prevent the outbox bug, email stucked into the outbox)
'***Source: http://www.rondebruin.nl/win/s1/outlook/openclose.htm, late binding mode
'Error handling
On Error GoTo ErrHandler
Set CreateOutlook = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Set CreateOutlook = Nothing
Resume ExitProc
Resume 'For debugging
End Function
FYI here is the code to activate the Excel window
Sub ActivateExcel()
'***This sub aims to activate Excel windows (so that it's in front of the windows)
'Set variable title equal to exact application window title
Dim ExcelTitleCaption As String
ExcelTitleCaption = Application.Caption
'Activate Microsoft Excel
AppActivate ExcelTitleCaption
End Sub
Thanks!! Topic solved
This issues is a bit of quirk - and it may be a systematic issue that just won't work. My overall project is that I need to have a presentation playing on loop 24/7 and it has some linked charts from an excel file that it needs to pull data from. I wrote the basic code to do this.
However when I first open PowerPoint and run the presentation -> No code is run (verified with Debug.Prints and MsgBoxes). However if I just open up the code in developer (But don't edit) and run the presentation, everything works as planned. I've turned all the Trust Center Security settings to allow all macros and setup my network files as automatically trusted as well. I've also verified that this occurs with another of the laptops here. Any help is greatly appreciated. For reference, this is my simple code that needs to run.
Sub updateCharts()
Dim i As Integer
Dim sld As Slide
Dim shp As Shape
If IsFileOpen(filePath) = False Then
If ActivePresentation.SlideShowWindow.View.Slide.SlideIndex = 1 Then
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
On Error Resume Next
shp.LinkFormat.Update
shp.Chart.Refresh
On Error GoTo 0
End If
Next shp
Next sld
End If
End If
End Sub
Sub OnSlideShowPageChange(ByVal Win As SlideShowWindow)
Call updateCharts
End Sub
Thanks for the opportunity. There are 3 main parts that can allow you to do that.
Need a way to auto run a macro upon presentation launch
Need a way to handle PowerPoint Application Events
A regular module for calls from Event Handler
Solution:
Follow instructions from PPT Alchemy, objective is to add UI element: <customUI xmlns="http://schemas.microsoft.com/office/2006/01/customui"
onLoad="onLoadCode" >
</customUI>
where onLoadCode is a sub you will create in a Module
According to MS How to: Use Events with the Application Object, you need to create a Class Module, have it initialized by a Sub. Here we want the onLoadCode to do initialization.
A Sub in a Module will do the Chart updates.
Ensure the Presentation is set to Kiosk mode for your purpose:
CODES
Class Module: EventClassModule
Public WithEvents App As Application
Private Sub App_SlideShowBegin(ByVal Wn As SlideShowWindow)
Debug.Print Now & vbTab & "App_SlideShowBegin"
updateCharts Wn
End Sub
Private Sub App_SlideShowNextSlide(ByVal Wn As SlideShowWindow)
Debug.Print Now & vbTab & "App_SlideShowNextSlide"
updateCharts Wn
End Sub
Module: Player
Dim X As New EventClassModule
Sub OnLoadCode()
InitializeApp
End Sub
Sub InitializeApp()
Set X.App = Application
ActivePresentation.SlideShowSettings.Run
End Sub
Sub updateCharts(ByRef Win As SlideShowWindow)
Dim sld As Slide
Dim shp As Shape
Debug.Print Now & vbTab & "Playing slide with index: " & Win.View.Slide.SlideIndex
If Win.View.Slide.SlideIndex = 1 Then
Debug.Print Now & vbTab & "Update charts on other slides!"
For Each sld In Win.Presentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Debug.Print Now & vbTab & "Update chart """ & shp.Chart.Name & """ on slide index " & sld.SlideIndex
On Error Resume Next
shp.LinkFormat.Update
shp.Chart.Refresh
If Err.Number <> 0 Then
Debug.Print Now & vbTab & "ERR(" & Err.Number & ") " & Err.Description
Err.Clear
End If
On Error GoTo 0
End If
Next
Next
End If
End Sub
You should remove the Debug lines for production environment. Have fun!