Automate Powerpoint Macro - vba

I have a PowerPoint Presentation that gets filled with pictures by a VBA script attached to it. I want to automatically open the Presentation and run the macro. Here's what I have tried:
turning the script into an add-in as shown here: it ran when I clicked activated it, but never when I simply opened powerpoint.
downloaded a pre-built add in, and called my script sub auto_open(). This worked, but because it is a macro enabled file(?), but I have to open powerpoint up and enable the add in before opening the file, so it's not much more automatic than just running the macro
Running PowerPoint through MatLab. I used the following commands that I found here, which do open powerpoint, and the file I am interested in.
g = actxserver('PowerPoint.Application');
Presentation = invoke(g.Presentations,'Open','\\path\Automatic_NEdN_Template2.pptm')
a = invoke(Presentation.Application,'Run','Auto_Open',[])
With small test cases, it even seemed to work--I could call a vba function that read data from a file and it would return the data to matlab, but when I tried to call the one that makes pictures, it returned NaN and the PowerPoint was not filled.
Ideally, I'd like to double click on something, then have PowerPoint open, and run my script.
Here are some code snippets if they'll help:
Function read_in_data_from_txt_file(strFileName As String) As String()
Dim dataArray() As String
Dim i As Integer
'Const strFileName As String = "C:\H5_Samples\Plots\WeeklyPlots\zz_avgTemp.txt"
Open strFileName For Input As #1
' -------- read from txt file to dataArrayay -------- '
i = 0
Do Until EOF(1)
ReDim Preserve dataArray(i)
Line Input #1, dataArray(i)
i = i + 1
Loop
Close #1
read_in_data_from_txt_file = dataArray
End Function
And here is the code for the pictures:
Function Auto_Open() As String
Dim oSlide As Slide
Dim oPicture As Shape
Dim oText As Variant
Dim heightScaleFactor As Single
Dim widthScaleFactor As Single
Dim width As Single
heightScaleFactor = 2.1
widthScaleFactor = 2.1
width = 205
Height = 360
ActiveWindow.View.GotoSlide 2
Set oSlide = ActiveWindow.Presentation.Slides(2)
Set oPicture = oSlide.Shapes.AddPicture("C:\H5_Samples\Plots\WeeklyPlots\Nominal DS Real spectra.png", _
msoFalse, msoTrue, 1, 150, Height, width)
Set oPicture = oSlide.Shapes.AddPicture("C:\H5_Samples\Plots\WeeklyPlots\Nominal DS Imaginary spectra.png", _
msoFalse, msoTrue, 350, 150, Height, width)
'Full Resolution
ActiveWindow.View.GotoSlide 3
Set oSlide = ActiveWindow.Presentation.Slides(3)
Set oPicture = oSlide.Shapes.AddPicture("C:\H5_Samples\Plots\WeeklyPlots\Full Resolution DS Real spectra.png", _
msoFalse, msoTrue, 1, 150, Height, width)
Set oPicture = oSlide.Shapes.AddPicture("C:\H5_Samples\Plots\WeeklyPlots\Full Resolution DS Imaginary spectra.png", _
msoFalse, msoTrue, 350, 150, Height, width)
End Function

Two ways to do this come to mind:
An Add-in that has an application-level event handler. Then, you could leverage the application class PresentationOpen event, compare the filename against the known file which you want to operate on, and then run the macro only when the right file has been opened. See this MSDN link for some information about creating an application-level event handler class.
Use the Ribbon XML framework to call a procedure from the ribbon's OnLoad event.
The second method would be essentially self-contained whereas the previous method would require at least one additional Add-in file to control the process.
The second method would use VBA that looks something like:
Option Explicit
Public Rib As IRibbonUI
'Callback for customUI.onLoad
Sub RibbonOnLoad(ribbon As IRibbonUI)
Set Rib = ribbon
Call Auto_Open() '### I would recommend changing your procedure name just to avoid confusion...
End Sub
Sub Auto_Open()
'### This is your procedure/macro that you want to run
' etc
' etc
End Sub
And you would need the ribbon XML (use the CustomUI editor to insert this, it can be done otherwise but this is probably the simplest):
<?xml version="1.0" encoding="UTF-8" standalone="yes"?>
<customUI onLoad="RibbonOnLoad" xmlns="http://schemas.microsoft.com/office/2009/07/customui">
</customUI>
The way this works is that when the file is opened, the RibbonOnLoad procedure is called, and that procedure then calls the procedure which executes your macro code. Note that unhandled run-time errors may cause the loss of the ribbon object variable which can be disastrous in larger applications, but in your specific use-case this shouldn't be a problem as re-opening the file from disk will always reload the ribbon anyways.
This link also has more info about the basics of ribbon customization, but for your purposes, I think the above code is all you should need.

