Have been working on this problem for days and cant figure it out. On line with ExecuteMso I get following error message Method "ExecuteMso" of object "_CommandBars" failed. I'm having difficulty to understand or find why.
Searched web for days.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, chart in word
Sub CreateChart(Wapp As Object)
Dim FomtCh As Excel.ChartObject
Dim InlineShCount As Long
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
'Copy from excel chart to word chart
FomtCh.Chart.ChartArea.Copy
'Counts number of shapes in word document
InlineShCount = ActiveDocument.InlineShapes.Count
'Paste without linking to excel chart and embeding copy in word file
Word.Application.CommandBars.ExecuteMso ("PasteExcelChartSourceFormatting")
Do '<~~ wait completion of paste operation
DoEvents
Loop Until ActiveDocument.InlineShapes.Count > InlineShCount
End Sub
Not all of the Ribbon commands exist in the legacy CommandBars collection.
To get a full listing of the available commands create a blank document in Word and run the code below (from Word).
Sub ListCommands()
Dim cbar As CommandBar
Dim cbarCtrl As CommandBarControl
For Each cbar In Application.CommandBars
For Each cbarCtrl In cbar.Controls
Selection.TypeText cbarCtrl.Caption & vbCr
Next cbarCtrl
Next cbar
End Sub
Related
I have a weekly presentation that I'm trying to automate. Each week I delete all of the previous weeks contents and paste in the new data using a macro in excel. However I cannot figure out how to delete all of the previous contents. Note: I do not want to delete the slides, just the pictures that are on the slides.
Edited: Below is the code I use in excel to paste in the new data each week. This code is for a single slide. Is it possible to add code to delete the previous weeks data before pasting in the new data?
Sub PasteAltSummaryToDeck()
'PURPOSE: Copy alt summary page and paste into weekly deck'
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
'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 Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
MySlideArray = Array(11)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet2.Range("F5:AS60"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
'Record the date & time of procedure execution
Range("ExportAltSumToPPT").Value = Format(Now(), "mm/dd/yy") & " - " &
Format(TimeValue(Now), "hh:mm AM/PM")
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"
End Sub
For deleting the content of slides via Excel, you can utilize the following code:
Option Explicit
Sub remove_previous_shapes_in_PPT()
Dim sl As PowerPoint.Slide, sl_cnt As Long, pr As Object, pr_name As String, ppt As Object
Dim i As Long, j As Long
Set ppt = GetObject(, "PowerPoint.Application")
Set pr = ppt.Presentations(1)
sl_cnt = pr.Slides.Count
For j = sl_cnt To 2 Step -1
Set sl = pr.Slides(j)
For i = sl.Shapes.Count To 1 Step -1
sl.Shapes(i).Delete
Next i
Next j
End Sub
This utilizes looping through the count of slides and a nested loop of going through the shapes within the slide. In my above code, I leave slide 1 alone (you can just change the loop for j to go to 1, not 2, if you want the first slide content removed).
Note the items labeled as Object versus those that are bound to PPT references. I didn't go through the steps of utilizing your particular PPT, as I typically deal with GetObject() for the active PPT window, having only 1 presentation open.
try this;
Sub deletepics()
'variables
Dim slide As slide
Dim y As Long
'loop through slides backwards and with the slides shapes if they are pictures then delete
For Each slide In ActivePresentation.Slides
For y = slide.Shapes.Count To 1 Step -1
With slide.Shapes(y)
If .Type = msoPicture Then
.Delete
End If
End With
Next
Next
End Sub
EDIT:If you want to delete images on only slides 14 to 2 you can do this. Ignore my comments they were wrong. But the below code will work for you.
Sub deletepics()
'variables
Dim slide As slide
Dim y As Long
'loop through slides backwards and with the slides shapes if they are pictures then delete
For y = ActivePresentation.Slides.Count To 2 Step -1
If y <> 14 Then
Set sldTemp = ActivePresentation.Slides(y)
For lngCount = sldTemp.Shapes.Count To 1 Step -1
With sldTemp.Shapes(lngCount)
If .Type = msoPicture Then
.Delete
End If
End With
Next
End If
Next
End Sub
I am trying to copy multiple Excel charts and paste them to a Word document, on separate pages, as the data type linked OLEObject but I am getting a run-time error.
Run-time error '5343':
Word cannot obtain the data for the
{00020832-0000-0000-C000-000000000046 link.
This is code that I've used in the past but literally, the only thing I changed in this code is to add an outer loop that processes the worksheets in the active workbook. Since adding that outer loop it no longer works, which is a little strange to me because I don't really see what is different.
It works for the first sheet (the currently active one), but fails when the loop moves to the next sheet. It does not matter whether the chart is pasted with or without a link.
Here is the full code for your reference:
Sub ExportingToWord_MultipleCharts()
'Declare Word Variables
Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
Dim SecCnt As Integer
'Declare Excel Variables
Dim ChrtObj As ChartObject
Dim Rng As Range
'Create a new instance of Word
Set WrdApp = New Word.Application
WrdApp.Visible = True
WrdApp.Activate
'Create a new word document
Set WrdDoc = WrdApp.Documents.Add
'Loop through each worksheet in the active workbook.
For Each WrkSht In ActiveWorkbook.Worksheets
'Loop through the charts on the active sheet
For Each ChrtObj In WrkSht.ChartObjects
'Copy the chart
ChrtObj.Chart.ChartArea.Copy
'Paste the Chart in the Word Document
With WrdApp.Selection
.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine
End With
'Add a new page to the document.
WrdApp.ActiveDocument.Sections.Add
'Go to the newly created page.
WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
Next ChrtObj
Next WrkSht
End Sub
It returns the error on the following line:
'Paste the Chart in the Word Document
With WrdApp.Selection
.PasteSpecial Link:=True, DataType:=wdPasteOLEObject, Placement:=wdInLine
End With
I found a workaround, but it still doesn't explain why the error is happening. What I had to do is activate the actual worksheet in the loop.
'***ACTIVATE THE WORKSHEET IN ORDER TO REMOVE THE ERROR***
WrkSht.Activate
For whatever reason, this seemed to remove the error from popping up. However, I find this strange because when I've exported charts from PowerPoint I am not required to activate the worksheet in order to copy it. Here is the code with the adjustments, I've called out the section I added.
Sub ExportingToWord_MultipleCharts()
'Declare Word Variables
Dim WrdApp As Word.Application
Dim WrdDoc As Word.Document
Dim SecCnt As Integer
'Declare Excel Variables
Dim ChrtObj As ChartObject
Dim Rng As Range
'Create a new instance of Word
Set WrdApp = New Word.Application
WrdApp.Visible = True
WrdApp.Activate
'Create a new word document
Set WrdDoc = WrdApp.Documents.Add
'Loop through each worksheet in the active workbook.
For Each WrkSht In ActiveWorkbook.Worksheets
'***ACTIVATE THE WORKSHEET IN ORDER TO REMOVE THE ERROR***
WrkSht.Activate
'Loop through the charts on the active sheet
For Each ChrtObj In WrkSht.ChartObjects
'Copy the chart
ChrtObj.Chart.ChartArea.Copy
'Paste the Chart in the Word Document
With WrdApp.Selection
.PasteSpecial Link:=False, DataType:=wdPasteOLEObject, Placement:=wdInLine
End With
'Add a new page to the document.
WrdApp.ActiveDocument.Sections.Add
'Go to the newly created page.
WrdApp.Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext
Next ChrtObj
Next WrkSht
End Sub
I am trying to create a loop to go through each picture in my slideshow and paste each picture's corresponding hyperlink in an excel document as a list
I would also like the loop to loop through the pictures in order from left to right (ie in this screenshot attached, select the upper left image (Target's ad), then the next image to the right (Rite-Aid's ad), then CVS's, then Walgreens', and then go to the next row which starts with Benadryl for Walgreens and repeat that process)
Here is the code I have thus far
'Code for getting hyperlinks of images in Powerpoint- and pasting into excel
Sub getLinks()
Dim pptSlide As Slide
Dim pptShape As Shape
Dim pptHLstring As String
Dim xlApp As Object
Dim xlWorkBook As Object
Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlWorkBook = xlApp.Workbooks.Open("C:\Weekly Ad Recaps\Non-FSI\lookuptable Non FSI.xlsm")
i = 0
For Each pptSlide In ActivePresentation.Slides
For Each pptShape In pptSlide.Shapes
i = i + 1
If pptShape.Type = Shape Then
On Error Resume Next
xlWorkBook.Sheets("PPT H-Link Index").Range(Cells(i, 1)) = pptShape.Hyperlink.Address
On Error GoTo 0
End If
Next pptShape
DoEvents
Next pptSlide
End Sub
The slideshow has a dozen slides all formatted the exact same way.
A macro to streamline this process would cut down on my weekly workload significantly
Thanks in advance to anyone who can help!!
so far I have tried the Chart.Refresh and Chart.Update and also ChartData.UpdateLinks and neither work.
My question is similar to this one only that this code did not work for my ppt
How to update excel embedded charts in powerpoint?
If i could Record Macro like in Excel the steps would be:
Select Chart
Chart Tools > Refresh Data
This is code is what I have managed to write but it fails at "gChart.Application.RefreshData":
Sub refreshchart()
Dim ppApp As PowerPoint.Application, sld As Slide
Dim s As PowerPoint.Shape
Dim gChart As Chart, i As Integer
ppApp.Visible = True
i = 3
Set sld = ActivePresentation.Slides(i)
sld.Select
For Each s In ActivePresentation.Slides(i)
If s.Type = msoEmbeddedOLEObject Then
Set gChart = s.OLEFormat.Object
With gChart.Application
gChart.Application.Refresh
Set gChart = Nothing
End If
Next s
End Sub
The Integer i is included to go from i=1 To 73, but as a test i am using Slide 3. Not all Slides have Charts but most of them have 4 Charts (65 out of 73).
I changed the code a little bit and with this little change, the refresh of the charts works again automatically.
Many times, if you share your excel ppt combo the links break and after restoring them the automated chart refresh doesn`t work.
With the downstanding macro the automated refresh will work again:
Sub REFRESH()
Dim pptChart As Chart
Dim pptChartData As ChartData
Dim pptWorkbook As Object
Dim sld As Slide
Dim shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Set pptChart = shp.Chart
Set pptChartData = pptChart.ChartData
pptChartData.Activate
shp.Chart.REFRESH
On Error Resume Next
On Error GoTo 0
End If
Next
Next
Set pptWorkbook = Nothing
Set pptChartData = Nothing
Set pptChart = Nothing
End Sub
The code below is in a macro in the Excel workbook which also contains the source data. Not sure if the code would be the same running it from PowerPoint. I simply open my Excel Workbook and then have it update the PowerPoint for me.
I have been looking forever to find an answer to this and finally managed to get it to work with a ton of reading and trial-and-error. My problem was that I have a PowerPoint with a lot of graphs that were created with CTRL+C and CTRL+V, so none of them are linked.
This is how I got it to work:
Dim myPresentation As PowerPoint.Presentation
Dim sld As PowerPoint.Slide
Dim shp As PowerPoint.Shape
Dim myChart As PowerPoint.Chart
For Each sld In myPresentation.Slides
For Each shp In sld.Shapes
If shp.HasChart Then
Set myChart = shp.Chart
myChart.ChartData.Activate
myChart.Refresh
End If
Next
Next
I don't know if there is unnecessary code in there but I am just happy that I finally got it to work so I'm not touching it anymore.
This code worked. But it works only if both files are open (the excel if its only one): The Power Point and the Excel with the data. It actually Refreshes all charts one by one.
Sub updatelinks()
Dim sld As Slide, shp As Shape
For Each sld In ActivePresentation.Slides
For Each shp In sld.Shapes
On Error Resume Next
shp.LinkFormat.Update
Next
Next
MsgBox ("Graficos actualizados con éxito")
End Sub
So, If the Excel is on a shared location, the code wont work because it takes too much time to retrieve the data. Im still looking for a way to do this. Thanks!
This may help, It opens and closes the embedded Excel object
For Each s In ActivePresentation.Slides(i)
If s.Type = msoEmbeddedOLEObject Then
s.Select 'select the object
s.OLEFormat.Activate 'Activate it (like 2x click))
ActiveWindow.Selection.Unselect 'To let it close
ActiveWindow.View.GotoSlide s.Slideindex 'make current slide active
End If
Next s
I have a batch of Word documents that have embedded Excel worksheets. Users have been entering data in the Excel sheet by double clicking the image of the sheet and opening an embedded Excel object. I need to get to the user entered data.
Below is WORD VBA with a reference to the Microsoft Excel 15 library. (The Word and Excel object where created under Office 2010.)
I can find the OLE object but I can't do anything with it. In the code below I tried to assign the object to a Worksheet object but I get a type mismatch error.
To complicate things further the embedded Excel sheet has macros. During some passes at the problem an Excel window opens with a prompt to enable macros security prompt. I can most likely temporarily disable macro checking to get past this.
All I need to do is get at the data in the worksheet to copy it elsewhere one time. I would be happy with just copying the worksheet to an external file if that is even possible.
I have Office 2010 and 2013, and Visual Studio 2010 Pro and 2014 Express at hand.
How can I get to the embedded worksheet data?
Sub x()
Dim oWS As Excel.Worksheet
Dim oIShape As InlineShape
For Each oIShape In ActiveDocument.InlineShapes
If Not oIShape.OLEFormat Is Nothing Then
If InStr(1, oIShape.OLEFormat.ProgID, "Excel") Then
oIShape.OLEFormat.ActivateAs (oIShape.OLEFormat.ClassType) 'Excel.Sheet.8
Set oWS = oIShape '** type mismatch
Debug.Print oWS.Cells(1, 1)
End If
End If
Next oIShape
End Sub
I used the suggested to get started on a previous try:
Modify embedded Excel workbook in Word document via VBA
Had some problems with proper references and the code bungling up the document.
Below is another pass that works OK but has some issues and code I don't understand.
1) I don't want to use Edit mode but other modes didn't work
2) The immaculate reference Set xlApp = GetObject(, "Excel.Application") is strange. Some kind of undocumented feature?
Sub TestMacro2()
Dim lNumShapes As Long
Dim lShapeCnt As Long
Dim xlApp As Object
Dim wrdActDoc As Document
Dim iRow As Integer
Dim iCol As Integer
Set wrdActDoc = ActiveDocument
For lShapeCnt = 1 To wrdActDoc.InlineShapes.Count
If wrdActDoc.InlineShapes(lShapeCnt).Type = wdInlineShapeEmbeddedOLEObject Then
If wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.ProgID = "Excel.Sheet.8" Then
wrdActDoc.InlineShapes(lShapeCnt).OLEFormat.Edit
Set xlApp = GetObject(, "Excel.Application")
With xlApp.Workbooks(1).Worksheets(2) ' can be multiple sheets, #2 is needed in this case
For iCol = 3 To .UsedRange.Columns.Count
If .Cells(1, iCol) = "" Then Exit For
For iRow = 1 To .UsedRange.Rows.Count
Debug.Print .Cells(iRow, iCol) & "; ";
Next iRow
Debug.Print 'line feed
Next iCol
End With
xlApp.Workbooks(1).Close
xlApp.Quit
Set xlApp = Nothing
End If
End If
Next lShapeCnt
End Sub
Code works well enough to accomplish my extraction task - thanks!