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
Related
I want to form a table at the word documents after inserting the exceltable as paragraphs.
This is the code that I used.
Sub MSWord()
Dim wApp As Word.Application
Dim wDoc As Word.Document
Dim wTable As Word.Table
Dim wb As Workbook, wsh As Worksheet, i As Long
Dim cel As Cell
Set wb = ThisWorkbook
Dim wRange As Range
Set wApp = CreateObject("word.application")
wApp.Visible = True
Set wDoc = wApp.Documents.add
Set tbRange = ThisWorkbook.Worksheets("Terms and conditions-Zero Call").Range("A1:A12")
tbRange.Copy
wDoc.Paragraphs(1).Range.PasteExcelTable False, False, False
wDoc.Range.InsertAfter vbNewLine
wDoc.Paragraphs(25).Range.InlineShapes.AddHorizontalLineStandard
Set tbRange1 = ThisWorkbook.Worksheets("Payoff-Zero Call").Range("A1:F32")
tbRange1.Copy
wDoc.Paragraphs(26).Range.PasteExcelTable False, False, False
intNoofRows = Year(Worksheets("Input").Range("H5")) - Year(Worksheets("Input").Range("G5"))
intNoofColumns = 4
Set wRange = wDoc.Range
wDoc.Tables.add wRange, intNoofRows, intNoofColumns
Set wTable = wDoc.Tables(1)
wTable.Borders.Enable = True
wTable.Cell(1, 1).Range.Text = "j"
wTable.Cell(1, 2).Range.Text = "Optional Redemption Date"
wTable.Cell(1, 3).Range.Text = "Optional Redemption Amount"
wTable.Cell(1, 4).Range.Text = "Optional Redomption Price"
For i = 2 To intNoofRows
wTable.Cell(i, 1).Range.Text = i - 1
wTable.Cell(i, 2).Formula ("=Date(Year('Payoff-Zero Call'!$C$22)+i-1,Month('Payoff-Zero Call'!$C$22),Day('Payoff-Zero Call'!$C$22))")
wTable.Cell(i, 3).Formula ("=Input!$D$5 & Round((1000000*(1+100*Input!$I$5/100)^(i-1)),2)")
wTable.Cell(i, 4).Formula ("=ROUND((1000000*(1+100*Input!$I$5/100)^(i-1)),2)/1000000")
Next i
Just ignore the contents of the table, they just the output of the formula that I entered. ALso, the previous part about the pasteExcelTable you can also ignore it. I just posted it because it might give a better idea on what i really want. So I would want the formed table in the word to be put right after the pasted excel table which refers to ThisWorkbook.Worksheets("Payoff-Zero Call").Range("A1:F32")
The problem is, at the For loop, I keep on getting the error: Application defined or object defined error. Or sometimes Type Mismatch when I try to adjust some trivial details.
Maybe is there my misconception in inserting table after the excel paste paragraph? Because if I just separate the tables code from previous code to only form table in the blank word, there is no problem.
Could you please shed some light for this problem? Thanks in advance
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'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.
I am trying to obtain a reference to a Shape in a Worksheet, corresponding to a ChartObject. I found no certain way of doing this. The only approximation, by trial-and-error and simply tested in a few cases, is assuming that the ZOrder of a ChartObject is the same as the Index of the corresponding Shape:
Function chobj2shape(ByRef cho As ChartObject) As Shape
' It appears that the ZOrder of a ChartObject is the same as the Index of
' the corresponding Shape, which in turn appears to be the same as its ZOrderPosition
Dim zo As Long
Dim ws As Worksheet
Dim shc As Shapes
Dim sh As Shape
zo = cho.ZOrder
Set ws = cho.Parent
Set shc = ws.Shapes
Set sh = shc.Item(zo)
Set chobj2shape = sh
'Set sh = Nothing
End Function
(a slight excess of defined variables is used for debugging purposes).
Is there any more certain way of doing this?
Any identifier used for picking the correct Shape should be unique. The name is not necessarily unique (see https://stackoverflow.com/questions/19153331/duplicated-excel-chart-has-the-same-name-name-as-the-original-instead-of-increm), so it is not guaranteed to work. The Index/ZOrderPosition is just a guess, at least satisfying the requirement of uniqueness.
Edit: see answer by #Andres in Excel VBA: Index = ZOrderPosition in a Shapes collection?. It is clear that the ZOrder of a ChartObject is not equal to the Index of either the ChartObject or the corresponding Shape (and I have verified this).
But it appears that ZOrder is equal to ZOrderPosition of the corresponding Shape. This was verified with dump_chartobjects:
Sub dump_chartobjects()
' Dump information on all ChartObjects in a Worksheet.
Dim coc As ChartObjects
Set coc = ActiveSheet.ChartObjects
Dim cho As ChartObject
Dim ich As Long
For ich = 1 To coc.Count
Dim msg As String
Set cho = coc(ich)
With cho
msg = "ChartObject '" & .name & "'" _
& ", type name: " & TypeName(cho) & ", at: " & .TopLeftCell.Address _
& ", index: " & ich & ", .Index: " & .Index _
& ", ZOrder: " & .ZOrder
'& ", hyperlink: " & .Hyperlink
End With
Debug.Print msg
Dim ish As Long
ish = choidx2shpidx(ich, coc.Parent)
Next ich
End Sub
Function choidx2shpidx(coidx As Long, ws As Worksheet) As Long
Dim cozo As Long
Dim coc As ChartObjects
Dim co As ChartObject
Set coc = ws.ChartObjects
Set co = coc(coidx)
cozo = co.ZOrder
choidx2shpidx = zo2idx_shp(cozo, ws)
Dim con As String, shn As String
Dim sh As Shape
Set sh = ws.Shapes(choidx2shpidx)
con = co.name
shn = sh.name
Dim cox As Double, coy As Double
Dim cow As Double, coh As Double
Dim shx As Double, shy As Double
Dim shw As Double, shh As Double
cox = co.Left
coy = co.top
cow = co.Width
coh = co.Height
shx = sh.Left
shy = sh.top
shw = sh.Width
shh = sh.Height
If ((con <> shn) Or (cox <> shx) Or (coy <> shy) Or (cow <> shw) Or (coh <> shh)) Then
Dim msg As String
msg = "ChartObject: '" & con & "', Shape: '" & shn & "'"
'Debug.Print msg
MsgBox msg
choidx2shpidx = -1
End If
End Function
Function zo2idx_shp(zo As Long, ws As Worksheet) As Long
Dim ish As Long
Dim shc As Shapes
Dim sh As Shape
Set shc = ws.Shapes
For ish = 1 To shc.Count
Set sh = shc(ish)
If (sh.ZOrderPosition = zo) Then
zo2idx_shp = ish
Exit Function
End If
Next ish
zo2idx_shp = -1
End Function
After losing hours in a similar issue, I found a couple of concepts related to referencing shapes in excel, but none satisfies me 100%. For accessing a shape you have 4 pure methods:
Shape.Name : Is FAST, but NOT RELIABLE. The name of the shape could be used to get a reference of a shape but provided you don't have duplicated names. Code: ActiveSheet.Shapes("Shape1")
Shape.ZOrderPosition : Very FAST, but NOT RELIABLE. The ZOrder of the shape could be used to get a reference of a shape, because is the same as the index of the shape in the shapes collection. But provided you don't have group of shapes that breaks previous rule (See: https://stackoverflow.com/a/19163848/2843348). Code: ActiveSheet.Shapes(ZOrderFromOneShape)
Set shpRef=Shape: FAST, RELIABLE, but NOT PERSISTENT. I try to use this always I can, specially when I create a new shape. Moreover, if I have to iterate on the new shapes later one I try to keep the object reference inside a collection. However not Persistent, that means if you stop and run you VBA code again to will loose all the references and collection. Code: Set shp = NewShape, or you can add it to a collection: coll.add NewShape for loop it later on.
Shape.ID : RELIABLE, PERSISTENT, but not directly supported! The ID of the shape is very reliable (don't change and cannot be duplicates IDs in a Sheet). However, there is no direct VBA function to get a shape back knowing its ID. The only way is to loop thorough all shapes until the ID match the ID you was looking for, but this can be very SLOW!.
Code:
Function FindShapeByID(ws as excel.worksheet, ID as long) as Excel.Shape
dim i as long
set FindShapeByID = nothing 'Not found...
for i = 1 to ws.shapes.count
if ws.shapes(i).ID = ID then
set FindShapeByID = ws.shapes(i) 'Return the shape object
exit function
end if
next i
End Function
Note 1: If you want to access this function several times, you can improve it by using a cache of Shape IDs. That way you will make the loop only one time.
Note 2: If you move a shape from one sheet to other, the ID of the shape will change!
By mixing and using above knowledge, I have concluded in two main approaches:
FIRST APPROACH
FASTEST BUT VOLATILE: (same as point#3) Try to keep the reference in a object as longer you can. When I have to iterate trough a bunch of shapes later on, I save the references inside a collection and I avoid to use other secondary reference like the name, ZOrder or ID.
For example:
dim col as new Collection
dim shp as Excel.Shape
'' <- Insert the code here, where you create your shape or chart
col.add shp1
'' <- Make other stuffs
for each shp in col
'' <- make something with the shape in this loop!
next shp
The problem of course is that the collection and reference are not permanent. You will loose them when you stop and restart the vba code!
SECOND APPROACH
PERSISTENT: My solution is to save the name and the ID of the shape for later reference. Why? Having the name I can access the shape very fast most of the time. Just in case I found a duplicated name I make the slow loop searching the ID. How can I know if there is a name duplicated? Very simple, just check the ID of the first name search, and if they don't match you have to suppose is duplicated.
Here the code:
Function findShapeByNameAndID(ws As Excel.Worksheet, name As String, ID As Long) As Shape
Dim sh As Excel.Shape
Set findShapeByNameAndID = Nothing 'Means not found
On Error GoTo fastexit
Set sh = ws.Shapes(name)
'Now check if the ID matches
If sh.ID = ID Then
'Found! This should be the usual case!
Set findShapeByNameAndID = sh
Else
'Ups, not the right shape. We ha to make a loop!
Dim i As Long
For i = 1 To ws.Shapes.Count
If ws.Shapes(i).ID = ID Then
'Found! This should be the usual case!
Set findShapeByNameAndID = ws.Shapes(i)
End If
Next i
End If
fastexit:
Set sh = Nothing
End Function
Hope this helps you!
Note 1: Is you want to search shapes that maybe inside groups, then the function is more complicated.
Note 2: The ZOrder looks nice, but cannot find it useful. When I tried to take advantage of it, there was always a missing part...
#TimWilliams is almost right (in his comment). However, there are some situation where Tim's idea could get confusing results.
I think the following code will be more appropriate and correct.
Sub qTest()
Dim cho As ChartObject
Set cho = ActiveSheet.ChartObjects(1)
Dim SH As Shape
Set SH = cho.ShapeRange.Item(1)
SH.Select 'here Shape will be selected..
Debug.Print TypeName(SH) '...which we can check here
End Sub