To merely crop a shape, here is the basic code:
Sub insert()
i = 1
Set myDocument = ActivePresentation.Slides(i)
myDocument.Layout = ppLayoutPictureWithCaption
Set myImage = myDocument.Shapes.AddPicture("D:\Pictures\" & _
"image1.PNG", LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, _
Left:=390, Top:=200, Width:=330, Height:=250)
myImage.PictureFormat.CropLeft = 40
myImage.PictureFormat.CropRight = 40
myImage.PictureFormat.CropTop = 40
myImage.PictureFormat.CropBottom = 40
End Sub
For a more advanced example, using a specific directory, it is possible to loop through the files and add all of the images therein to each consecutive slide. In the code below, I have added error handling that will create slides if there are none present or if there are less slides than there are pictures.
To automatically crop a solid color from around images, it's a little more complicated, but it is doable using the getPixel API. In the below example, I create a temporary file in bitmap format, and loop through the pixels from the left side of the image until a non-white pixel is found to determine the width of the border. I then crop the shape accordingly. I've tested this code in different environments, and I've discovered that there are differences in the size of the exported files. Consequently, there is a scaleAdjustment parameter that can be used to dial in the cropping for a specific system. In the code below, the crop color is set to white, but if a different color needs to be cropped, a partial chart can be found here. Using this code, it is also possible to filter a gradient color using a range of color codes in the If NOT Like statement:
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Function PixelTest(objPict As Object, ByVal X As Long, ByVal Y As Long) As Long
Dim lDC As Variant
lDC = CreateCompatibleDC(0)
SelectObject lDC, objPict.Handle
PixelTest = GetPixel(lDC, X, Y)
DeleteDC lDC
End Function
Sub insert()
Dim myDocument As Slide, fileSystem As Object, fileFolder As Object
Dim fileItem As Object, objPict As Object, objImage As Object
Dim i As Integer, startingPoint As Integer, endingPoint As Integer
Dim MidPoint As Integer, filePath As String
Dim scaleAdjustment As Single, margin As Single
Dim importHeight As Single, importWidth As Single
Dim xlocation As Single, yLocation As Single
Dim restoreLayout As Boolean
filePath = "D:\Pictures"
Set fileSystem = CreateObject("Scripting.FileSystemObject")
Set fileFolder = fileSystem.GetFolder(filePath)
Set objImage = CreateObject("WIA.ImageFile")
scaleAdjustment = 3
importWidth = 330
importHeight = 250
xlocation = 390
yLocation = 200
For Each fileItem In fileFolder.Files
If fileItem Like "*.PNG" Then
i = i + 1
On Error GoTo insertSlide
Set myDocument = ActivePresentation.Slides(i)
If myDocument.CustomLayout.Name = "Picture with Caption" Then
myDocument.Layout = ppLayoutText
restoreLayout = True
End If
Set preCroppedPic = myDocument.Shapes.AddPicture(FileName:=fileFolder & "\" & _
fileItem.Name, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue, _
Left:=xlocation, Top:=yLocation, Width:=importWidth, Height:=importHeight)
preCroppedPic.Export filePath & "\Temp.bmp", ppShapeFormatBMP, preCroppedPic.Width, preCroppedPic.Height, ppScaleToFit
Set objImage = CreateObject("WIA.ImageFile")
objImage.LoadFile filePath & "\Temp.bmp"
Set objPict = LoadPicture(filePath & "\Temp.BMP")
endingPoint = objImage.Width
MidPoint = (0.5 * objImage.Height)
For marginScan = 1 To endingPoint
On Error Resume Next
If Not (PixelTest(objPict, marginScan, MidPoint) Like "1677*") Then
margin = marginScan * scaleAdjustment
preCroppedPic.PictureFormat.CropLeft = margin
preCroppedPic.PictureFormat.CropRight = margin
preCroppedPic.PictureFormat.CropTop = margin
preCroppedPic.PictureFormat.CropBottom = margin
Exit For
End If
Next
If restoreLayout Then
myDocument.Layout = ppLayoutPictureWithCaption
restoreLayout = False
End If
End If
Next fileItem
Exit Sub
insertSlide:
Set myDocument = ActivePresentation.Slides.Add(i, ppLayoutText)
Resume Next
End Sub
The preceding code produces the following result when importing uncropped files with a solid white border:
Note how the white border has been trimmed after the import.
Also, note that there is an if statement that filters out non PNG files. If working with other types of picture files, this will have to be modified accordingly.
