Excel VBA Image EXIF Orientation

问题

Made this macro that inserts images from the active directory into an excel spreadsheet and scales it down to fit in the cell. It works pretty well except for images that come from a source were their orientation/rotation is defined in the EXIF data. So in:

In Windows Explorer - Not rotated
Window Picture viewer - Not rotated
IE - Not Rotated
Chrome - Rotated
EXCEL - Rotated

It's all due to some legacy issue from the camera that the image was taken from. Somebody post a similar problem but it got labelled as a duplicate, incorrectly, and has been ignored since. I did find this obscure post were somebody linked an exif reader class, I tested it and it gave me the same Orientation value for all my images.

The Problems: the photo gets rotated properly (YAY!), but its position is 35-80 columns to the right (Boo!) and/or 200 rows down, and the scaling is off because it mixes the width and height fields (Boo! x2).

Here's my Code:

For Each oCell In oRange
        If Dir(sLocT & oCell.Text) <> "" And oCell.Value <> "" Then
        'Width and Height set to -1 to preserve original dimensions.
            Set oPicture = oSheet.Shapes.AddPicture(Filename:=sLocT & oCell, LinktoFile:=msoFalse, savewithdocument:=msoTrue, Left:=oCell.Left + 10, Top:=oCell.Top + 10, Width:=-1, Height:=-1)

            oPicture.LockAspectRatio = True

        'Scales it down  
            oPicture.Height = 200
        'Adds a nice margin in the cell, useless             
            oCell.RowHeight = oPicture.Height + 20
            oCell.ColumnWidth = oPicture.Width / 4
        Else

            oCell.Offset(0, 1).Value = ""
        End If
        Next oCell

Image dimensions can be variable from unknown sources (but I'm pretty sure we can blame Samsung on this one). Looking for a solution and/or an explanation without the need of a 3rd party application.

Here's a sample of the images to try out, the first image works properly, the others don't.

回答1:

You have to check the rotation to see if you have to adjust height or Width (Top or Left)

Adjust your loop as follows:

For Each oCell In oRange
        If Dir(sloct & oCell.Text) <> "" And oCell.Value <> "" Then
          Set oPicture = osheet.Shapes.AddPicture(Filename:=sloct & oCell, LinktoFile:=msoFalse, savewithdocument:=msoTrue, Left:=oCell.Left + 10, Top:=oCell.Top + 10, Width:=-1, Height:=-1)

          With oPicture
                .LockAspectRatio = True
            If .Rotation = 0 Or .Rotation = 180 Then
                .Height = 200
                 oCell.RowHeight = .Height + 20
                 oCell.ColumnWidth = .Width / 4
                .Top = oCell.Top
                .Left = oCell.Left
            Else
                .Width = 200
                oCell.RowHeight = .Width + 20
                oCell.ColumnWidth = .Height / 4
                .Top = oCell.Top + ((.Width - .Height) / 2)
                .Left = oCell.Left - ((.Width - .Height) / 2)
            End If

           End With
        Else
            oCell.Offset(0, 1).Value = ""
        End If
        Next oCell

来源：https://stackoverflow.com/questions/51400088/excel-vba-image-exif-orientation

标签

excel

vba

image

excel-vba

image-scaling