How to use the Camera Icon Tool using a Macro?

[all4excel]

How to use the Camera Icon Tool using a Macro?

I want to copy the First Row which is the Column heading of one Sheet to a different Sheet
Example :
From Col A till Col G First Row is to be copied as an Image..
Normally I do it using the Camera Icon, however when I tried recording a Macro for the same it did not work..

So how do I that if I provide the Start Column and End Column Alphabet as a Variable is that possible..
I want this Image to not remain Volatile which is the case using the Camera Tool..

So, how do i get the picture of only the first row or any row and store it is an Image in a different sheet as static picture so that even when the sheet is moved to a different location it does not make a difference to the Image.

Thanks in advance..

 

[all4excel]

Hey Brother sorry for the late response..
Partially correct..
1. I want to copy the Image of the cell A1 from the Sheet Report. with following dimensions as mentioned earlier [ with the Column Width - 6.00 ( 73 pixels) and Row Height of 20.00 ( 40 pixels ) ].

2. This Image has to be Pasted in the cell G2 where the Column width need not be the same as the Parent cell mentioned above in Pt1.
Anyways, Precisely the dimensions are ( has the same Row Height and a Different Column Width of 26.00 ( 293 pixels ).. )

3. The Image Size needs to be smaller and noticeable and Ideally I would like to encase the cell G2 in Borders hoping to get this Image exactly in the center both Horizontal and Vertical..

Now I have followed the instructions but in vain...

Nothing has changed even the Name Remains the same as Picture and the latest No instead of "Picture-A1" etc

Al-Humdallah

 

[Mohammad Basem]

Please let us stick to one unit of measurements, which is Point as returned by both Width and Height properties.

So, the dimensions of cell A1 are 54.75 points (73 pixels) width × 30 points (40 pixels) height. This will be the size of the image as well.

You want G2 to have the same aforementioned height of 30 points, but with different width of 219.75 points (293 pixels).

Then the image size is reduced by 25% and centered in G2.

Please confirm the above.

Nothing has changed even the Name Remains the same as Picture and the latest No instead of "Picture-A1" etc

Have you made changes to the code? Could you please share sample file that show this?

 

[Mohammad Basem]

When an image is added on a sheet, it becomes the last shape (in count) and Shapes.Count represents index to the last added shape. That was the criterion used in ClickAndPaste_Adjust.

However, in your case the newly added image is inserted and not appended to the list of shapes, and, therefore, Shapes.Count does not point to the newly added image. The reason behind this is the Comment box. It seems Excel keeps the comments at the bottom of the shapes’ list, so any newly added image is relocated before the first comment box!

Another observation; Excel does not check for names’ conflict of added images. For example, if you have an image named "Picture 38", a newly added image might get the same name, so we end up with more than one image having the same name. To overcome this, simply rename images.

Here is the fixed code of ClickAndPaste_Adjust.

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Option Explicit

Sub ClickAndPaste_Adjust(ByVal rInputRng As Range, ByVal rOutputRng As Range)

    Const csngResizeNo As Single = 90 / 100     [COLOR="Green"]'* Image size adjustment[/COLOR]
    Const cbMarginSize As Byte = 2 * 1          [COLOR="Green"]'* Destination cell width = source cell width + cbMarginSize (1 = Margin size)[/COLOR]
    Dim blScreenUpdate As Boolean
    Dim sShapeName As String
    Dim sActivesheet As String

[COLOR="Green"]    '*
    '* Copy range[/COLOR]
    rInputRng.CopyPicture
[COLOR="Green"]    '*
    '* Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial
[COLOR="Green"]    '*
    '* Set the height of destination cell[/COLOR]
    With rOutputRng
        .RowHeight = rInputRng.RowHeight
        .ColumnWidth = rInputRng.ColumnWidth + cbMarginSize
    End With
[COLOR="Green"]    '*
    '* Get the name of pasted image[/COLOR]
    blScreenUpdate = Application.ScreenUpdating
    sActivesheet = ActiveSheet.Name
    Application.ScreenUpdating = False
    rOutputRng.Parent.Select
    sShapeName = Selection.Name
    Sheets(sActivesheet).Select
    Application.ScreenUpdating = blScreenUpdate
[COLOR="Green"]    '*
    '* Adjust image size and alignment[/COLOR]
    With Sheets(rOutputRng.Parent.Name).Shapes(sShapeName)
        .LockAspectRatio = False
[COLOR="Green"]        '*
        '* Adjust image size[/COLOR]
        .Width = csngResizeNo * rInputRng.Width
        .Height = csngResizeNo * rInputRng.Height
[COLOR="Green"]        '*
        '* Adjust image alignment within destination cell[/COLOR]
        .Top = rOutputRng.Top + (rOutputRng.Height - .Height) / 2
        .Left = rOutputRng.Left + (rOutputRng.Width - .Width) / 2
[COLOR="Green"]        '*
        '* Change image name[/COLOR]
        .Name = "Picture " & rInputRng.Address(False, False)
    End With

End Sub[/COLOR][/SIZE][/FONT]

