Cropping a fixed area from a picture in VBA

Question

I would like to create a PowerPoint VBA script which inserts pictures such that they are cropped to a fixed size relative to the top and left of the image. As a starting point, I would like to take the following VBA script:

Sub Insert_Traverse_1()
    Dim oPic As Shape
    Set oPic = ActiveWindow.View.Slide.Shapes.AddPicture("\\nlamvfs00065\homes\nlkpec\newpic.png", False, True, 0, 0, -1, -1)
        oPic.PictureFormat.CropLeft = 110
        oPic.PictureFormat.CropTop = 85
        oPic.PictureFormat.CropRight = 16
        oPic.PictureFormat.CropBottom = 55
        oPic.Height = 7.5 * 72
        oPic.Left = 0 * 72
        oPic.Top = 0 * 72
        oPic.ZOrder msoSendToBack
End Sub

This VBA script inserts the picture 'newpic.png', which represents a screen grab of a window, and crops a fixed amount (representing the borders of the window) from the edges. This works fine if what I want is indeed the entire window.

Now, however, I'd like to make another VBA script which inserts a certain part of the window, which has a fixed size and position relative to the top left of the window. The problem, however, is that "CropRight" and "CropBottom" are now dependent on the size of the window. I've tried the following:

Sub Insert_Well_Tie_TZ()
    Dim oPic As Shape
    Set oPic = ActiveWindow.View.Slide.Shapes.AddPicture("\\nlamvfs00065\homes\nlkpec\newpic.png", False, True, 0, 0, -1, -1)
        ppi = 72                    'points per inch (=72 always)
        dpi = 96                    'dots per inch (=96 for my screen)
        oWidth = oPic.Width         'width of the shape in pixels
        oHeight = oPic.Height       'height of the shape in pixels
        oWidthPoints = oWidth * ppi / dpi   'width of the shape in points
        oHeightPoints = oHeight * ppi / dpi 'height of the shape in points
        L = 182                     'number of points to crop from the left
        T = 394                     'number of points to crop from the top

        oPic.PictureFormat.CropLeft = L
        oPic.PictureFormat.CropRight = oWidthPoints - L + 665
        oPic.PictureFormat.CropTop = T
        oPic.PictureFormat.CropBottom = oHeightPoints - T + 318
        ' oPic.Height = 7.5 * 72
        oPic.Left = 0 * 72
        oPic.Top = 0 * 72
        oPic.ZOrder msoSendToBack
End Sub

As I understand it, the "CropLeft" etc. are expressed in units of points (=1/72nd of an inch) whereas the ".Width" and ".Height" properties are expressed in pixels; that's why I've included a conversion factor of 72/96 to convert the width of the picture from pixels to points.

The idea was to, by taking into account the width of the image in the amount to crop from the right, the part of the image that is cropped should look the same regardless of the size of the window. I find, however, that this is not the case, and I probably have some scaling factor wrong. Can anybody see the problem?

Answer 1

I managed to solve the problem for a special case, namely, a portion of a picture with fixed width. Here is the code:

Sub Insert_Well_Tie_Fit_To_Slide()
    Dim sh As Double
    Dim sw As Double
    Dim sa As Double
    With ActivePresentation.PageSetup
        sh = .SlideHeight       ' Slide height (usually 10 inches * 72 points/inch = 720 points)
        sw = .SlideWidth        ' Slide width (usually 7.5 inches * 72 points/inch = 540 points)
    End With
    sa = sh / sw                ' Slide aspect ratio (usually 3/4)

    Dim cl As Double
    Dim ct As Double
    Dim cr As Double
    Dim cb As Double
    cl = 0.05 * 72      ' Points to crop from the left
    ct = 0.72 * 72       ' Points to crop from the top
    cb = 0.72 * 72      ' Points to crop from the bottom
    fw = 10.17 * 72     ' Final width

    Dim oPic As Shape
    Set oPic = ActiveWindow.View.Slide.Shapes.AddPicture("\\nlamvfs00065\homes\nlkpec\newpic.png", False, True, 0, 0, -1, -1)
        With oPic
            .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
            .PictureFormat.CropLeft = cl
            .PictureFormat.CropTop = ct
            .PictureFormat.CropBottom = cb
            w1 = .Width
            cr = w1 - fw - cl       ' Points to crop from the right
            .PictureFormat.CropRight = cr
            h = .Height
            w = .Width
            a = h / w           ' Aspect ratio of picture
            If a > sa Then      ' For 'narrow' pictures, set height equal to height of the slide
                .Height = sh
                .Left = 0
                .Top = 0
            ElseIf a <= sa Then ' For 'wide' pictures, set width equal to width of the slide
                .Width = sw
                .Left = 0
                nh = .Height    ' New height of the picture after cropping and resizing
                .Top = sh - nh  ' Align to bottom of the slide
            End If
            .ZOrder msoSendToBack
        End With
End Sub

This version of the code also resizes the picture to 'fill' the slide.

Incidentally, I was motivated to resume working on the problem after I had switched from Windows Vista to Windows 7 and found that my previously coded macros suddenly didn't work either. But in Windows 7, I found that height, width, etc. did behave as I expected them to. Perhaps there was something fishy about the settings in my previous OS (Windows Vista).

Answer 2

If the intent is to crop 182 points from the left, keep only the next 665 points, and crop everything else from the right, then all you need to do is change one sign, replacing:

oPic.PictureFormat.CropRight = oWidthPoints - L + 665

with

oPic.PictureFormat.CropRight = oWidthPoints - L - 665

the algebra is: oWidthPoints = leftCrop + middle + rightCrop, so

rightCrop = oWidthPoints - leftCrop - middle

In a similar fashion, replace:

oPic.PictureFormat.CropBottom = oHeightPoints - T + 318

with

oPic.PictureFormat.CropBottom = oHeightPoints - T - 318