Related

Creating shapes in similar fashion as with autoshape dropdown

I would like to make a macro in Powerpoint that enables me to create shapes in a similar fashion as when you select the autoshapes in the autoshape overview (i.e. once you call the macro you have a possibility to click to set the coordinates and subsequently you drag and click to set the width&height). Also, I would like to give it pre-set cosmetic characteristics (e.g. certain inner margins, fill color, border style and transparancy), which will be defined in the vba code.
I am aware of .addshapes(), however, this requires coordinates and height/width as input. Moreover, I have not find any posts / documents on vba to create shapes without defined coordinates and height/width.
Anyone some ideas on how to tackle this challenge?
Many thanks in advance!
Sofar
Building on what John Korchok suggested, here's code that retrieves the just-drawn shape so that your code can resume and manipulate it...
Sub testAppComBars()
Dim SHP As Shape
Application.CommandBars.ExecuteMso ("ShapeFreeform")
Stop
Set SHP = Selection.ShapeRange(1)
With SHP.Fill
.ForeColor.RGB = RGB(192, 0, 0)
.Transparency = 0.75
End With
End Sub
I would hope there's a more elegant solution than using Stop to pause code execution while the user picks the shape's location (or in this case, draws a freeform polyline/polygon), but that's all I could come up with off the top of my head.
I was fascinated by this problem and think this might help you.
Consider that when you draw a new autoshape, you have changed the window selection, and created a new selection ShapeRange with exactly 1 item (the new shape).
So by setting a WindowSelectionChange event, you're able to apply any formatting you wish at the time of creation.
First create a class module called cPptEvents with the following:
Public WithEvents PPTEvent As Application
Private Sub PPTEvent_WindowSelectionChange(ByVal sel As Selection)
On Error GoTo Errhandler
Debug.Print "IN_PPTEvent_WindowSelectionChange"
Dim oShp As Shape
If (ActiveWindow.ViewType = ppViewNormal) Then
With sel
If .Type = ppSelectionShapes Then
If .ShapeRange.Count = 1 Then
Set oShp = .ShapeRange(1)
If oShp.Type = msoAutoShape Then
If oShp.AutoShapeType = msoShapeOval Then
If oShp.Tags("new_oval") = "" Then
oShp.Fill.ForeColor.RGB = RGB(255, 0, 0)
oShp.Tags.Add "new_oval", "true"
End If
End If
End If
End If
End If
End With
End If
Exit Sub
Errhandler:
Debug.Print "Error: " & Err.Description
End Sub
This checks the selection every time it changes. If there's an oval selected, it looks for the "new_oval" tag, which will not exist for a newly created shape. In that case, it applies a red fill, although of course once you get to this point you can call an entirely different sub, pass along the shape, and do whatever you want formatting-wise to it.
By adding that "new_oval" tag, you ensure that the formatting will not be applied to an oval that hasn't been newly created. This allows the user to make manual changes to the formatting as needed -- otherwise you're just resetting the formatting every time the user selects an oval.
Note that for the _WindowSelectionChange event to be running in the background, you have to call this at some point:
Public MyEventClassModule As New cPptEvents
'
Public Sub StartMeUp()
Set MyEventClassModule.PPTEvent = Application
End Sub
You can include that one line from StartMeUp above in whatever Ribbon_Onload sub is triggered by your addin, if you're making a new addin ribbon.
With this solution, you don't even have to give the end user a special button or set of tools to create the shapes that are being formatted. It happens invisibly whenever the user draws a new shape from the native PPT tools.
This will put your cursor in drawing mode to draw an oval. After running, you may have to click on the slide once, then the cursor will change shape and you can draw an oval:
Sub DrawOval()
Application.CommandBars.ExecuteMso ("ShapeOval")
End Sub
Other commands to substitute for ShapeOval:
ShapeRectangle
ShapeElbowConnectorArrow
ShapeStraightConnectorArrow
Get the full list in Excel spreadsheets from Microsoft Office 2016 Help Files: Office Fluent User Interface Control Identifiers
Look for the powerpointcontrols.xlsx file and search the first column with "shape"
There are 173 shapes in the menu, so you have a lot of macros to write.

