Paste Pictures Into an Excel 2007 Worksheet From a Server
The VBA code in this example shows how to paste pictures into an Excel worksheet and resize them so they fit within the confines of a cell. In preparation, the user should create a template with the "right-sized" cells as the target for the pictures. In addition, the ratio of width to height in the target cell needs to be examined so that the code can be adjusted to allow the entire picture to be contained within the confines of a cell.
This technique allows the user to create catalogs of products with pictures stored on a server.
Program Code
Sub InsertPicturesFromServer(i As Long)
' ******************************************************************************************
' Excel 2007 Version - Parameter i is the row number for insertion
' ******************************************************************************************
' ******************************************************************************************
' dblWidth and dblHeight Contain the Original Picture's Width and Height in Excel Units
' ******************************************************************************************
Dim dblWidth As Double
Dim dblHeight As Double
' ******************************************************************************************
' Ratio of Width to Height. Depending on the ratio, either the width
' or height must be modified so the picture will fit within the confines of a cell space
' ******************************************************************************************
Dim dblDimensionRatio As Double
' ******************************************************************************************
' Flag An Error If Picture Not Found On Server
' ******************************************************************************************
On Error GoTo Handler
' ******************************************************************************************
' Insert Pictures From A Server Using The Path and Picture Name
' For example: \\Servername\Pictures\MyPic.jpg
' ******************************************************************************************
' ******************************************************************************************
' Create the Full Path To the Picture
' ******************************************************************************************
strGblFullPathToPic = strGblPathToPicDirectory & strGblFileName
' ******************************************************************************************
' Default the Success Flag to Yes
' ******************************************************************************************
strGblSuccess = "Y"
' ******************************************************************************************
' Insert The Picture in Excel Note: In Excel 2007, Picture Is NOT
' Inserted in the Currently Selected Cell It Must Be Cut And Pasted To the Destination Cell
' ******************************************************************************************
ActiveSheet.Pictures.Insert(strGblFullPathToPic).Select
Selection.Cut
' ******************************************************************************************
' Select The Destination Cell and Paste The Raw Picture Which Still Needs To Be Resized
' ******************************************************************************************
wksTemplate.Cells(i - 1, 1).Select
ActiveSheet.Paste
' ******************************************************************************************
' Determine the Raw Picture's Width and Length
' ******************************************************************************************
dblWidth = Selection.ShapeRange.Width
dblHeight = Selection.ShapeRange.Height
' ******************************************************************************************
' Calculate The Ratio - This is important in Determining which dimension to increase or
' Shrink in Size so the entire picture will fit in the destination cell
' ******************************************************************************************
dblDimensionRatio = dblWidth / dblHeight
' ******************************************************************************************
' Make Sure Proporations of Width and Height Are Maintained If Picture is Resized
' ******************************************************************************************
Selection.ShapeRange.LockAspectRatio = msoTrue
' ******************************************************************************************
' Depending on the ratio, either resize the Width or Height to fit picture into the
' Destination Cell
' ******************************************************************************************
If dblDimensionRatio > 1.64 Then
Selection.ShapeRange.Width = 93 'Shrink Width
Else
Selection.ShapeRange.Height = 56.70732 ' Shrink Height
End If
' ******************************************************************************************
' Move the picture down slightly so as not to obscure the cell border
' ******************************************************************************************
Selection.ShapeRange.IncrementTop 2.25
' ******************************************************************************************
' Make Sure That the Picture Is Attached To Cell and will be deleted if the row is
' deleted (otherwise it stays even if the row is deleted
' ******************************************************************************************
Selection.Placement = xlMoveAndSize
' ******************************************************************************************
' Allow printing of the picture
' ******************************************************************************************
Selection.PrintObject = True
Exit Sub
' ******************************************************************************************
' On an error, Flag the problem
' ******************************************************************************************
Handler:
strGblSuccess = "N"
On Error GoTo 0
Exit Sub
End Sub
Paste Pictures Into an Excel 2010 Worksheet From a Server
Sub InsertPicturesFromServer2010(i)
Dim dblWidth As Double
Dim dblHeight As Double
Dim dblDimensionRatio As Double
' *********************************************
' Insert Pictures From Server
' *********************************************
On Error GoTo Handler
strGblFullPathToPic = strGblPathToPicDirectory & strGblFileName
strGblSuccess = "Y"
wksTemplate.Cells(i - 1, 1).Select
ActiveSheet.Pictures.Insert(strGblFullPathToPic).Select
dblWidth = Selection.ShapeRange.Width
dblHeight = Selection.ShapeRange.Height
dblDimensionRatio = dblWidth / dblHeight
Selection.ShapeRange.LockAspectRatio = msoTrue
If dblDimensionRatio > 1.64 Then
Selection.ShapeRange.Width = 93 'Shrink Width
Else
Selection.ShapeRange.Height = 56.70732 ' Shrink Height
End If
Selection.ShapeRange.IncrementTop 2.25
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True
Exit Sub
Handler:
strGblSuccess = "N"
On Error GoTo 0
Exit Sub
End Sub