i have typed some image locations in some cells and hyperlinked them. when i click this cells, a macro will be executed and fills a rectangle shape with pictures specified in those cells. this is the macro:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
Row = ActiveCell.Row
col = ActiveCell.Column
ActiveSheet.Shapes.Range(Array("Rectangle 38")).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.UserPicture ActiveSheet.Cells(Row, col).Value
End With
End Sub
it works but the picture is stretched. i want the picture to be fitted inside my shape. in excel , as you might know , after filling a shape with picture,there is a fit button under crop option. when you click it, it fits the image inside the picture box and maintains the size of shape. i want to do the exact thing only in VBA.
Use the shape properties of .PictureWidth , .PictureHeight , .PictureOffsetX = .PictureOffsetY.
Code example:
Option Explicit
Public Sub AddPicAndAdjust()
Dim shp As ShapeRange
Set shp = ActiveSheet.Shapes.Range(Array("Rectangle 1"))
With shp.Fill
.Visible = msoTrue
.UserPicture "C:\Users\User\Pictures\MyNicePic.png" '<== Add pic
.TextureTile = msoFalse
.RotateWithObject = msoTrue
End With
'Positioning within fill
With shp.PictureFormat.Crop
.PictureWidth = 231
.PictureHeight = 134
.PictureOffsetX = 50
.PictureOffsetY = 28
End With
With shp
.LockAspectRatio = msoFalse
.IncrementLeft 2
End With
End Sub
Related
With PowerPoint, I have created several templates made of groups of shapes that I would copy to create nice image galleries in a Word document.
My idea is to automate the following process:
select a shape
shape format > shape fill > picture > from a file
picture format > crop > fill
by a macro that would do:
select all shapes in the selected slide
chose a folder and select pictures
fill each shape with the pictures
crop all the pictures in the shapes to fill the shapes
I have a macro that fill a specific shape on a specific slide with an image thanks to the filedialog. Thanks to commandbars I can do the PictureFillCrop.
Sub FillPictureAndFillCrop()
Dim strFilePath As String
With Application.FileDialog(msoFileDialogFilePicker)
If .Show <> 0 Then
strFilePath = .SelectedItems(1)
With ActivePresentation.Slides(1).Shapes(1).Fill
.Visible = msoTrue
.UserPicture strFilePath
End With
ActivePresentation.Slides(1).Shapes(1).Select
CommandBars.ExecuteMso ("PictureFillCrop")
End If
End With
End Sub
I still need to extend this macro to all the shapes of the selected slide with each pictures I have selected.
I have a previous macro with which I can select multiple pictures and add one picture per newly created slide.
I would like to adapt it to the macro above.
Sub AddOneImagePerNewSlide()
Dim ImgI As Long, tmpDIAPO As Slide
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Add "Images", "*.png, *.gif; *.jpg; *.jpeg", 1
If .Show = -1 Then
For ImgI = 1 To .SelectedItems.Count
Set tmpDIAPO = ActivePresentation.Slides.Add(Index:=ImgI, Layout:=ppLayoutBlank)
tmpDIAPO.Shapes.AddPicture FileName:=.SelectedItems.Item(ImgI), _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, Top:=0, _
Width:=-1, Height:=-1
Next
End If
End With
End Sub
I think it would be a mix of the 2 above macro would work.
Is it doable?
Yes, it is doable.
With this macro you will not need to select the Shapes.
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
End Sub
#Clemleb
To loop through all the shapes on each slide, you'd do something like this:
Option Explicit
Sub EachShape()
Dim oSh As Shape
Dim oSl As Slide
For Each oSl In ActivePresentation.Slides
For Each oSh In oSl.Shapes
' You might add code here to
' ensure that it's the right shape type
' For example, exclude shapes with text
If oSh.HasTextFrame And oSh.TextFrame.HasText Then
' Leave it alone
Else
Call DoSomethingWith(oSh)
End If
Next ' Shape
Next ' Slide
End Sub
Sub DoSomethingWith(oSh As Shape)
' you could call TinMan's example here
ShapePictureFitCrop (oSh)
' then do other things with the shape
End Sub
Sub ShapePictureFitCrop(Shape As Shape)
Dim Width As Double, Height As Double
With Shape
Width = .Width
Height = .Height
.ScaleWidth 1, msoFalse
.ScaleHeight 1, msoFalse
.PictureFormat.CropRight = .Width * Width / 100
.PictureFormat.CropBottom = .Height * Height / 100
End With
End Sub
I am finding adjusting the size of shapes in Excel incredibly frustrating. For some reason, when I resize the height, the width adjusts to some random number, and vice versa. I do not have aspect ratio locked, and have Don't move or size with cells ticked on. The shapes are circles and I am trying to format them to have equal height and width (12 x 12)
Thinking this was due to some bug in the Format Shape controls, I wrote a very simple script to loop over all the shapes in my sheet and correct their properties, but the same problem persists.
Sub FixButFormat()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
sh.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 12
Selection.ShapeRange.Width = 12
Selection.Placement = xlMove
Selection.ShapeRange.LockAspectRatio = msoTrue
Next sh
End Sub
Try the next code, please:
Sub FixButFormat()
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
With sh
.LockAspectRatio = msoFalse
.height = 12
.width = 12
.placement = xlMove
.LockAspectRatio = msoTrue
End With
Next sh
End Sub
But, if the shapes are circles, is it a possibility to not be circles, anymore? I mean having the same dimension on both axes. Otherwise, it is enough to modify only one dimension, keeping LockAspectRatio = msoTrue...
I wrote this function to loop through powerpoint slides in a vba macro. I wanted it to then loop through the shapes on each slide and set the text to user defined defaults.
I got this working and now for some reason after tidying up it stopped working. I get Run-time-error '-2147024809 (80070057) The specified value is out of range.
When I debug it works up to a certain slide. In my case it's a test slide with 5 objects of different types with text in. There is a group.
Despite doing some study and training this one has me stumped. Would really appreciate some help. I'm sure it's a simple solution but I can't see what I'm doing wrong.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For i = 1 To oSl.Shapes.Count
With oSl.Shapes(i).TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
Next i
Next oSl
End Sub
This will probably be enough to solve the problem. It tests each shape to see if it can contain text and if so, if it does contain text and only then does it try to modify the text.
I've also changed the loop a bit to use a Shape object; cuts out a lot of typing and (I think) makes it clearer what you're dealing with.
Sub FontDefaultAllSlidesBody()
'Sets the text for all shapes on all slides in active presentation
'Set variables for functions
Dim oSl As Slide
Dim oSls As Slides
' This will make it easier to read:
Dim oSh as Shape
Set oSls = ActivePresentation.Slides
'Set our default font settings
For Each oSl In oSls
For Each oSh in oSl.Shapes
' Add this to keep it from touching shapes that
' can't contain text
If oSh.HasTextFrame Then
' And skip shapes that have no text
If oSh.TextFrame.HasText Then
With oSh.TextFrame.TextRange.Font
.Size = 16
.Bold = msoFalse
.Italic = msoFalse
.Underline = msoFalse
.Color = msoThemeColorAccent1
.Name = "+mn-lt"
End With
End If ' HasText
End If ' HasTextFrame
Next ' Shape
Next oSl
End Sub
I am trying to use VBA in PowerPoint to copy 2 shapes and a group of shapes called SP_MP, SP_TEST and the group called SP_MP_START from the active slide in the same slide, in the following location 83.52, 41.62. Issue is I don't know how to reference to the shapes and group to copy them and what commands to use.
Thank you in advance,
Stefan.
Private Sub CommandButton1_Click()
Dim Sld As Slide
Dim Shp As Shape
'ERROR HANDLING
If ActivePresentation.Slides.Count = 0 Then
MsgBox "You do not have any slides in your PowerPoint project."
Exit Sub
End If
Set Sld = Application.ActiveWindow.View.Slide
'Create shape with Specified Dimensions and Slide Position
Set Shp = Sld.Shapes.AddShape(Type:=msoShapeFlowchartPredefinedProcess, _
Left:=50, Top:=100, Width:=83.52, Height:=41.62)
'FORMAT SHAPE
'Shape Name
Shp.Name = "My Header"
'No Shape Border
Shp.Line.Visible = msoTrue
'Shape Fill Color
Shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
'Shape Text Color
Shp.TextFrame.TextRange.Font.Color.RGB = RGB(0, 0, 0)
'Text inside Shape
Shp.TextFrame.TextRange.Characters.Text = TextBox1
'Center Align Text
Shp.TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter
'Vertically Align Text to Middle
Shp.TextFrame2.VerticalAnchor = msoAnchorMiddle
'Adjust Font Size
Shp.TextFrame2.TextRange.Font.Size = 8
'Adjust Font Style
Shp.TextFrame2.TextRange.Font.Name = "Verdana (Body)"
Unload UserForm4
End Sub
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If