I have a VBA macro that goes for an image in a file and sticks it into an Excel spreadsheet, in a worksheet called "Country Profile".
I would like to resize the image so that it has a width of 350px, while maintaining its aspect ratio.
This is the code that I wrote:
Public Sub Macro15()
Dim picname As String
Dim shp As Shape
Dim present As String
Sheets("Country Profile").Activate
Sheets("Country Profile").Select
ActiveSheet.Pictures.Delete
Cells(19, 40).Select 'This is where picture will be inserted (column)
picname = Sheets("REPORT ON").Range("A2").Value 'This is the picture name
Cells(19, 46).Select
Call ActiveSheet.Shapes.AddPicture("C:\Users\" & Environ("UserName") & "\Maps with Cities\" & picname & ".png", _
LockAspectRatio = msoTrue, msoCTrue, Left:=Cells(19, 40).Left, Top:=Cells(19, 46).Top, Width:=350, Height:=-1).Select
End Sub
The code works and the image is inserted in the desired file. However, the aspect ratio is not maintained. What can I do to correct this?
Try it like this:
With ActiveSheet.Pictures.Insert(PicPath)
.ShapeRange.LockAspectRatio = msoTrue
.Width = 350
End With
Related
I’m writing a Document in which I have to include many Pictures. In the ongoing process the Pictures get changed many times.
My idea was to include Rectangle Shapes as placeholders and give them a suitable name. I created a Macro that selects the Shape, deletes the old Picture and inserts the new one into the Shape.
Sub InsertImage(Shape As String, Picture As String, Hight As Integer)
Dim shp As Word.Shape
Dim strFile As String
Dim strExt As String
strFile = "C:\Pictures"
strExt = ".png"
ActiveDocument.Shapes.Range(Array(Shape)).Select
Selection.TypeBackspace
Set shp = ActiveDocument.Shapes.AddPicture(Anchor:=Selection.Range, FileName:= _
strFile & "\" & Picture & strExt, LinkToFile:=False, SaveWithDocument:=True)
With shp
.LockAspectRatio = msoTrue
.Height = CentimetersToPoints(Hight)
End With
End Sub
Sub Insert1()
InsertImage "Shape01", "Pic01", 10
End Sub
I want this for floating Shapes as well as for InlineShapes.
When I set my Placeholder Shapes to InlineShapes the TypeBackspace line deletes the InlineShape and the picture does not get inserted into the InlineShape.
Thank you very much for the help. After many struggles, the solution with Tables + Bookmarks works perfekt.
Here is the code:
Sub InsertPic(Pic As String, Cut As Single)
Dim strFile As String
Dim strExt As String
Dim ils As InlineShape
strFile = "C:\Pictures“
strExt = ".png"
Application.ScreenUpdating = False
ActiveDocument.Bookmarks(Pic).Select
Selection.Delete
Set ils = Selection.InlineShapes.AddPicture(FileName:= _
strFile & "/" & Pic & strExt, _
LinkToFile:=False, SaveWithDocument:=True)
With ils
.PictureFormat.CropBottom = CentimetersToPoints(Cut)
.LockAspectRatio = msoTrue
.Height = .Range.Cells(1).Height
If .Width > .Range.Cells(1).Width Then
.Width = .Range.Cells(1).Width
End If
End With
ActiveDocument.Bookmarks.Add (Pic)
Application.ScreenUpdating = True
End Sub
Sub Insert01()
InsertPic "Image01", 20
MsgBox "Done"
End Sub
Some explanation:
For this code, the Bookmark and the Picture need the same Name. I made this to avoid mix-ups.
With the Selection.Delete command, the Bookmark gets also deleted, so I just added a new Bookmark with the same name at the end. I’m sure there are more elegant ways to solve this, but this solution works.
I have had many struggles because i wanted to crop the Picure. But the size gets changed to the size of the table-cell when its inserted and the cutting step comes afterwards. So the Picturs wasn´t filling the complete cell size. Therefore, I added a part to resize the Image to the table-cell Size. As well, im sure there are better ways to overcome this ...
Because of this resizing, the Makro needs a bit of time (at least for my document). So I disabled the Screenupdating.
I think this could solve problems for a lot of people doing tedious pasting of images from one directory into powerpoint then resizing them.
My problem is that I have 16 images all in one directory which need updating each month and it's very slow to do it one by one. The task is:
Open directory
Open first image
Paste image into powerpoint
Reposition image to top left
Resize image to height 550 by width 960 (fills A4 page)
Send image to back
Move to next slide
Repeat for second image
Continue until no more images in directory
Directory is (e.g.) "C:\Users\xxxxxx\Documents\Work\Procurement Project\Slides"
First image name is (e.g.) "01 Summary", second is "02 Client Contracts" etc etc
I think I need a str and a path and a table for the str to add to path to create each new path using i and i + 1 etc
I think I then need some code that's a bit like this:
Sub Picture_size_and_position()
Dim oShape As Shape
Dim oPresentation As Presentation
Dim oSlide As Slide
Dim oSelection As Selection
ActiveWindow.View.GotoSlide oSlide.SlideIndex
With ActiveWindow.Selection.ShapeRange
.LockAspectRatio = msoFalse
.Height = 550
.Width = 960
.Left = 0
.Top = 0
End With
End Sub
Then I'm sure I need a looping function to repeat this until there's nothing left in the directory using some combination of i and j...but the whole code is way beyond me, very frustratingly.
Could someone offer some tips, please? Much much appreciated!
Thank you!
Sub ImportABunch()
Dim strTemp As String
Dim strPath As String
Dim strFileSpec As String
Dim oSld As Slide
Dim oPic As Shape
' Edit these to suit:
strPath = "C:\Users\username\"
strFileSpec = "*.png"
strTemp = Dir(strPath & strFileSpec)
i = 1
Do While strTemp <> ""
Set oSld = ActivePresentation.Slides(i)
Set oPic = oSld.Shapes.AddPicture(FileName:=strPath & strTemp, _
LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, _
Left:=0, _
Top:=0, _
Width:=960, _
Height:=550)
i = i + 1
With oPic
.LockAspectRatio = msoFalse
.ZOrder msoSendToBack
End With
' Or (with thanks to David Marcovitz) make the picture as big as possible on the slide
' without changing the proportions
' Leave the above commented out, uncomment this instead:
' With oPic
' If 3 * .width > 4 * .height Then
' .width = ActivePresentation.PageSetup.Slidewidth
' .Top = 0.5 * (ActivePresentation.PageSetup.Slideheight - .height)
' Else
' .height = ActivePresentation.PageSetup.Slideheight
' .Left = 0.5 * (ActivePresentation.PageSetup.Slidewidth - .width)
' End If
' End With
' Optionally, add the full path of the picture to the image as a tag:
'With oPic
' .Tags.Add "OriginalPath", strPath & strTemp
'End With
' Get the next file that meets the spec and go round again
strTemp = Dir
Loop
End Sub
Credit to http://www.pptfaq.com/index.html - Great little site!
Have an idea to automate it/or upon manual launch of a new Macro Enabled PowerPoint Template file. To automate macro upon file open, add customUI: onLoad="ImagesToPowerPoint". Search "CustomUI Editor" for it.
Note I have not fully tested the automation part.
Option Explicit
Sub ImagesToPowerPoint()
Const FileType As String = "*.png"
Dim sSaveFilePath As String, sSaveFileName As String, sImagesFolder As String
Dim oLayout As CustomLayout, oSlide As Slide, i As Long, sFile As String
sImagesFolder = Environ("USERPROFILE") & "\Documents\Work\Procurement Project\Slides\"
' Prepare auto save PowerPoint file name
sSaveFilePath = Environ("USERPROFILE") & "\Documents\Work\PowerPoints\"
sSaveFileName = Format(Now, "yyyy_mmdd") & "_Procurement.pptx"
With ActivePresentation
' Use the first layout for all new slides
Set oLayout = .SlideMaster.CustomLayouts(1)
' Start processing all files in the folder
sFile = Dir(sImagesFolder & FileType)
Do Until sFile = ""
' Add new slide
Set oSlide = .Slides.AddSlide(.Slides.Count, oLayout)
' Delete all the shapes from that layout
For i = oSlide.Shapes.Count To 1 Step -1
oSlide.Shapes(i).Delete
Next
' Add the image to slide
With oSlide.Shapes.AddPicture(sImagesFolder & sFile, msoFalse, msoTrue, 0, 0, oLayout.Width, oLayout.Height)
.LockAspectRatio = msoFalse
.AlternativeText = Now & " | " & sImagesFolder & sFile
End With
sFile = Dir
Loop
.SaveAs sSaveFilePath & sSaveFileName
End With
Presentations(sSaveFileName).Close
If Presentations.Count = 0 Then Application.Quit
End Sub
I am trying to export a PPT Shape into an image file, however, PowerPoint is re-sizing the shape to the text length.
I know there is an Autosize feature in VBA, however I cannot get the msoAutoSizeTextToFitShape feature working in PowerPoint 2013.
My code is as follows
Sub RunMe()
Dim MyShape As Shape
Dim i As Integer
Dim S(0 To 2) As String
Set MyShape = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 40)
S(0) = "short text"
S(1) = "Medium length text"
S(2) = "Really Really Long and descriptive Text"
For i = 0 To 2
With MyShape
'.TextFrame.AutoSize = PowerPoint.ppAutoSizeMixed
.TextFrame.TextRange.Text = S(i)
.Export "C:\temp\" & "\" & S(i) & ".png", ppShapeFormatPNG
End With
Next i
End Sub
As you will see, the generated image dimensions are different. Is there a way to create images of the same size?
You could either adjust the text size to make sure it fits within the shape or adjust the shape to fit the text size. My guess is that you'd want the former, so have a shot with this:
Sub RunMe()
Dim MyShape As Shape
Dim i As Integer
Dim S(0 To 2) As String
Dim sngOriginalSize As Single
Set MyShape = ActivePresentation.Slides(1).Shapes.AddShape(msoShapeRectangle, 50, 50, 100, 40)
S(0) = "short text"
S(1) = "Medium length text"
S(2) = "Really Really Long and descriptive Text"
For i = 0 To 2
With MyShape
.TextFrame.TextRange.Text = S(i)
' store original text size
sngOriginalSize = .TextFrame.TextRange.Font.Size
' decrement font size until the text fits
' within the shape:
Do While .TextFrame.TextRange.BoundHeight > MyShape.Height
.TextFrame.TextRange.Font.Size = .TextFrame.TextRange.Font.Size - 1
Loop
.Export "C:\temp\" & "\" & S(i) & ".png", ppShapeFormatPNG
' reset the text to original size
.TextFrame.TextRange.Font.Size = sngOriginalSize
End With
Next i
End Sub
I have version 2003 installed on my current PC so the following is NOT TESTED.
According to some websites, TextFrame2 is a new property from 2007 onwards.
You may try msoAutoSizeTextToFitShape on TextFrame2 instead.
EDIT :
I tried this in my home PC with version 2010 and it looks okay. Give it a try.
Replace TextFrame in your code by TextFrame2
I have some cells with some values. This values are the names of a pictures in a folder. I would like to show the proper picture called "value" when I click a cell "value". I would like to do it dynamically, so that adding a picture causes displaying it when a cell with its name value is clicked. Could you tell me where should I start? Are there any tutorials showing how to do this? I found many, but they use lists and store pics in excel worksheet. Are there any examples?
Private Sub CommandButton2_Click()
On Error Resume Next
Dim imageFolder As String 'this is the folder where the image is located
Dim imagePath As String
Cells.Find("Code").Offset(1).Select
Range(Selection, Selection.End(xlDown)).Select
For Each cell In Selection
imageFolder = cell.Value
imagePath = "C:\Documents and Settings\kollol\My Documents\Quotes\Image\" & imageFolder
cell.Offset(0, 2).Select
ActiveSheet.Pictures.Insert(imagePath & "\" & "1.jpeg").Select ' here the name of the image is 1.jpg
With Selection
.Placement = xlMoveAndSize
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Width = ActiveCell.ColumnWidth
.ShapeRange.Height = ActiveCell.RowHeight - 5
.ShapeRange.IncrementLeft 10.5
.ShapeRange.IncrementTop 4#
End With
Next cell
End Sub
I'm using vba in PowerPoint. I'm trying to compress orginal picture files from a specified folder to a smaller size. I was able to achieve that. However, I want to save the new compressed picture into a destination folder.
The following code will save the presenation or slide with the picture. But I only want the picture. I'm pretty sure I have to use ActivePresentation.SaveAs. But it will only let me save the slide. How can I save the pic alone & not the slide?
Also, I seem to have another problem when I try to save the modified pic. It saves the presentation into a folder in the destination with a filename of "Slide1.bmp". Any idea why & how can I change this?
Dim strSrcPath As String, strDestPath As String
Dim strSrcPic As String
Dim objPic As Shape
Dim x as Integer
strSrcPath = "C:\Temp\Pics\In\"
strDestPath = "C:\Temp\Pics\Out\"
strSrcPic = Dir(strSrcPath)
Do While strSrcPic <> ""
x = x + 1
Set objPic = ActiveWindow.Selection.SlideRange.Shapes.AddPicture(FileName:=strSrcPath & strSrcPic, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, Left:=0, Top:=0, Width:=100, _
Height:=100)
With objPic
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
End With
objPic.Select
ActivePresentation.SaveAs _
FileName:=strDestPath & "ModPicture(" & x & ").bmp", _
FileFormat:=ppSaveAsBMP, EmbedTrueTypeFonts:=msoFalse
objPic.Delete
strSrcPic = Dir 'Get next entry.
Loop
Thanks #JSRWilson for the following response:
"You do have to right click in View >Object Browser >> Show Hidden Members
Assuming objPic is still a reference to the compressed pic
objPic.Export(strDestPath & "& "ModPicture(" & x & ").bmp", ppSaveAsBMP)"