I've written a vba script which basically inserts a table into a slide with text"Sample text in the cell", Now i want to add images to the cells of the table depending on the size of a table from a folder.
Basically if it's 5X3 table then it should take 15 images from the folder and arrange it into the cell with the image file name. The output which i want is this:
the code which i wrote is :
Sub NativeTable()
Dim pptSlide As Slide
Dim pptShape As Shape ' code to create table in present slide
Dim pptPres As presentation
Dim iRow As Integer
Dim iColumn As Integer
Dim oShapeInsideTable As Shape
Set pptPres = ActivePresentation
With pptPres
Set pptSlide = .Slides.Add(.Slides.Count, ppLayoutBlank)
End With
With pptSlide.Shapes
Set pptShape = .AddTable(NumRows:=3, NumColumns:=5, Left:=30, _
Top:=110, Width:=660, Height:=320)
End With
With pptShape.Table
For iRow = 1 To .Rows.Count
For iColumn = 1 To .Columns.Count
With .Cell(iRow, iColumn).Shape.TextFrame.TextRange
.Text = "Sample text in Cell"
With .Font
.Name = "Verdana"
.Size = "14"
End With
End With
Next iColumn
Next iRow
End With
End Sub
So how can i do it please help me with this and the image should be resizable(if that is possible) please help me with this
Is this possible i've checked the msdn object reference but there is no option for inserting picture in a cell
Insert as cell background. Select a cell > Design > Shading > Picture
I'm a little late to the party, but here's the code in case anyone else needs it. Just make sure to change the variables in parenthesis to fit your needs.
PowerPoint.ActivePresentation.Slides(1).Shapes("table_1").Table.Cell(1, 2).Shape.Fill.UserPicture ("location_of_picture_file")
Related
I'm using MacOS or I would have tried the Macro recorder :(
I have a regular repetitive task to change the selected text at various positions within multiple tables to a set font and size as well as centered within the table and vertically in the middle. Rather than do this a thousand times a week I am trying to make a macro to do it for me with VBA.
So far I have the font and text size changing whatever text is selected but can't seem to figure out the alignment with my friend Google.
Sub SR()
With ActiveWindow.Selection.TextRange2.Font
.Name = "Roboto Light (Body)"
.Size = "10"
End With
End Sub
Solution:
Sub SR()
Dim oTbl As Table
Dim oSh As Shape
Dim lRow As Long
Dim lCol As Long
' Get a reference to the parent table
With ActiveWindow.Selection.ShapeRange(1).Table
' Find the selected cell
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
If .Cell(lRow, lCol).Selected Then
With .Cell(lRow, lCol).Shape.TextFrame2
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
With .Cell(lRow, lCol).Shape.TextFrame2.TextRange.Font
.Name = "Roboto Light (Body)"
.Size = "10"
End With
End If
Next
Next
End With
End Sub
Combine this with what you have and it should get you there.
You can set font and other characteristics of selected text, but to change the alignment, you need to work with the shape that contains the text.
Normally you could walk up the selected text's Parent chain to get the containing shape, but unfortunately, that doesn't work with text in table cells. PPTBug.
Instead, you have to look at each cell to find out whether it's selected and if so, drill down to its shape. Which is what we do here.
By the way, no version of PPT has a macro recorder any longer, not even Windows.
Sub Test()
Dim oTbl As Table
Dim oSh As Shape
Dim lRow As Long
Dim lCol As Long
' Get a reference to the parent table
With ActiveWindow.Selection.ShapeRange(1).Table
' Find the selected cell
For lRow = 1 To .Rows.Count
For lCol = 1 To .Columns.Count
If .Cell(lRow, lCol).Selected Then
With .Cell(lRow, lCol).Shape.TextFrame2
.HorizontalAnchor = msoAnchorCenter
.VerticalAnchor = msoAnchorMiddle
End With
End If
Next
Next
End With
End Sub
I've written a code to set pictures next to it's link in an excel sheet after it's done downloading. It is working smoothly but the problem is that every time i run the code it gets downloaded again and settled there. So if i delete one picture i see another one in that place. I hope there is a solution in if statement so that, if applied, it will omit downloading and go for the next loop if the cell is already filled in. I can't make it. If anybody helps me accomplish this, i would be very grateful. Thanks in advance.
Note: Links are in B column and pictures to get settled in C column.
Sub SetPics()
Dim pics As String
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
pics = cel.Offset(0, -1)
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.Width = cel.Width
.Height = cel.Height
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
Next cel
End Sub
You need to scan the ActiveSheet (try not to use this, and replace it with Worksheets("YourSheetName")) for all Shapes.
For each Shape found, check it's TopLeftCell.Row property, if it equals the
cel.Row then the current picture already exists (from previous runs of this code), and you don't "re-insert" the picture.
Code
Sub SetPics()
Dim pics As String
Dim myPics As Shape
Dim PicExists As Boolean
Dim myPic As Picture
Dim rng As Range
Dim cel As Range
Set rng = Range("C2", Range("B2").End(xlDown).Offset(0, 1))
For Each cel In rng
PicExists = False ' reset flag
pics = cel.Offset(0, -1)
' loop through all shapes in ActiveSheet
For Each myPics In ActiveSheet.Shapes
If myPics.TopLeftCell.Row = cel.Row Then ' check if current shape's row equale the current cell's row
PicExists = True ' raise flag >> picture exists
Exit For
End If
Next myPics
If Not PicExists Then '<-- add new picture only if doesn't exist
Set myPic = ActiveSheet.Pictures.Insert(pics)
With myPic
.ShapeRange.LockAspectRatio = msoFalse
.WIDTH = cel.WIDTH
.HEIGHT = cel.HEIGHT
.Top = Rows(cel.Row).Top
.Left = Columns(cel.Column).Left
End With
End If
Next cel
End Sub
I am trying to copy a range from Excel into PowerPoint using vba.
Copying and Pasting are no Problem, but i can´t get the text in the created PowerPoint table to be aligned right (and vertical Center).
Here is the part how i copy and paste the range:
Dim myWks As Excel.Worksheet
Dim ppSlide As PowerPoint.Slide
wksData.Range("A2:A5").Copy
ppSlide.Shapes.PasteSpecial
Set MyShape = ppSlide.Shapes(ppSlide.Shapes.Count)
MyShape.Top = x
MyShape.Height = y
MyShape.Width = z
MyShape.Left = m
Now I Need something like MyShape.Align = Right (which of course is not working).
Can someone help me with this?
Thx a lot!
Try the following procedure, it works on my Excel file.
You need to have an open PowerPoint, this sub-routine will scan column A in your Excel file (starting from the second row).
It will create a new slide at the end of the open PowerPoint, and will create a Table with the number of rows it found text in your Excel worksheet column A.
At last it will store each Excel's row data in in the new Table.
Sub Export_to_PPT_Table()
Dim wksData As Excel.Worksheet
Dim PPT As PowerPoint.Application
Dim ppslide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Dim ppTable As PowerPoint.Table
' in brackets add your worksheet name
Set wksData = ActiveWorkbook.Worksheets("Sheet2")
Set PPT = New PowerPoint.Application
PPT.Visible = True
'Add a blank slide at the end of an existing PowerPoint
Set ppslide = PPT.ActivePresentation.Slides.Add(PPT.ActivePresentation.Slides.Count + 1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Dim Excel_numofRows As Integer
ExcelRow = 2
' loop through your excel file in Column A, and check for last row with existing text inside
While wksData.Cells(ExcelRow, 1) <> ""
Excel_numofRows = ExcelRow
ExcelRow = ExcelRow + 1
Wend
' create a new Table in the new slide created
' in brackets is where you play with your table's properties
Set ppShape = ppslide.Shapes.AddTable(Excel_numofRows, 1, 100, 100, PPT.ActivePresentation.PageSetup.SlideWidth - 300, 150)
Set ppTable = ppShape.Table
ExcelRow = 2
While wksData.Cells(ExcelRow, 1) <> ""
With ppTable
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.Text = wksData.Cells(ExcelRow, 1)
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = msoTextEffectAlignmentRight
.Cell(ExcelRow - 1, 1).Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
End With
ExcelRow = ExcelRow + 1
Wend
End Sub
I have an Excel worksheet that i use as a printable single page PDF report that contains an image with some text. In a column to the side I have a list of all the images in a specific folder and i would like to use VBA to cycle through the list replacing the image in the worksheet and creating a PDF to be stored in the same folder. I currently do this manually which is a pain and would like to automate it with VBA.
Any help would be greatly appreciated.
Thanks in advance.
The code i use manualy by changing the full path of the image to be replaced is as follows>
Sub AddPicturesFULL()
Dim myPic As Picture
Dim wkSheet As Worksheet
Dim myRng As Range
Dim myCell As Range
Dim rowCount As Long
Dim rowCount2 As Long
Dim Pic As Object
Set wkSheet = Sheets("REPORT(FULL)") ' -- Change to your sheet
For Each Pic In wkSheet.Pictures
Pic.Delete
Next Pic
'-- The usual way of finding used row count for specific column
rowCount2 = wkSheet.Cells(wkSheet.Rows.Count, "N").End(xlUp).Row
If rowCount2 <> 0 Then
Set myRng = wkSheet.Range("N2", wkSheet.Cells(wkSheet.Rows.Count, "N").End(xlUp))
For Each myCell In myRng.Cells
If Trim(myCell.Value) = "" Then
'MsgBox "No file path"
ElseIf Dir(CStr(myCell.Value)) = "" Then
MsgBox myCell.Value & " Doesn't exist!"
Else
'myCell.Offset(0, 1).Parent.Pictures.Insert (myCell.Value)
Set myPic = myCell.Parent.Pictures.Insert(myCell.Value)
With myCell.Offset(0, -13) '1 columns to the right of C ( is D)
'-- resize image here to fit into the size of your cell
myPic.Top = .Top
myPic.Width = .Width
myPic.Height = 640
myPic.Left = .Left
myPic.Placement = xlMoveAndSize
myPic.SendToBack
End With
End If
Next myCell
Else
MsgBox "There is no file paths in your column"
End If
End Sub
Create an ActiveX Image on the Sheet instead of using drawing Pictures
Then you can use
Dim i As Integer
For i = 1 To 20 Step 1
imgTest.Picture = LoadPicture(Sheets("Sheet1").Cells(i, COLUMN).Value)
Sheets("Sheets1").ExportAsFixedFormat Type:=xlTypePDF, Filename:="C:\test" & i & ".pdf", Quality:=xlQualityStandard
Next i
To loop through the column with imagepaths and set the image for each of them. Then just export it as a PDF.
Of course you have to adjust the i values and COLUMN to your needs.
I'm working with PowerPoint 2007. I want to use a list to create a table on a slide. The first column of each row will have a hyperlink to a different slide in the presentation (like a summary slide).
I'm having trouble using VBA to insert a hyperlink into a cell. The error message is usually something like "object doesn't support that function".
Here is the offending line:
With pptPres.Slides(2).Shapes("Table Summary").Table.Cell(i - 1, 1).Shape.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = ThisWorkbook.Sheets(i).Range("B1")
.SubAddress = pptPres.Slides(i).SlideID
End With
You're almost there.
You need to access TextRange Object if you want to add a Link in the text within a table or shape.
Something like:
Sub marine()
Dim t As Table
Dim pptpres As Presentation
Set pptpres = ActivePresentation
Set t = pptpres.Slides(1).Shapes(1).Table
With t.Cell(2, 1).Shape.TextFrame.TextRange.ActionSettings(ppMouseClick).Hyperlink
.TextToDisplay = "Link to Slide"
.SubAddress = pptpres.Slides(2).SlideNumber _
& ". " & pptpres.Slides(2).Name
End With
End Sub
And also, you cannot use SlideID property as SubAddress.
It should be in this format: <slide number><dot><space><slide name> (eg. #2. Slide2)
To get this done we used SlideNumber and Name property instead. HTH
thanks for the above. Below generates a hyperlinked TOC table for each slide into slide 2
Sub DeckTOC() ' Creates a hyperlinked TOC of each slide in deck
' Tip: add a return-to-TOC hyperlink on Slidemaster default layout
' assumes slide 1 is a cover slide, slides 2 is for TOC
' and #2 already includes a table And (important) no other shapes or title
' with col 1 for slide title and 2nd cloumn for slide no
' TOC can be formatted before/after macro has run
Dim slidecount As Integer
Dim t As Table
Dim TOCrow As Integer
Dim pptpres As Presentation
Set pptpres = ActivePresentation
slidecount = pptpres.Slides.Count
If slidecount < 3 Then Exit Sub ' nothing to do
Set t = pptpres.Slides(2).Shapes(1).Table ' grab= ther toc
TOCrow = 2
For i = 3 To slidecount Step 1 ' get slide references for each slide
If TOCrow > t.Rows.Count Then t.Rows.Add ' add rows on fly as needed
' create text entry in cell, then add hyperlink (doing in one step fails)
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange
.Text = pptpres.Slides(i).Shapes.Title.TextFrame.TextRange.Characters
End With
With t.Cell(TOCrow, 1).Shape.TextFrame.TextRange.Characters().ActionSettings(ppMouseClick).Hyperlink
.Address = ""
.SubAddress = pptpres.Slides(i).SlideNumber & ". " & pptpres.Slides(i).Name
End With
t.Cell(TOCrow, 2).Shape.TextFrame.TextRange.Text = i
TOCrow = TOCrow + 1
Next
End Sub
ex [enter image description here][1]
[1]: https://i.stack.imgur.com/gaMJK.png