Question

我想创建一个PowerPoint VBA脚本，插入图片，使它们被裁剪为相对于图像顶部和左侧的固定大小。作为起点，我想采用以下VBA脚本：

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

此VBA脚本插入图片＆＃39; newpic.png＆＃39;，表示窗口的屏幕抓取，并从边缘裁剪固定数量（表示窗口的边框）。如果我想要的确实是整个窗口，这样可以正常工作。

然而，现在，我想制作另一个VBA脚本，该脚本插入窗口的某个部分，该窗口具有相对于窗口左上角固定的大小和位置。然而，问题是＆＃34; CropRight＆＃34;和＆＃34; CropBottom＆＃34;现在取决于窗口的大小。我尝试过以下方法：

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

据我所知，＆＃34; CropLeft＆＃34;以点为单位（= 1/72英寸）表示＆＃34;。宽度＆＃34;等等。和＆＃34; .Height＆＃34;属性以像素表示;这就是为什么我将转换系数从72/96转换为将图片的宽度从像素转换为点的原因。

这个想法是，通过考虑从右边裁剪的图像宽度，裁剪的图像部分应该看起来相同，而不管窗口的大小。然而，我发现情况并非如此，我可能有一些缩放因素错误。任何人都可以看到问题吗？

Answer 1

如果目的是从左侧裁剪182点，只保留接下来的665点，并从右侧裁剪其他所有内容，那么您需要做的就是更改一个标志，替换：

oPic.PictureFormat.CropRight = oWidthPoints - L + 665

带

oPic.PictureFormat.CropRight = oWidthPoints - L - 665

代数是： oWidthPoints = leftCrop + middle + rightCrop，所以

rightCrop = oWidthPoints - leftCrop - middle

以类似的方式，替换：

oPic.PictureFormat.CropBottom = oHeightPoints - T + 318

带

oPic.PictureFormat.CropBottom = oHeightPoints - T - 318

Answer 2

我设法解决了一个特殊情况的问题，即一个固定宽度的图片的一部分。这是代码：

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

此版本的代码还会调整图片大小以“填充”幻灯片。

顺便说一句，在我从Windows Vista切换到Windows 7之后，我有动力继续解决这个问题，并发现我之前编码的宏突然也无法正常工作。但在Windows 7中，我发现高度，宽度等确实表现得像我预期的那样。也许我以前的操作系统（Windows Vista）中的设置有些可疑。

从VBA中的图片中裁剪固定区域

2 个答案: