Problem with picture size when hiding columns

[klarowe]

Right now I have teardown reports that have a simple "insert picture" button to make things easier. It works great with all columns unhidden. However when I try to hide all outside columns to clean up the report a bit, it is throwing the picture sizes all off.
This is what I have now (working fine):

This is what happens when I hide the outside columns:

And here is the code I have:

Sub LoadMultipleImages()
    Dim arrSelected()   As String
    Dim i               As Long
    Dim rngDest         As Range
    Dim objPic          As Object
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg"
        .InitialFileName = CurDir
        .FilterIndex = 2
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                ReDim Preserve arrSelected(1 To i)
                arrSelected(i) = .SelectedItems(i)
            Next
        Else
            Exit Sub
        End If
    End With
    Set rngDest = Range("A65536").End(xlUp).Offset(4, 0)
    For i = 1 To UBound(arrSelected)
        Set objPic = ActiveSheet.Pictures.Insert(arrSelected(i))
        With objPic
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Width = 215#
        End With
        objPic.Cut
        ActiveSheet.PasteSpecial Format:="Picture (GIF)", Link:=False, DisplayAsIcon:=False
        Selection.Left = rngDest.Left
        Selection.Top = rngDest.Top
        Set rngDest = rngDest.Offset(1 + (Selection.Height \ 15))
    Next
End Sub

So how can I alter the size so that it does not take the hidden columns into affect. I have to leave the aspect ratio locked because some pictures will be taken horizontally, and some will be taken vertically. So I can't just lock in a set width and height.

Any help is appreciated.

 

[Gary McMaster]

Have a look at "GroupItem" in VBA help. It will let you address individual items inside a group of shapes.

Keep in mind this is only a guess. I don't want to send you on a wild goose chase. I've had problems with grouped shapes because the behave as though they are a single shape.

Gary

 

[klarowe]

I looked into it and it doesn't seem like its a grouping issue as far as I can tell. it seems to me that for whatever reason the width/height are being controlled by the sheet almost like a ratio... but then again, the location of the selected cell is affecting it also...

 

[klarowe]

any other ideas?

 

[klarowe]

Well this is the final "issue" for now for these reports. Granted, its something I can do without if needed but there has to be a way to be able to hide the unused columns without affecting the images... right?????

 

[Gary McMaster]

I can't duplicate that behavior in XL2000. If I set the placement to "Move but don't size" the image does not distort no matter how many columns I hide.

I did notice that there is a page break running through the middle of your distorted image. Probably effect rather than cause but who knows?

Gary

 

[Andrew Poulsom]

I've run your code in Excel 2003 and 2007 and can't reproduce the behaviour you are seeing. Something else must be going on in your workbook. Can you reproduce it in a new workbook?

 

[Gary McMaster]

Why do you insert the picture then cut it and then paste it back in again? That seems like a rather strange operation. Perhaps it is the source of the problem.

Gary

    For i = 1 To UBound(arrSelected)
        Set objPic = ActiveSheet.Pictures.Insert(arrSelected(i))
        With objPic
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Width = 215#
        End With
        objPic.Cut
        ActiveSheet.PasteSpecial Format:="Picture (GIF)", Link:=False, DisplayAsIcon:=False
        Selection.Left = rngDest.Left
        Selection.Top = rngDest.Top
        Set rngDest = rngDest.Offset(1 + (Selection.Height \ 15))
    Next

 

[klarowe]

I can't duplicate that behavior in XL2000. If I set the placement to "Move but don't size" the image does not distort no matter how many columns I hide.
Gary

I've run your code in Excel 2003 and 2007 and can't reproduce the behaviour you are seeing. Something else must be going on in your workbook. Can you reproduce it in a new workbook?

I went through it and apparently it is only doing it when the columns are already hidden. If I insert then hide the columns the pictures do not change.

Why do you insert the picture then cut it and then paste it back in again? That seems like a rather strange operation. Perhaps it is the source of the problem.

Gary

Because these reports get emailed to the customer and with having the standard picture inserted, after 20 some pages all with 2-3 pictures the file size was getting astronomical. So I use the cut, paste as a GIF file to "dumb" down the pictures some and reduce their size. Because they are relatively small, the added distortion is barely noticeable but the size is cut greatly.

I believe I have found a work around for it. It works in my test report, but it's just adding about another 5 seconds to the overall running...which isn't horrible, but if I can find a better way it will make things easier. Here is what I have now:

Sub LoadMultipleImages()
    Dim arrSelected()   As String
    Dim i               As Long
    Dim x               As Long
    Dim rngDest         As Range
    Dim objPic          As Object
 
    Application.ScreenUpdating = False
 
 
    With Application.FileDialog(msoFileDialogFilePicker)
        .AllowMultiSelect = True
        .Filters.Add "Images", "*.gif; *.jpg; *.jpeg"
        .InitialFileName = CurDir
        .FilterIndex = 2
        If .Show = -1 Then
            For i = 1 To .SelectedItems.Count
                ReDim Preserve arrSelected(1 To i)
                arrSelected(i) = .SelectedItems(i)
            Next
        Else
            GoTo Er
        End If
    End With
    Set rngDest = Range("A65536").End(xlUp).Offset(4, 0)
    For i = 1 To UBound(arrSelected)
        Set objPic = ActiveSheet.Pictures.Insert(arrSelected(i))
        With objPic
            .Placement = xlMoveAndSize
            .ShapeRange.LockAspectRatio = msoTrue
            .ShapeRange.Width = 215#
        End With
        objPic.Cut
        ActiveSheet.PasteSpecial Format:="Picture (GIF)", Link:=False, DisplayAsIcon:=False
        Selection.Left = rngDest.Left
        Selection.Top = rngDest.Top
        Set rngDest = rngDest.Offset(1 + (Selection.Height \ 13))
    Next
 
Er:    For x = 11 To Columns.Count
        ActiveSheet.Columns(x).EntireColumn.Hidden = True
    Next x
 
    Application.ScreenUpdating = True
End Sub

I added:

    For x = 11 To Columns.Count
        ActiveSheet.Columns(x).EntireColumn.Hidden = False '(/True)
    Next x

to the beginning and end of the macro (with an "error handler" so to speak to account for someone pressing cancel when inserting pictures).

Thanks again guys... hopefully we can find something a little quicker!