I'm following up to two questions (Here & Here) that were asked regarding this issue of using VBA to grab a hyperlink from Excel and insert it into PowerPoint.
Below is the code I have - I've tried tweaking with it but I can't get it to place the hyperlink into the cell and display text as it never gets past this point:
.Address = getAddress
The code breaks with this error message: "Run-time error '438': Object doesn't support this property or method."
I apologize if this is a rehash. Any help would be appreciated.
Option Explicit
Sub PPTableMacro()
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim strPresPath As String
Dim strExcelFilePath As String
Dim getAddress As Hyperlink
strPresPath = "C:\Somewhere...\Presentation.pptm"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 4
oPPTFile.Slides(SlideNum).Select
Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("Table 1")
Sheets("Sheet1").Activate
Set getAddress = Sheet1.Range("F1").Hyperlinks(1)
oPPTShape.Table.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(1, 1)
oPPTShape.Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(1, 2)
oPPTShape.Table.Cell(3, 2).Shape.TextFrame.TextRange.Text = Cells(1, 3)
oPPTShape.Table.Cell(4, 2).Shape.TextFrame.TextRange.Text = Cells(1, 4)
oPPTShape.Table.Cell(5, 2).Shape.TextFrame.TextRange.Text = Cells(1, 5)
With oPPTShape.Table.Cell(6, 2).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.Address = getAddress.Address
.TextToDisplay = "Link"
End With
Set oPPTShape = Nothing
Set oPPTFile = Nothing
Set oPPTApp = Nothing
End Sub
Edit: So I've been searching the web for anyone else who's come across this issue but so far I haven't had any luck. There's nothing else on stack overflow I could find to help, nor did I find anything on the Microsoft Developer site for Office 2010. I looked at the examples provided there for the Hyperlink.TextToDisplay ="..." attribute and it looks like I'm doing everything right. I hope its not a cheap shot to edit my question in hopes someone will see it, but I'm not sure what else to do on this one.
Related
Fist of all, I'm not good with VBA, and to be honest I don't know how to go about on this problem.
The Situation
I have a database as shown below with multiple entries (currently only 2, but there will be more as soon as the students will progress with there work). I want to be able to filter the database and then depending on the selection put the information in a PowerPoint Slide.
I created (with a lot of youtube videos) a script that will copy the relevant information from one line onto a PowerPoint presentation into the defined fields.
Problem
I have absolutely no idea how to loop that code in order to bring only the filtered Information onto the PowerPoint. Can someone guide me on how to go about it?
Sub XLS_to_PPT()
Dim pptPres As Presentation
Dim strPfad As String
Dim strPOTX As String
Dim pptApp As Object
strPfad = "C:XXX"
strPOTX = "PPT_Template.pptx"
Set pptApp = New PowerPoint.Application
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
pptPres.Slides(1).Duplicate
pptPres.Slides(1).Select
pptPres.Slides(1).Shapes("Header").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 5).Value
pptPres.Slides(1).Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 9).Value
pptPres.Slides(1).Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(5, 10).Value
pptPres.SaveAs strPfad & ("New_Request")
pptPres.Close
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
The plan is to create a new slide for each visible row in the table, i presume.
so you could loop through the table like this:
For Each tableRow In Sheets("NameOfYourSheet").ListObjects("NameOfYourTable").DataBodyRange.SpecialCells(xlCellTypeVisible).Rows
set newSlide = pptPres.Slides(1).Duplicate
newSlide.Shapes("Header").TextFrame.TextRange.Characters.Text = tableRow.Columns(5).Value
newSlide.Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = tableRow.Columns(9).Value
newSlide.Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = tableRow.Columns(10).Value
Next tableRow
Basically we go through each row in the table, duplicate slide(1), use that new slide object to populate the shapes inside by the given column numbers.
SpecialCells(xlCellTypeVisible) takes care of ignoring the filtered out rows.
try looking into this answer.
There it is described how to loop through a filtered list. There is information there how to get the address of the cell in you are looping through and so on
edit: after I got reprimanded I am posting full solution. Hope it works.
edit2: now made it so it works for arbitrary number of slides
Sub XLS_to_PPT()
Dim pptPres As Presentation
Dim strPfad As String
Dim strPOTX As String
Dim pptApp As Object
strPfad = "C:XXX"
strPOTX = "PPT_Template.pptx"
Set pptApp = New PowerPoint.Application
pptVorlage = strPfad & strPOTX
pptApp.Presentations.Open Filename:=pptVorlage, untitled:=msoTrue
Set pptPres = pptApp.ActivePresentation
'below if set the range to 500 but you may want to increase /decrease that number depending on how many entries you expecty
Set rng = Range("A5:A500")
For Each cl In rng.SpecialCells(xlCellTypeVisible)
set mynewslide=pptPres.Slides(1).Duplicate
' I do not think you need below line
'pptPres.Slides(1).Select
mynewslide.Shapes("Header").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 5).Value
mynewslide.Shapes("ClientChanlenge").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 9).Value
mynewslide.Shapes("HowWeHelped").TextFrame.TextRange.Characters.Text = Worksheets("PPT_Creation").Cells(cl.row, 10).Value
Next cl
pptPres.SaveAs strPfad & ("New_Request")
pptPres.Close
Set pptPres = Nothing
Set pptApp = Nothing
End Sub
I am trying to retrieve the links in which a PowerPoint is connected to using VBA in Excel. I receive two different errors from the two different approaches in which I will attach below, both stemming from calling the Slide and Shape objects of PowerPoint. The first macro results in an "Object required" error starting with the first line of the For Loop.
Sub Macro1()
'Opening up the PowerPoint to retrieve the links
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim i As Integer
Dim j As Long
Dim k As Long
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
k = k + 1
Next k
j = j + 1
Next j
End Sub
The second macro results in a "Compile error" starting with the "Set PPTSlides = CreateObject("PowerPoint.Slides")."
Sub Macro2()
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim PPTSlides As Object
Dim PPTShapes As Object
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
For Each PPTSlides In PPT.ActivePresentation.Slides
For Each PPTShapes In PPT.ActivePresentation.Shapes
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
Next PPTShapes
Next PPTSlides
End Sub
I have not used VBA in Excel to work with PowerPoint before, so this is a new learning curve for me. Because of these errors, I have not been able to check my For Loop for errors as well. Any help is appreciated on these issues. Thanks in advance!
Fortunately, that is only a minor issue: A wrong index is used:
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If you look closely, then you need to use j instead of i in the last row.
And for the second code listing, there you can just omit the lines
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
Because down below the first variable will be set from ActivePresentation.Slides.
As you are using the for each loop it also make sense to rename these two variables from plural to singular, i.e. PPTSlide instead of PPTSlides.
Please note as well that For Each PPTShapes In PPT.ActivePresentation.Shapes does not work. You need to get the Shapes from For Each PPTShape in PPTSlide.Shapes.
All the best
I am in the process of creating diagrams for multiple sites in our enterprise as part of an effort to implement a new technology. I have been gathering the information In an Excel document and from this document I have been able to update various Word documents and Excel documents using VBA, a picture of portion of my spreadsheet along with a sample of the Visio template and desired end state can be found below.
After searching through multiple websites, I was able to come up with the following code that will open the Visio Template, but I can't seem to get it to update the values as expected. As far as I can tell, I seem to be going through the various shapes, as I mentioned, the values are not updating as expected.
Thanks in advance for your help and advice.
Sub UpdateVisioTemplate()
Dim vDocs As Visio.Documents 'Documents collection of instance.
Dim vsoDoc As Visio.Document 'Document to work in
Dim vsoPage As Visio.Page 'Page to work in.
Dim vsoPages As Visio.Pages 'Pages collection of document.
Dim vApp As Visio.Application 'Declare an Instance of Visio.
Dim vsoShape As Visio.Shape 'Instance of master on page.
Dim vsoCharacters As Visio.Characters
Dim DiagramServices As Integer
Dim VarRow As Long
Dim FileName, DocName, VarName, VarValue, SiteID, SiteType, Wave, SiteName As String
'Dim vContent As Word.Range
With ActiveSheet
DocName = .Cells(1, 6).Value
SiteType = .Cells(1, 25).Value
SiteID = .Cells(20, 5).Value
SiteName = .Cells(21, 5).Value
On Error Resume Next 'Check if Visio is already running
'Set vApp = CreateObject("Visio.Application")
Set vApp = GetObject(, "Visio.Application")
If Err.Number <> 0 Then 'not equal to 0
Err.Clear
Set vApp = CreateObject("Visio.Application")
End If
vApp.Visible = True
Set vDocs = vApp.Documents.OpenEx(DocName, &H1)
'(DocName)
'Set vDocs = vApp.Documents.Open(DocName)
Set vsoPages = vApp.ActiveDocument.Pages
DiagramServices = vApp.ActiveDocument.DiagramServicesEnabled
vApp.ActiveDocument.DiagramServicesEnabled = visServiceVersion140
LastRow = .Range("A999").End(xlUp).Row
For Each vsoPage In vsoPages
For VarRow = 2 To LastRow 'from Row 2 to the last row
For Each vsoShape In vsoPage.Shapes
VarName = .Cells(VarRow, 1).Value 'VariableName
VarValue = .Cells(VarRow, 2).Value 'VariableValue
If Len(VarValue) = 0 Then 'If the variable value is blank, keep the variable in place
VarValue = .Cells(VarRow, 1).Value
End If
Set vsoCharacters = vsoShape.Charaters
vsoCharacters.Text = Replace(vsoCharacters.Text, VarName, VarValue) 'Find and replace the variables with the appropriate value
Next vsoShape
Next VarRow
Next vsoPage
End With 'Active Sheet
vDoc.SaveAs (SiteID & ".vsd")
End Sub
Sample of Excel Data
Visio Diagram Template
Visio Diagram Final
One thing I noticed was on the line Set vsoCharacters = vsoShape.Charaters - the latter should be vsoShape.Characters instead of Charaters - since this was essentially set to blank (nothing), then there was nothing to 'replace' and nothing changed.
The reason this did not appear is because the 'on error resume next' statement was made earlier which suppresses error messages and simply continues.
Is there any way to Style a table with VBScript? All the solutions I'm finding online are for VBA.
for example, I tried the solution here Excel Macro - Select all cells with data and format as table with the following code
Set objExcel = CreateObject("Excel.Application")
Dim tbl
Set tbl = objWorkbook.ListObjects.Add(xlSrcRange, objWorkbook.Sheets("101").Range("$A$1:$C$26"), , xlYes)
tbl.TableStyle = "TableStyleLight1"
but I get this error
Microsoft VBScript runtime error: Object doesn't support this property or method: 'objWorkbook.ListObjects'
(If you have a solution for this in exceljs that would be even better)
I found something you may be able to use. It is from Using Styles to Dress Up Your Worksheets in Excel 2007. What I did was converted it from VBA to VBScript, which really wasn't that hard.
Sub ListStyles()
Dim objStyle
Dim objCellRange
Dim lngCount
Dim objSheet
Set objSheet = ThisWorkbook.Worksheets("Config - Styles")
With objSheet
lngCount = objSheet.UsedRange.Rows.Count + 1
For Each objStyle In ThisWorkbook.Styles
On Error Resume Next
Set objCellRange = Nothing
Set objCellRange = Intersect(objSheet.UsedRange, objSheet.Range("A:A")).Find(objStyle.Name, _
objSheet.Range("A1"), xlValues, xlWhole, , , False)
If objCellRange Is Nothing Then
lngCount = lngCount + 1
.Cells(lngCount, 1).Style = objStyle.Name
.Cells(lngCount, 1).Value = objStyle.NameLocal
.Cells(lngCount, 2).Style = objStyle.Name
End If
Next
End With
End Sub
To set this up, double click on the Sheet1 tab and rename it "Config - Styles". Add the code above, then run the script. What you end up with is this:
I am currently using this code to pull out the 5-day forecast along with some decent pictures for an assignment. I had built it off of a video I found but I'm having trouble with why the delshape process isn't removing the shapes as it should.
If anyone has any recommendations I would appreciate it as well as trying to explain what is wrong if possible. I am trying to learn as much as I can with VBA as I am a brand new user.
Sub CurrentFiveDayForecast()
Dim WS As Worksheet: Set WS = ActiveSheet
>WS.Range("thedate").Value = ""
WS.Range("hightemp").Value = ""
WS.Range("lowtemp").Value = ""
Dim delshape As Shape
For Each delshape In WS.Shapes
If delshape.Type = msoAutoShape Then delshape.Delete
Next delshape
Dim Req As New XMLHTTP
Req.Open "GET", "http://api.worldweatheronline.com/free/v1/weather.ashx?q=Hong+Kong&format=xml&num_of_days=5&key=APIKEY", False
Req.send
Dim Resp As New DomDocument
Resp.LoadXML Req.responseText
Dim Weather As IXMLDOMNode
Dim i As Integer
Dim wShape As Shape
Dim thiscell As Range
For Each Weather In Resp.getElementsByTagName("weather")
i = i + 1
WS.Range("thedate").Cells(1, i).Value = Weather.SelectNodes("date")(0).Text
WS.Range("hightemp").Cells(1, i).Value = Weather.SelectNodes("tempMaxF")(0).Text
WS.Range("lowtemp").Cells(1, i).Value = Weather.SelectNodes("tempMinF")(0).Text
Set thiscell = WS.Range("weatherpictures").Cells(1, i)
Set wShape = WS.Shapes.AddPicture(Weather.SelectNodes("weatherIconUrl")(0).Text, msoFalse, msoCTrue, thiscell.Left, thiscell.Top, thiscell.Width, thiscell.Height)
Next Weather
End Sub
Shapes.AddPicture Creates a picture from an existing file. It returns a Shape object that represents the new picture. You can read more about it in Shapes.AddPicture Method
Change the line
If delshape.Type = msoAutoShape Then delshape.Delete
to
If delshape.Type = msoPicture Then delshape.Delete