VB.NET - Programatically close the chart data object

My program is automating PowerPoint to loop through a series of chart parameters and create a new chart per parameter set. So far it works well for the first chart - however, it throws an error when attempting to create a second chart because the chart data grid is already open, and I can't find a method to properly close or dispose of the data grid after generating the graph.
Abridged code:
Imports Powerpoint = Microsoft.Office.Interop.PowerPoint
Imports Excel = Microsoft.Office.Interop.Excel
Private Sub generatePowerPoint(Qnum As String)
Try
'Create PowerPoint object and assign a presentation / slide to it
Dim oApp As Powerpoint.Application
Dim oPres As Powerpoint.Presentation
Dim oSlide As Powerpoint.Slide
oApp = New Powerpoint.Application()
oApp.Visible = True
oApp.WindowState = Powerpoint.PpWindowState.ppWindowMinimized
oPres = oApp.Presentations.Add
'Prepare to generate charts based on parameters in a listbox
Dim slideCount = lbQuestions.Items.Count
For slideN = 1 To slideCount
'Add a blank slide per graph request
oSlide = oPres.Slides.Add(slideN, Powerpoint.PpSlideLayout.ppLayoutBlank)
'Create a new shape object for each slide
Dim chartShape(slideCount) As Powerpoint.Shape
' What's causing the error: assign a chart object to the next shape object.
' This works for the first slide, but then throws an error that the PowerPoint
'Chart Data Grid is still open, preventing it from creating a new chart.
chartShape(slideN - 1) = oSlide.Shapes.AddChart2(-1, ChartFind(chartType), 50, 50, 775, 410)
Dim cData = chartShape(slideN - 1).Chart.ChartData 'Activate to refresh
Dim workbook = cData.Workbook
workbook.Application.Visible = False
Dim datasheet = workbook.Worksheets(1)
Dim colNumber As Integer = 2
Dim firstRowNumber As Integer = 2
datasheet.rows.clear()
datasheet.columns.clear()
For r = categoryNames.Count - 1 To 0 Step -1
datasheet.Cells(r + firstRowNumber, 1) = categoryNames(r)
Next
... Code to assign data and format the chart object ...
'Refresh the range accepted by the chart object
chartShape(slideN-1).Chart.Refresh
'Loop again
Next
I've spent some time going through the PowerPoint Interop docs and the PowerPoint Chart Object Model docs on msdn (e.g. https://learn.microsoft.com/en-us/previous-versions/office/developer/office-2010/ff760412(v=office.14), https://msdn.microsoft.com/en-us/vba/powerpoint-vba/articles/chartdata-object-powerpoint), and it seems that there's while there's a method to call the Chart Data Grid (chartdata.activate()) , there isn't a method to close the Chart Data Grid.
The exact error message thrown is "System.Runtime.InteropServices.COMException (0xBFFF64AA): The chart data grid is already open in 'Presentation 1 - PowerPoint'. To edit the data for this chart, you need to close it first. at Microsoft.Office.Interop.PowerPoint.Shapes.AddChart2( ..."
Does anyone have a suggestion?
Solved, mostly. For those who may have the same issue:
chartShape.Chart.ChartData.Workbook.close()
This is an undocumented method / IntelliSense will not provide it (hence the capitalization on Close), but after opening a chart object and editing the data, make sure you finish the code block with this before attempting to create a new chart object.
Now, this doesn't work if the open workbook isn't the one you opened (so for example, I can't test if there is a workbook opened by the user, and if so, close it). I'm resolving this issue by encapsulating the AddChart2 method in a Try Catch method, and if an error is thrown I let the user know to close the window and exit the subroutine so the program doesn't crash.

VBA Copy image from worksheet to Userform

Is there a way to runtime copy image from worksheet to userform image control?
I got a shape on a worksheet containing image. And when I select --> copy (ctrl + C) this shape, go to the UserForm1 design --> image1 properties I can do ctrl + v in the picture property of image1 and the image is pasted from clipboard to image1 control.
How can I achieve this using VBA in runtime?
I tried UserForm1.Image1.Picture = ActiveSheet.Shapes("Picture 1").Picture
And many similar bot none of them work
I usually get "Object doesn't support this property or method" or "Type mismatch"
Some time ago I was looking for a solution of the same problem. Did not find a solution, but I found a great workaround:
Make a separate form with plenty of pictures in it. Name it user_form_pics.
Then call the following on your form:
Me.Image1.Picture = user_form_pics.img_name11.Picture
This is how to use it in the constructor:
Private Sub UserForm_Initialize()
Me.Image1.Picture = user_form_pics.img_name11.Picture
End Sub
It works! Now your form has the picture of the user_form_pics.img_name11
Edit:
In case that you need to save Chart to picture, the procedure is the following:
Option Explicit
Public Sub TestMe()
Dim chtChart As Chart
Dim strPath As String
Set chtChart = ActiveSheet.ChartObjects(1).Chart
strPath = ThisWorkbook.Path & "\myChart.bmp"
chtChart.Export (strPath)
UserForm1.Show vbModeless
UserForm1.Image1.Picture = LoadPicture(strPath)
End Sub

Remove all macros from a visio 2013 file

I have a Viso 2013 .vstm file that launches a VBA macro on document creation (template instanciation when a user opens the template manually). This macro populates the created drawing from a datasource. When finished, I would like to save programatically (from VBA) the drawing that has been generated as a .vsdx file, i.e. with all VBA macros that were used to populate the drawing being removed.
My questions are:
Is it possible to remove all macros programatically from a VBA macro (Visio 2013) which is in the .vstm file itself without causing the VBA Macro to fail and if yes, how can I do it ?
If 1. is not possible, how can I force programatically Visio to save to .vsdx a drawing that has macros (i.e. save ignoring all macros)
If 2. is not possible, how can I copy current drawing (everything except macros) to a new Drawing which should then be savable to .vsdx?
I have tried the following:
Deleting all lines with VBProject.VBComponents.Item(index).CodeModule.DeleteLines causes the macro to fail with "End Function is missing" (I have checked and there is no missing End Function anywhere, my guess is that the macro probably deletes the code that hasn't been executed yet, which in turn causes this error)
Save and SaveEX do not work either, I get a "VBProjects cannot be saved in macro-free files" error/message, even if I add a Application.AlertResponse = IDOK prior to the call to Save / SaveEx.
Here follows a sample code.
Private Sub RemoveVBACode()
' If document is a drawing remove all VBA code
' Works fine however execution fails as all code has been deleted (issue 1)
If ActiveDocument.Type = visTypeDrawing Then
Dim i As Integer
With ActiveDocument.VBProject
For i = .VBComponents.Count To 1 Step -1
.VBComponents.Item(i).CodeModule.DeleteLines 1, .VBComponents.Item(i).CodeModule.CountOfLines
Next i
End With
On Error GoTo 0
End If
End Sub
Private Sub SaveAsVSDX(strDataFilePath As String)
RemoveVBACode
Application.AlertResponse = IDOK
' Next line fails at runtime (issue 2), the same occurs when using Save
ThisDocument.SaveAsEx strDataFilePath, visSaveAsWS + visSaveAsListInMRU
Application.AlertResponse = 0
End Sub
The code that starts the execution of the Macro is the following event:
' This procedure runs when a Visio document is
' created. I.e., when the template (.vstm) is opened.
Private Sub Document_DocumentCreated(ByVal Doc As IVDocument)
' ...
SaveAsVSDX (strDataFilePath)
' ...
End Sub
I finally found a way to achieve what I wanted : generate a macro-less visio drawing, from a macro-enabled drawing.
What IS NOT possible from my understanding :
Have vba code that removes modules / class modules that is launched through an event such as Document_DocumentCreated. The best I could achieve is to remove the content of ThisDocument vba visio object, but all code in modules / class modules were not removable (note that if the macro is called manually, everything works like a charm, but this was not what I wanted to achieve).
Saving a a drawing instanciated from a vstm template as a macro-less vsdx file.
What IS possible (and is my solution to the third part of the question) :
Instead of loading datasource into the drawing instanciated from the vstm file, have the macro do the following:
select all shapes that appear on the page of the drawing that has been instanciated
group them
copy them
create a new Document
setup the page of the new document (orientation, size, disable snapping and gluing)
paste the group into the first page of the newly created document
center the drawing on the new document
Then load the datasource into the newly created document and link data to existing Shapes
Finaly you can save the new document as vsdx
With lots of shapes (more than 400) this takes some time (around 10 seconds), but it works.
Here is the code of the class module that generates the document.
Option Explicit
'Declare private variables accessible only from within this class
Private m_document As Document
Private m_dataSource As DataSourceFile
Private m_longDataRecordsetID As Long
Public Function Document() As Document
Set Document = m_document
End Function
Private Sub CreateDocument()
' I consider here that the active window is displaying the diagram to
' be copied
ActiveWindow.ViewFit = visFitPage
ActiveWindow.SelectAll
Dim activeGroup As Shape
Set activeGroup = ActiveWindow.Selection.Group
activeGroup.Copy
ActiveWindow.DeselectAll
Set m_document = Application.Documents.Add("")
' I need an A4 document
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageWidth).FormulaU = "297 mm"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPage, visPageHeight).FormulaU = "210 mm"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPageOrientation).FormulaForceU = "2"
m_document.Pages(1).PageSheet.CellsSRC(visSectionObject, visRowPrintProperties, visPrintPropertiesPaperKind).FormulaForceU = "9"
m_document.SnapEnabled = False
m_document.GlueEnabled = False
m_document.Pages(1).Paste
m_document.Pages(1).CenterDrawing
End Sub
Private Sub LoadDataSource()
Dim strConnection As String
Dim strCommand As String
Dim vsoDataRecordset As Visio.DataRecordset
strConnection = "Provider=Microsoft.ACE.OLEDB.12.0;" _
& "User ID=Admin;" _
& "Data Source=" + m_dataSource.DataSourcePath + ";" _
& "Mode=Read;" _
& "Extended Properties=""HDR=YES;IMEX=1;MaxScanRows=0;Excel 12.0;"";" _
& "Jet OLEDB:Engine Type=34;"
strCommand = "SELECT * FROM [Data$]"
Set vsoDataRecordset = m_document.DataRecordsets.Add(strConnection, strCommand, 0, "Data")
m_longDataRecordsetID = vsoDataRecordset.ID
End Sub
Private Function CheckDataSourceCompatibility() As Boolean
Dim visRecordsets As Visio.DataRecordsets
Dim varRowData As Variant
Set visRecordsets = m_document.DataRecordsets
varRowData = visRecordsets(1).GetRowData(1)
If varRowData(3) = "0.6" Then
CheckDataSourceCompatibility = True
Else
MsgBox "Using invalid DataSource version, aborting. You shoud use data format version 0.6."
CheckDataSourceCompatibility = False
End If
End Function
Private Sub LinkDataToShapes()
Application.ActiveWindow.SelectAll
Dim ColumnNames(1) As String
Dim FieldTypes(1) As Long
Dim FieldNames(1) As String
Dim IDsofLinkedShapes() As Long
ColumnNames(0) = "ID"
FieldTypes(0) = Visio.VisAutoLinkFieldTypes.visAutoLinkCustPropsLabel
FieldNames(0) = "ID"
Application.ActiveWindow.Selection.AutomaticLink m_longDataRecordsetID, ColumnNames, FieldTypes, FieldNames, 10, IDsofLinkedShapes
Application.ActiveWindow.DeselectAll
End Sub
Public Function GenerateFrom(dataSource As DataSourceFile) As Boolean
Set m_dataSource = dataSource
'Store diagram services
Dim DiagramServices As Integer
DiagramServices = ActiveDocument.DiagramServicesEnabled
ActiveDocument.DiagramServicesEnabled = visServiceVersion140
' Create a new document that contains only shapes
CreateDocument
' Load datasource
LoadDataSource
' Check datasource conformity
If CheckDataSourceCompatibility Then
' Link data recordset to Visio shapes
LinkDataToShapes
GenerateFrom = True
Else
GenerateFrom = False
End If
'Restore diagram services
ActiveDocument.DiagramServicesEnabled = DiagramServices
End Function
Hope this helps.

