Solved

excel 2007 image

Posted on 2014-10-26
10
116 Views
Last Modified: 2014-11-26
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.
0
Comment
Question by:Hank11
  • 5
  • 4
10 Comments
 
LVL 3

Expert Comment

by:Sandeep Khanagwal
ID: 40405773
0
 

Author Comment

by:Hank11
ID: 40405782
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
 
LVL 21

Expert Comment

by:Ejgil Hedegaard
ID: 40406531
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
Create the perfect environment for any meeting

You might have a modern environment with all sorts of high-tech equipment, but what makes it worthwhile is how you seamlessly bring together the presentation with audio, video and lighting. The ATEN Control System provides integrated control and system automation.

 

Author Comment

by:Hank11
ID: 40407654
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
 
LVL 21

Accepted Solution

by:
Ejgil Hedegaard earned 500 total points
ID: 40408649
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
 

Author Comment

by:Hank11
ID: 40461524
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
 
LVL 21

Expert Comment

by:Ejgil Hedegaard
ID: 40462510
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
 

Author Comment

by:Hank11
ID: 40463543
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
 

Author Comment

by:Hank11
ID: 40466128
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
 
LVL 21

Expert Comment

by:Ejgil Hedegaard
ID: 40467493
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

Featured Post

Connect further...control easier

With the ATEN CE624, you can now enjoy a high-quality visual experience powered by HDBaseT technology and the convenience of a single Cat6 cable to transmit uncompressed video with zero latency and multi-streaming for dual-view applications where remote access is required.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Recently Microsoft released a brand new function called CONCAT. It's supposed to replace its predecessor CONCATENATE. But how does it work? And what's new? In this article, we take a closer look at all of this - we even included an exercise file for…
My experience with Windows 10 over a one year period and suggestions for smooth operation
This video shows where to find templates, what they are used for, and how to create and save a custom template using Microsoft Word.
Excel styles will make formatting consistent and let you apply and change formatting faster. In this tutorial, you'll learn how to use Excel's built-in styles, how to modify styles, and how to create your own. You'll also learn how to use your custo…

820 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question