Please note that the destination cell is slightly wider than the source cell. You can adjust destination cell's width via the constant cbMarginSize. The formula is 2 * Margin size, where 2 represent the cell’s two margins; left and right. So, in order to adjust cell’s width change the value of Margin size, currently 1.

 

[all4excel]

Wow...Brother Amazing...That worked beautifully..
All the adamant issues are solved like Image Size , Center Alignment and last but not the least the Image Name..
The only thing I wanted is for the OutputRange Column Width to be Fixed for all the columns in consideration..lets say 27:00..
However, I think I will have to compare it with the Largest Width of InputRange Column and then decide on a number which is slightly higher than that.. Logically, Lets say the Largest ColumnWidth in the InputRange from A1 till G1 is say 24 then add + x where x can be 10..
I was trying to do that but since this in a loop thats difficult..for my kind..

Just can we have the Output Range Column Fixed and just a tad larger than the InputRange's Width..

Thanks in advance..

In-Sha Allah...

You have done it..

Al-Humdallah

 

[Mohammad Basem]

Al-hamdullah. If you want to set a fixed column width equals to the widest source cell, then it would be more convenient controlling dimensions of destination cells from the call macro (FormattingInfo), before calling ClickAndPaste_Adjust.

In this case you will need to delete the following statements from ClickAndPaste_Adjust

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]With rOutputRng
    .RowHeight = rInputRng.RowHeight
    .ColumnWidth = rInputRng.ColumnWidth + cbMarginSize
End With
[/COLOR][/SIZE][/FONT]

 

[all4excel]

Sorry I had not checked this message at all till today..
Anomalous it did not show up as Unread..

I tinkered with the code however I am not sure how to get the Max ColumnWidth of the InputRange for the seven columns in the Parent SHeet..
I need the OutpuRange width to be fixed for all the Output columns but also which is slightly greater than the columnwidth of the Input Range from all the Columns in consideration..

Some changes in the GetFormatting1..

Sub GetFormatting1()
'...
.
.
.


    j = 7
    For i = 1 To 7
    
    Call ClickAndPaste_Adjustment(wsR.Cells(1, i), wsF.Cells(2, j))
    wsF.Cells(2, j).Borders.Color = 1
    wsF.Cells(2, j).ColumnWidth = wsR.Range(Cells(1, i), Cells(1, j)).ColumnWidth + 10
    j = j + 1
    Next i

So getting a Max ColumnWidth for the InputRange..is challenging..

With rOutputRng
        .RowHeight = rInputRng.RowHeight
        '.ColumnWidth = rInputRng.ColumnWidth + cbMarginSize
    End With

I am OK with the same height but the ColumnWidth for the OutPut Range needs to be Fixed and 10 points more than the Max of the InputRng ColumnWidth..



Al-Humdallah..

 

[Mohammad Basem]

I tinkered with the code however I am not sure how to get the Max ColumnWidth of the InputRange for the seven columns in the Parent SHeet..

Loop through the source table’s columns to find which one is the widest, then set the destination columns to that width + whatever value you want. This should be done before entering the loop where ClickAndPaste_Adjustment is called.

 

[all4excel]

Brother,

My take was to do that before calling your ClickAndPaste_Adjustment

Sub MaxColumnWidth()Dim i As Long, j As Long
Dim r As Range, maxWidth As Double
Dim wsR As Worksheet
    
    Set wsR = Worksheets("Report")    
    i = 1
    j = 7    
    With wsR.Range(Cells(1, i), Cells(1, j))
                For Each r In .Cells
                    maxWidth = Application.Max(maxWidth, r.ColumnWidth)
                Next
                    .ColumnWidth = maxWidth
    End With


End Sub

Now this is the code which I tried putting inside the GetFormatting1 SubRoutine, but in vain as I am facing problems using the Range(Cells(1,i), cells(1,j)

i = 1    j = 7
    
    With wsR.Range(Cells(1, i), Cells(1, j))
                For Each r In .Cells
                    maxWidth = Application.Max(maxWidth, r.ColumnWidth)
                Next
                    .ColumnWidth = maxWidth
    End With
    
    For i = 1 To 7
    


    
    Call ClickAndPaste_Adjustment(wsR.Cells(1, i), wsF.Cells(2, j))
    
    wsF.Cells(2, j).Borders.Color = 1  
        
    
    wsF.Cells(2, j).ColumnWidth = maxWidth + 10
    
    j = j + 1
    Next i

So, please advise where am I making a mistake..

Thanks in advance

Al-Humdallah

 

[Mohammad Basem]

Try,

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]With wsR.Range(Cells(1, i), Cells(1, j))
    For Each r In .Cells
        maxWidth = Application.Max(maxWidth, r.ColumnWidth)
    Next
End With
[I][COLOR="Red"]Destination range[/COLOR][/I].ColumnWidth = maxWidth[/COLOR][/SIZE][/FONT]

Replace Destination range with the correct range.

 

[all4excel]

With wsR.Range(Cells(1, i), Cells(1, j))

Brother,

But I am getting continuous error in the first line itself as follows

RunTime Error '1004':

Method 'Range' of object '_Worksheet' failed.

Al-Humdallah