VBA: Code not running after ToggleFormsDesign

I have the following code in VBA (MS Word), that is meant to run after I click in a button, named cmdFormPreencher inserted in my Document:
Private Sub cmdFormPreencher_Click()
'
If ActiveDocument.FormsDesign = False Then
ActiveDocument.ToggleFormsDesign
End If
'
ThisDocument.cmdFormPreencher.Select
ThisDocument.cmdFormPreencher.Delete
ActiveDocument.ToggleFormsDesign
'
UserForm2.Show
End Sub
The purpose of the code above is to delete that button inserted in my document.
But when I run the code only the button is selected. When I tried to figure out what is happening by debugging, it showed me the code runs until ActiveDocument.ToggleFormsDesign and not running the code remaining
Is this a bug of VBA, or am I doing something wrong? If so, how can I get around this problem?
Thanks!
Note: The ActiveX button is not in Header and Footer. The Text Wrap is set to In Front of Text
Edit:
When I try to run a macro, activating FormDesign, Selecting the ActiveX button and then deleting, I get this code:
Sub Macro1()
'
' Macro1 Macro
'
'
ActiveDocument.ToggleFormsDesign
ActiveDocument.Shapes("Control 52").Select
Selection.ShapeRange.Delete
ActiveDocument.ToggleFormsDesign
End Sub
But when I run this code nothing happens...
This is by design. When an Office application is in Design Mode code should not run on an ActiveX object that's part of the document.
I take it this is an ActiveX button and in that case, it's a member of the InlineShapes or Shapes collection - Word handles it like a graphic object. It should be enough to delete the graphical representation, which you can do by changing it to display as an icon instead of a button.
For example, for an InlineShape:
Sub DeleteActiveX()
Dim ils As word.InlineShape
Set ils = ActiveDocument.InlineShapes(1)
ils.OLEFormat.DisplayAsIcon = True
ils.Delete
End Sub
You just have to figure out how to identify the InlineShape or Shape. You could bookmark an InlineShape; a Shape has a Name property.
EDIT: Since according to subsequent information provided in Comments you have a Shape object, rather than an InlineShape, the following approach should work:
Dim shp As word.Shape
Set shp = ActiveDocument.Shapes("Shape Name") 'Index value can also be used
shp.Delete
Note that Word will automatically assign something to the Shape.Name property, but in the case of ActiveX controls these names can change for apparently no reason. So if you identify a control using its name instead of the index value it's much better to assign a name yourself, which Word will not change "on a whim".
Activate Design Mode.
Click on the control to select it
Go to the VB Editor window
Ctrl+G to put the focus in the "Immediate Window"
Type the following (substituting the name you want), then press Enter to execute:
Selection.ShapeRange(1).Name = "Name to assign"
Use this Name in the code above