I've written a script to change all images in many hundreds of Excel documents to a .png format in order to reduce their file size (the largest were coming up on 25MB).

If the images in the Excel document are not in their original orientation i.e., if they have been rotated since being inserted in the document, then the new .png images, when added to the document, are distorted. They appear too flat and wide.

The process by which the images are changed is:

  1. Iterating through all workbooks in the directory
  2. Iterating through each sheet in the workbook
  3. Iterating through all shapes in the worksheet (Worksheet.Shapes)
  4. Extracting the shape size and location with Shape.Width, .Height, .Top, and .Left
  5. Copying the shape to the Clipboard and storing into a variable of type Bitmap
  6. Making Color.White transparent
  7. Saving as a .png
  8. Deleting the old shape (Shape.Delete)
  9. Inserting the new image (Shapes.AddPicture)
  10. Saving and closing the document

What I believe to be the relevant code is as shown below:

' Iterate over each sheet in the current workbook
                    For Each xlsSheet In xlsBook.Worksheets
                        xlsSheet.Unprotect() ' Unprotect the worksheet for editing

                        ' Iterate over each Shape in the current worksheet
                        For Each xlsShape As Excel.Shape In xlsSheet.Shapes
                            copied = False

                            While Not copied
                                    If Not xlsShape.Name.Contains("Drop Down") Then ' Ignore images with name containing Drop Down (not sure what this is)

                                        ' Store Shape properties
                                        shapeLeft = xlsShape.Left
                                        shapeTop = xlsShape.Top
                                        shapeWidth = xlsShape.Width
                                        shapeHeight = xlsShape.Height
                                        xlsShape.Copy() ' Copy the shape to the Clipboard

                                        If Clipboard.ContainsImage Then
                                            img = Clipboard.GetImage ' Store the image in a variable
                                            img.MakeTransparent(Color.White) ' Use White as the transparent colour
                                            imgName = temporaryImageLocation & xlsShape.Name & ".png"
                                            img.Save(imgName, ImageFormat.Png) ' Save the image in a temporary location (as a .png file)
                                            xlsShape.Delete() ' Delete the current Shape and replace it with the new .png file
                                            xlsSheet.Shapes.AddPicture(imgName, MsoTriState.msoFalse, MsoTriState.msoCTrue, shapeLeft, shapeTop, shapeWidth, shapeHeight)
                                            File.Delete(imgName) ' Delete the .png file in the temporary location
                                        End If
                                    End If

                                    copied = True
                                Catch ex As System.Runtime.InteropServices.COMException
                                End Try
                            End While


I've thought that perhaps the code is extracting the original height and width (which will have the inverse aspect ratio of the rotated image), but this isn't the case (I've checked other documents where the images appear just fine, despite having different original sizes). I've also extracted the images manually, saved as a .png, and reinserted (so that the images are now 'not rotated') before running the code and the images then appear to be just fine.

After checking maybe a dozen or so Excel documents that have been 'compressed' as expected, I'm pretty sure this has something to do with the image rotation in the original Excel document. I don't know how to work around this so that, in future, if the code comes across a rotated image, it doesn't falter.

I've tried extracting the Shape.Rotation value and rotating the shape with Shape.IncrementRotation(-Shape.Rotation). The issue with this is that the original shape is deleted and a new one added. I've tried creating an ArrayList to keep track of the shape names and the corresponding rotation on the original shape, but the shape names are changed upon deletion of the original shape and addition of the new shape. I'm not sure what Excel's naming convention for this is. I've also tried something similar by keeping track of the Shape.Left and Shape.Top values, but this doesn't seem to work either.

In other words, I'm finding it difficult to keep track of which rotation value is associated with which picture in the Excel document.

3 Years
Discussion Span
Last Post by Eruditio

The issue I was having with comparing the Shape.Top and Shape.Left values to stored values is that I was trying to compare a Single to a String. This wasn't working, so comparing instead to Shape.Top.ToString and Shape.Left.ToString solved the comparison issue.

I think I'm close to fixing the problem (some of the images still aren't rotating properly, but most are), but if there are any suggestions for a simpler way to do this, or perhaps any suggestions as to why this is even happening, would be appreciated.


The issue has been solved. The images that weren't being rotated correctly were those that originally (for whatever reason) had a negative Shape.Left or Shape.Top property. They could be reinserted at their correct position by first rotating and then incrementing their left or top property (accordingly) by the negative value stored.

For posterity:

If rotated Then
     For Each xlsShape As Excel.Shape In xlsSheet.Shapes
          For Each element As String In rotationInfo
               If element.Split(vbTab)(0) = xlsShape.Left.ToString And element.Split(vbTab)(1) = xlsShape.Top.ToString Then
               ElseIf element.Split(vbTab)(0) < 0 And element.Split(vbTab)(1) = xlsShape.Top.ToString Then
               ElseIf element.Split(vbTab)(0) = xlsShape.Left.ToString And element.Split(vbTab)(1) < 0 Then
               ElseIf element.Split(vbTab)(0) < 0 And element.Split(vbTab)(1) < 0 Then
               End If
End If

where rotationInfo contains, as a String: shapeLeft & vbTab & shapeTop & vbTab & shapeRotation.

This question has already been answered. Start a new discussion instead.
Have something to contribute to this discussion? Please be thoughtful, detailed and courteous, and be sure to adhere to our posting rules.