excel 2007 image

Have images auto copied from one excel file to another. Once images copied into the destination master excel file, need to run VBA to auto-size image and center inside cell.
Hank IsaacsEngineerAsked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Hank IsaacsEngineerAuthor Commented:
We already have VBA that copies images from one xls to another xls where it places them in the correct corresponding cell in the upper left corner.  After copying to destination (which works great), some images are larger than the cell and hang over the cell - while other images are smaller than the cell and we want enlarge to fit in the cell.  The cells are formatted to be the same size since this is a report.
0
Ejgil HedegaardCommented:
Insert this in a module.

Option Explicit

Sub FitPictureToCell()
    Dim ws As Worksheet
    Dim sh As Shape
    Dim rw As Integer, col As Integer
    Dim rg As Range
    Dim rwHeigth As Single, colWidth As Single
    
    Set ws = Worksheets("QA")
    Application.ScreenUpdating = False
    For Each sh In ws.Shapes
        If sh.TopLeftCell.Row > 1 Then
            rw = sh.TopLeftCell.Row
            col = sh.TopLeftCell.Column
            Set rg = ws.Range(Cells(rw, col), Cells(rw, col))
            rwHeigth = ws.Rows(rw).Height
            colWidth = ws.Columns(col).Width
            If col = 2 Then
                colWidth = colWidth + ws.Columns(col + 1).Width
            End If
            If sh.Height / rwHeigth > sh.Width / colWidth Then
                sh.Height = rwHeigth - 2
            Else
                sh.Width = colWidth - 2
            End If
            sh.Top = rg.Top + (rwHeigth - sh.Height) / 2
            sh.Left = rg.Left + (colWidth - sh.Width) / 2
        End If
    Next sh
    Application.ScreenUpdating = True
End Sub

Open in new window

0
The Ultimate Tool Kit for Technolgy Solution Provi

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy for valuable how-to assets including sample agreements, checklists, flowcharts, and more!

Hank IsaacsEngineerAuthor Commented:
You cleaned up the row adjustment module.  Can this be included as part of that execution? Rows and Pics? If so, how would I ass this code to that module?
0
Ejgil HedegaardCommented:
Replace all in the row adjustment module with this, or insert in another module.
Change the macro for the button "Auto Row Adj".
Right click on button and attach the macro.

Option Explicit

Sub Auto_Row_Height_Picture_Fit()
    Dim rw As Integer, rwMax As Integer, col As Integer
    Dim MrgAddr As String
    Dim rngMergeArea As Range, c As Range
    Dim MrgWidth As Double, rwHeight As Double, cellWidth As Double, colWidth As Single
    Dim ws As Worksheet
    Dim sh As Shape
    Dim PictureNbr As Integer, PictureTotalNbr As Integer
    Dim rg As Range
    
    Set ws = Worksheets("QA")
    Application.ScreenUpdating = False
    
    'Adjust row height in rows with Status in column B
    rwMax = ws.UsedRange.Rows.Count
    frmStatus.Show vbModeless
    frmStatus.Label1 = "Adjusting row height for Status"
    For rw = 1 To rwMax
        If Range("B" & rw) = "Status" Then
            frmStatus.Label2 = "Row " + CStr(rw) + " of " + CStr(rwMax)
            DoEvents
            MrgAddr = Range("C" & rw).MergeArea.Address
            Set rngMergeArea = Range(MrgAddr)
            With rngMergeArea
                .UnMerge
                cellWidth = .Cells(1).ColumnWidth
                MrgWidth = 0
                For Each c In rngMergeArea
                    c.WrapText = True
                    MrgWidth = c.ColumnWidth + MrgWidth
                Next
                .Cells(1).ColumnWidth = MrgWidth
                .EntireRow.AutoFit
                rwHeight = .RowHeight
                .Cells(1).ColumnWidth = cellWidth
                .MergeCells = True
                .RowHeight = rwHeight
            End With
        End If
    Next rw
    
    'Adjust pictures to fit in cells
    frmStatus.Label1 = "Adjusting picture to fit in cells"
    PictureTotalNbr = ws.Shapes.Count
    PictureNbr = 0
    For Each sh In ws.Shapes
        If sh.TopLeftCell.Row > 1 Then
            PictureNbr = PictureNbr + 1
            frmStatus.Label2 = "Picture number " + CStr(PictureNbr) + " of " + CStr(PictureTotalNbr)
            DoEvents
            rw = sh.TopLeftCell.Row
            col = sh.TopLeftCell.Column
            Set rg = ws.Range(Cells(rw, col), Cells(rw, col))
            rwHeight = ws.Rows(rw).Height
            colWidth = ws.Columns(col).Width
            If col = 2 Then
                colWidth = colWidth + ws.Columns(col + 1).Width
            End If
            If sh.Height / rwHeight > sh.Width / colWidth Then
                sh.Height = rwHeight - 2
            Else
                sh.Width = colWidth - 2
            End If
            sh.Top = rg.Top + (rwHeight - sh.Height) / 2
            sh.Left = rg.Left + (colWidth - sh.Width) / 2
        End If
    Next sh
    Application.ScreenUpdating = True
    Unload frmStatus
End Sub

Open in new window

0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Hank IsaacsEngineerAuthor Commented:
Ejgil,

I'm getting a Run-time error '5' "Invalid procedure call or argument" on the weekly master file.  When I debug, it highlights "FilenameAgent = Dir" about 10 lines from the bottom.

How can we fix?  I looked at the agents folder and files, and nothing seems to have changed. What would have caused this?

Thanks,
-Hank
0
Ejgil HedegaardCommented:
Probably you have an agent folder with no file.

The check for "no more files to use in agent folder" is done after the code has run once.
This changes it to check before the first run (for each agent).

Change 2 lines.
1. Look for (about 10 lines after the comment 'Copy pictures from agent file)
        FilenameAgent = Dir(PathAgentFile + "*.xlsx")
        Do
Change the second line with Do to
Do While FilenameAgent <> ""

2. Just below the line with the error.
Remove Until FilenameAgent = "" in the statement
Loop Until FilenameAgent = ""
so it is only Loop
0
Hank IsaacsEngineerAuthor Commented:
Its fixed now.  I started looking at the agents files and noticed one of the agents "saved-as" to older type  *.xls instead of *.xlsx for newer files. I corrected and the picture mapping started working again.

Thank you again, Ejgil.
0
Hank IsaacsEngineerAuthor Commented:
Hi Ejgil,

One more question.

The auto row height stopped working and I'm not sure why.  No errors messages. When I execute it runs through the process (slowly) completes, no errors and none of the rows adjust. I'm a little stumped on this.

Thanks,
-Hank
0
Ejgil HedegaardCommented:
Without more information it is impossible to tell why adjustment does not work now.
It worked before, so clearly something has been changed.
The function loops all rows from 1 to the last used row, looks for the word Status in column B, and adjust the merged cells in column C for that row.

To see the process, set a ' in front of the line
Application.ScreenUpdating = False
The ' makes it a comment doing nothing, and the line turns green.
and insert
Range("B" & rw).Select
just after the line
If Range("B" & rw) = "Status" Then

You should see the cells unmerge, column C expand width, adjust row height and merge the cells again.  
It will be quite slow, so save the workbook before the changes, so you can stop the code (Ctrl+Break) and quit the workbook without save if needed.

The speed could depend on the calculation.
Are other workbooks open?
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Office Productivity

From novice to tech pro — start learning today.