Question

我有一个脚本，可以选择一个文件夹并以不同的图像格式加载单个或多个图像。

然后，它创建一个两列表格，并将加载的图像放在左列。

在右列中，显示文件名和原始图像大小。但我无法以像素为单位计算正确的图像大小。

这是我的剧本；问题开始于以下评论：

'Image height and width

On Error GoTo fehler
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
Dim pic As InlineShape, bildname As String, pfad As String, details As String
Dim bildHoehePt As Single, bildbreitePt As Single
Dim faktor As Single, origbreitePt As Single, origbreiteCm As Single, orighoehePt As Single, orighoeheCm As Single

'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files And click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        
                If .Show = -1 Then
                    ' Add a 'Picture' caption label
                    CaptionLabels.Add Name:="Picture"
                    'Add a 1-row by 3-column table with same width to take the images
                    Set oTbl = Selection.Tables.Add(Selection.Range, 1, 3)
                    
                        With oTbl
                            .AutoFitBehavior (wdAutoFitFixed)
                            .Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 1 / 3, RulerStyle:=wdAdjustProportional
                            .Borders.Enable = True
                        End With
                    
                    For i = 1 To .SelectedItems.Count
                        ' Add extra rows as needed
                        With oTbl
                            If i > .Rows.Count Then oTbl.Rows.Add
                        With .Rows(i)
                            .Range.Style = "Normal" 'In a German Word version, change "Normal" to "Standard"
                            .Cells(1).Range.Text = vbCr
                            .Cells(1).Range.Characters.Last.Style = "Caption" 'In a German Word version, change "Caption" to "Beschriftung"
                        End With
                    End With
                
                    'Insert the Picture
                    Set pic = ActiveDocument.InlineShapes.AddPicture(FileName:=.SelectedItems(i), _
                        LinkToFile:=False, SaveWithDocument:=True, _
                        Range:=oTbl.Cell(i, 1).Range.Characters.First)
                    ' Image name and path
                     pfad = .SelectedItems(i)
                    bildname = Mid(pfad, InStrRev(pfad, "\", -1) + 1)
                    MsgBox "Pfad " & pfad & vbLf & "Filename: " & bildname
                    
                    'Image height and width
                    bildbreitePt = pic.Width
                    bildHoehePt = pic.Height
                    
                    ' Scale factor
                    faktor = pic.ScaleWidth
                    'Original size
                    origbreitePt = bildbreitePt / faktor * 100 ' pt
                    orighoehePt = bildHoehePt / faktor * 100 'Pt
                    origbreiteCm = origbreitePt * 0.0353 'cm
                    orighoeheCm = orighoehePt * 0.0353
                
                   'Bilddetails zusammensetzen
               details = "Filename: " & bildname & vbLf & "ImageSize (cm): " & origbreiteCm & " x " & orighoeheCm & vbLf & _
                    "Scaling: " & faktor & "%" & " BildbreitePt: " & bildbreitePt & " OrigbreitePt: " & origbreitePt & " OrigbreitePX: " & origbreitePX

                    ' Insert the Caption on the line below the picture
                        With oTbl.Cell(i, 1).Range
                            .Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _
                                Position:=wdCaptionPositionAbove, ExcludeLabel:=False
                            .Characters.Last.Previous = vbNullString
                        End With
                        
                        'Writes the image details in column 2
                        oTbl.Cell(i, 2).Range = details
            Next
                
            End If
     End With
Application.ScreenUpdating = True
Exit Sub
fehler:
Application.ScreenUpdating = True
MsgBox "Fehler: " & Err.Number & ": " & Err.Description
End Sub```
**Can anyone help me to get the correct image size (width and length) in pixels?**
Thank you very much and best regards

Answer 1

以下函数将返回图像文件的尺寸（以像素为单位）。请注意，您需要将其与路径和图像文件名一起传递给Shell Application对象。

在调用过程中创建Shell Application对象并将其传递给被调用函数的原因是，您将在循环中使用它。如果是在调用的函数中创建的，则将不必要地创建多个Shell Application对象。

此外，请注意，当路径和/或图像文件名不存在时，该函数将返回错误值。但是，您将可以使用IsError函数测试错误。

这是功能...

Function GetImagePixelDimensions(ByVal shell_app As Object, ByVal path As String, ByVal image_filename As String) As Variant

    On Error GoTo error_handler

    Dim shell_folder As Object
    Set shell_folder = shell_app.Namespace(CVar(path)) 'Namespace requires a Variant
    
    Dim pixel_dimensions As String
    pixel_dimensions = shell_folder.ParseName(image_filename).ExtendedProperty("Dimensions")
    
    pixel_dimensions = Replace(pixel_dimensions, ChrW(8234), "") 'remove the LEFT-TO-RIGHT EMBEDDING invisible character
    pixel_dimensions = Replace(pixel_dimensions, ChrW(8236), "") 'remove the POP DIRECTIONAL FORMATTING invisible character
    
    GetImagePixelDimensions = pixel_dimensions
    
    Exit Function
    
error_handler:
    GetImagePixelDimensions = CVErr(2015) 'xlErrValue
    
End Function

这是如何调用函数的示例...

Sub test()

    Dim shell_app As Object
    Set shell_app = CreateObject("Shell.Application")
    
    Dim pixel_dimensions As Variant
    pixel_dimensions = GetImagePixelDimensions(shell_app, "c:\users\domenic\pictures", "image_filename.jpg")
    
    If Not IsError(pixel_dimensions) Then
        MsgBox "Dimensions: " & pixel_dimensions
    Else
        MsgBox "Unable to get the dimensions."
    End If
    
End Sub

相应地更改路径和图像文件名。

Answer 2

Max，我已经使用了Domenic的答案并将其与您的代码集成在一起。它似乎正常工作，并且为我使用的两个示例图像生成了以下文档（以下快照是针对创建的MS Word文档）：

我使用Paint.Net检查了图像尺寸，它们是正确的。我将MsgBox语句留在了代码中（注释掉了），以供您进行必要的测试。让我知道你是否有疑问。

您提到代码创建了两列；您的代码实际上创建了一个三列的表。我使用了一个名为ColumnCount的变量，您可以为其设置所需的列数。当前设置为两列。

您可以在此处下载MS Word宏文档和两个图像：https://1drv.ms/u/s!AjKDc68HR6lQkHlLfdPppPIAIgk9?e=UBdAy6

注意：我对Domenic的回答表示反对，希望您也可以这样做。

Sub Mumm()

On Error GoTo fehler
Application.ScreenUpdating = False
Dim oTbl As Table, i As Long, j As Long, k As Long, StrTxt As String
Dim pic As InlineShape, bildname As String, pfad As String, details As String
Dim bildHoehePt As Single, bildbreitePt As Single
Dim faktor As Single, origbreitePt As Single, origbreiteCm As Single, orighoehePt As Single, orighoeheCm As Single
Dim foldername As String
    
Dim Pos_of_x As Integer
Dim Width As Integer
Dim Height As Integer
Dim pixel_dimensions As Variant
Dim shell_app As Object
Dim ColumnCount As Integer

    ' Number of columns in the table
    ColumnCount = 2
    
    'Select and insert the Pics
    With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Select image files and click OK"
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
        .FilterIndex = 2
        
        If .Show = -1 Then
            ' Add a 'Picture' caption label
            CaptionLabels.Add Name:="Picture"
            
            'Insert table row.
            Set oTbl = Selection.Tables.Add(Selection.Range, 1, ColumnCount)
             
            With oTbl
                .AutoFitBehavior (wdAutoFitFixed)
                .Columns(1).SetWidth ColumnWidth:=.PreferredWidth * 1 / ColumnCount, RulerStyle:=wdAdjustProportional
                .Borders.Enable = True
            End With
            
            Set shell_app = CreateObject("Shell.Application")

            For i = 1 To .SelectedItems.Count
                
                ' Add extra rows as needed
                With oTbl
                    If i > .Rows.Count Then oTbl.Rows.Add
                        With .Rows(i)
                            .Range.Style = "Normal" 'In a German Word version, change "Normal" to "Standard"
                            .Cells(1).Range.Text = vbCr
                            .Cells(1).Range.Characters.Last.Style = "Caption" 'In a German Word version, change "Caption" to "Beschriftung"
                        End With ' .Rows(i)
                End With ' oTbl
         
                'Insert the Picture
                Set pic = ActiveDocument.InlineShapes.AddPicture(FileName:=.SelectedItems(i), _
                    LinkToFile:=False, SaveWithDocument:=True, _
                    Range:=oTbl.Cell(i, 1).Range.Characters.First)
                 
                ' Image name and path
                pfad = .SelectedItems(i)
                bildname = Mid(pfad, InStrRev(pfad, "\", -1) + 1)
                foldername = Left(pfad, InStrRev(pfad, "\"))
'                MsgBox _
'                    "pfad (image pathname): " & pfad & vbLf & _
'                    "foldername: " & foldername & vbLf & _
'                    "bildname (image filename): " & bildname
                
                'Image height and width
                pixel_dimensions = GetImagePixelDimensions(shell_app, foldername, bildname)
                
                Pos_of_x = InStr(pixel_dimensions, "x")
                Width = Mid(pixel_dimensions, 1, Pos_of_x - 2)
                Height = Mid(pixel_dimensions, Pos_of_x + 2, Len(pixel_dimensions))
'                MsgBox _
'                    "pixel_dimensions: " & pixel_dimensions & vbLf & _
'                    "Width: " & Width & vbLf & _
'                    "Height: " & Height
                bildbreitePt = Width
                bildHoehePt = Height
                
                ' Scale factor
                faktor = pic.ScaleWidth
                 
                'Original size
                origbreitePt = bildbreitePt / faktor * 100 ' pt
                orighoehePt = bildHoehePt / faktor * 100 'Pt
                origbreiteCm = origbreitePt * 0.0353 'cm
                orighoeheCm = orighoehePt * 0.0353
             
                'Bilddetails zusammensetzen
                details = "Filename: " & bildname & vbLf & "ImageSize (cm): " & origbreiteCm & " x " & orighoeheCm & vbLf & _
                    "Scaling: " & faktor & "%" & " BildbreitePt: " & bildbreitePt & " OrigbreitePt: " & origbreitePt & " OrigbreitePX: " & origbreitePX
    
                ' Insert the Caption on the line below the picture
                With oTbl.Cell(i, 1).Range
                    .Characters.Last.Previous.InsertCaption Label:="Picture", Title:=StrTxt, _
                        Position:=wdCaptionPositionAbove, ExcludeLabel:=False
                    .Characters.Last.Previous = vbNullString
                End With ' oTbl.Cell(i, 1).Range
                     
                'Writes the image details in column 2
                oTbl.Cell(i, 2).Range = details
            
            Next ' For i = 1 To .SelectedItems.Count
                    
        End If ' If .Show = -1 Then
        
    End With ' With Application.FileDialog(msoFileDialogFilePicker)
     
    Application.ScreenUpdating = True
    Exit Sub

fehler:
    Application.ScreenUpdating = True
    MsgBox "Fehler: " & Err.Number & ": " & Err.Description

End Sub

Function GetImagePixelDimensions(ByVal shell_app As Object, ByVal path As String, ByVal image_filename As String) As Variant

    ' From here: https://stackoverflow.com/a/62647100/
    Dim Pos_of_x As Integer
    Dim Width As Integer
    Dim Height As Integer

    On Error GoTo error_handler

    Dim shell_folder As Object
    Set shell_folder = shell_app.Namespace(CVar(path)) 'Namespace requires a Variant
    
    Dim pixel_dimensions As String
    pixel_dimensions = shell_folder.ParseName(image_filename).ExtendedProperty("Dimensions")
    
    pixel_dimensions = Replace(pixel_dimensions, ChrW(8234), "") 'remove the LEFT-TO-RIGHT EMBEDDING invisible character
    pixel_dimensions = Replace(pixel_dimensions, ChrW(8236), "") 'remove the POP DIRECTIONAL FORMATTING invisible character
    
    'Pos_of_x = InStr(pixel_dimensions, "x")
    'Width = Mid(pixel_dimensions, 1, Pos_of_x - 2)
    'Height = Mid(pixel_dimensions, Pos_of_x + 2, Len(pixel_dimensions))
    'MsgBox "pixel_dimensions: " & pixel_dimensions & vbLf & "Width: " & Width & vbLf & "Height: " & Height
    
    GetImagePixelDimensions = pixel_dimensions
    
    Exit Function
    
error_handler:
    GetImagePixelDimensions = CVErr(2015) 'xlErrValue
    
End Function

Sub test_GetImagePixelDimensions()

    Dim shell_app As Object
    Set shell_app = CreateObject("Shell.Application")
    
    Dim pixel_dimensions As Variant
    pixel_dimensions = GetImagePixelDimensions(shell_app, "C:\TMP\", "image_68_KB.jpg")
    
    If Not IsError(pixel_dimensions) Then
        MsgBox "Dimensions: " & pixel_dimensions
    Else
        MsgBox "Unable to get the dimensions."
    End If
    
End Sub

计算正确的图像尺寸

2 个答案: