Question

我在Powerpoint（2016）中创建了一个userform，允许用户选择一些带有filedialog的图片。文件名存储在列表框和集合中的绝对路径中。选择条目后，图片应显示在用户窗体中（如预览）。因此我使用帧控制。

因为大多数图片都是png，所以我使用GDI库将文件作为位图加载并将其转换为IPicture对象。之后我只需要将IPicture对象设置为控件的Picture属性。这些工作正常，图片显示正确。

我的问题是图像的分辨率很高（例如1600x1200），我想调整图像的大小。我的第一种方法是设置PictureSizeMode，但PNG变得不可读。似乎 PictureSizeModeZoom 会扭曲图像。如果我使用 fmPicturesizeModeClip 并减小缩放值，则会产生相同的效果。

搜索网页后，我发现了一些关于渲染方法（IPicture::Render (MSDN)）的帖子。我使用间谍程序来确定我的帧的句柄，然后以较低的分辨率渲染图像。不幸的是，图片仍然不可读，与其他方法看起来相同。

图像包含一些带有描述标签和图例的测量图。至少描述标题应该是可读的。如果我用paint更改大小并将图像加载到userform后它看起来就像我想要的那样，但这对我来说不是一个解决方案！

有没有其他方法可以使用VBA减小图像的大小并保持其可读性？

感谢您的帮助！

更新这是我在谷歌上发现的linked picture的两个png版本。第一个尺寸为1920x921（从框架控制自动减小），第二个尺寸为400x192（用油漆减少）。两者都加载到尺寸为400x192的框架中。

以下代码声明了所有库。

'@author    Stephen Bullen, Rob Bovey
'@url       http://www.rondebruin.nl/win/s2/win009.htm

'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

#If VBA7 Then
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        Size As Long
        Type As Long
        hPic As LongPtr
        hPal As LongPtr
    End Type

    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type

    'Windows API calls into the GDI+ library
    Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As LongPtr, bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As LongPtr, hbmReturn As LongPtr, ByVal background As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal image As LongPtr) As Long
    Private Declare PtrSafe Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr)
    Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#Else
    'Declare a UDT to store the bitmap information
    Private Type PICTDESC
        Size As Long
        Type As Long
        hPic As Long
        hPal As Long
    End Type

    'Declare a UDT to store the GDI+ Startup information
    Private Type GdiplusStartupInput
        GdiplusVersion As Long
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
        SuppressExternalCodecs As Long
    End Type

    'Windows API calls into the GDI+ library
    Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdipCreateBitmapFromFile Lib "GDIPlus" (ByVal filename As Long, bitmap As Long) As Long
    Private Declare Function GdipCreateHBITMAPFromBitmap Lib "GDIPlus" (ByVal bitmap As Long, hbmReturn As Long, ByVal background As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal image As Long) As Long
    Private Declare Sub GdiplusShutdown Lib "GDIPlus" (ByVal token As Long)
    Private Declare Function OleCreatePictureIndirect Lib "oleaut32" (PicDesc As PICTDESC, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
#End If

这里有方法：

'@brief     Showing the image with the given path
Private Sub showImage(ByVal path As String)
    LoadPictureGDI Frame1, path
End Sub

' Procedure:    LoadPictureGDI
' Purpose:      Loads an image using GDI+
' Returns:      The image as an IPicture Object
Public Sub LoadPictureGDI(ByVal c As Object, ByVal sFilename As String)

    Dim uGdiInput As GdiplusStartupInput
    Dim lResult As Long
#If VBA7 Then
    Dim hGdiPlus As LongPtr
    Dim hGdiImage As LongPtr
    Dim hBitmap As LongPtr
#Else
    Dim hGdiPlus As Long
    Dim hGdiImage As Long
    Dim hBitmap As Long
#End If

    'Initialize GDI+
    uGdiInput.GdiplusVersion = 1
    lResult = GdiplusStartup(hGdiPlus, uGdiInput)

    If lResult = 0 Then

        'Load the image
        lResult = GdipCreateBitmapFromFile(StrPtr(sFilename), hGdiImage)

        If lResult = 0 Then

            'Create a bitmap handle from the GDI image
            lResult = GdipCreateHBITMAPFromBitmap(hGdiImage, hBitmap, 0)

            'Create the IPicture object from the bitmap handle
            'and show it in the frame.
            Set c.Picture = CreateIPicture(hBitmap)

            'Tidy up
            GdipDisposeImage hGdiImage
        End If

        'Shutdown GDI+
        GdiplusShutdown hGdiPlus
    End If
End Sub


' Procedure:    CreateIPicture
' Purpose:      Converts a image handle into an IPicture object.
' Returns:      The IPicture object
#If VBA7 Then
Private Function CreateIPicture(ByVal hPic As LongPtr) As IPicture
#Else
Private Function CreateIPicture(ByVal hPic As Long) As IPicture
#End If
    Dim lResult As Long
    Dim uPicInfo As PICTDESC
    Dim IID_IDispatch As GUID
    Dim IPic As IPicture

    'OLE Picture types
    Const PICTYPE_BITMAP = 1

    ' Create the Interface GUID (for the IPicture interface)
    With IID_IDispatch
        .Data1 = &H7BF80980
        .Data2 = &HBF32
        .Data3 = &H101A
        .Data4(0) = &H8B
        .Data4(1) = &HBB
        .Data4(2) = &H0
        .Data4(3) = &HAA
        .Data4(4) = &H0
        .Data4(5) = &H30
        .Data4(6) = &HC
        .Data4(7) = &HAB
    End With

    ' Fill uPicInfo with necessary parts.
    With uPicInfo
        .Size = Len(uPicInfo)
        .Type = PICTYPE_BITMAP
        .hPic = hPic
        .hPal = 0
    End With

    ' Create the Picture object.
    lResult = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)

    ' Return the new Picture object.
    Set CreateIPicture = IPic

End Function

Answer 1

从你的例子中可以看出，表格正在简单地缩小图像尺寸（基本上是抛出像素），其中Paint是下采样，会使图像看起来更柔和，但会更好地保留精细像你的图像一样的细节。

您可以使用像FreeImage这样的图像处理库对原始图像进行缩减采样，以便在表单上使用。

加载/调整png图像大小并以userform

1 个答案: