Solved

excel 2007 image

Posted on 2014-10-26
10
114 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
 

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
Zoho SalesIQ

Hassle-free live chat software re-imagined for business growth. 2 users, always free.

 

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

Is Your Active Directory as Secure as You Think?

More than 75% of all records are compromised because of the loss or theft of a privileged credential. Experts have been exploring Active Directory infrastructure to identify key threats and establish best practices for keeping data safe. Attend this month’s webinar to learn more.

Question has a verified solution.

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

Suggested Solutions

Title # Comments Views Activity
IF OR formula Excel 8 41
recovering Excel 2016 file 2 50
OCT or Config.xml 2 32
Recover lost Hyperlink destination/target in OneNote 3 28
This article will show you how to use shortcut menus in the Access run-time environment.
Using Word 2013, I was experiencing some incredible lag when typing.  Here's what worked for me....
This video shows where to find templates, what they are used for, and how to create and save a custom template using Microsoft Word.
The viewer will learn how to create two correlated normally distributed random variables in Excel, use a normal distribution to simulate the return on different levels of investment in each of the two funds over a period of ten years, and, create a …

930 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

Need Help in Real-Time?

Connect with top rated Experts

9 Experts available now in Live!

Get 1:1 Help Now