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]

Since you asked me please provide both the options if possible i.e Its Static that it does not change as a Normal Picture captured by a Camera and also if possible the Dynamic Picture which can show changes..

What I am trying to do is to get a Picture of the Main Sheets First One or Two Rows which I have not decided yet as this is in process..

However since you asked me about the Dynamic Image I can see some uses for that too..

Thanks in advance

Al-Humdallah

 

[Mohammad Basem]

Yu already have the static version. Here is the dynamic one,

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub ClickAndPaste_Camera(ByVal rInputRng As Range, ByVal rOutputRng As Range)

    Dim shShape As Shape

    For Each shShape In ActiveSheet.Shapes
        If shShape.Type = msoPicture Then shShape.Delete
    Next shShape
[COLOR="Green"]    ' Copy range[/COLOR]
    rInputRng.CopyPicture
[COLOR="Green"]    ' Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial
    Selection.Formula = rInputRng.Address

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

 

[all4excel]

There is no need to have a function as you are not expecting return value. Try this,

[FONT=Consolas][SIZE=2][COLOR=Navy]Sub ClickAndPaste(ByVal rInputRng As Range, ByVal rOutputRng As Range)


    Dim shShape As Shape

    For Each shShape In ActiveSheet.Shapes
        If shShape.Type = msoPicture Then shShape.Delete
    Next shShape
    [COLOR=green]' Copy range[/COLOR]
    rInputRng.CopyPicture
    [COLOR=green]' Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial

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

rOutputRng could be one cell only.

Wow this worked like a charm for so long my non-vba brain could not understand but when I tried it numerous times, it worked amazingly thanks a lot..
Now please also tell me , how do I lock these Images and also is there a way of controlling the Names of these Images in any way..

Like it creates Image as "Picture 1" etc so I can make it as "Picture" & "-" & the Value of the cell or just the cell Address as "A1" , "B1"..

And the last thing, the image remains selected , so what do I do to make de-selecting the image?

By the way I have to still try the Dynamic Version but I am sure that it would work..
and also the major help on Formatting also needs to be tried and tested...

Thanks a lot...

Al-Humdallah...

 

[all4excel]

I really am impressed with this ClickAndPaste(ByVal rInputRng As Range, ByVal rOutputRng As Range)Just one last thing, Now when the Image is placed in the Output Cell it gets Pasted in the Left Area Top Edge..

Forgive me if I am not able to describe the positioning of the cell properly..

What I meant is that it goes more towards left, so is it possible to keep it center Aligned as well as also if we could reduce the size of the Image by 10% ( Whole Image )

I just want to see it so dont mind if its slightly smaller in size and center aligned..

http://www.mrexcel.com/forum/showthread.php?77483-Using-VBA-to-insert-an-image-within-a-cell

I think I found the solution for de-selection select some cell to de-select the Picture

Thanks in advance..

Al-Huumdallah

 

[all4excel]

Hey Mohammed brother, me still burning the Midnight Oil..

Found some good code thought of sharing though you could always make such things easily..

[URL]http://www.ozgrid.com/forum/showthread.php?t=62510[/URL]
Sub aTest()
     
    CenterMe ActiveSheet.Shapes(1), Range("G2")
     
End Sub
 
Sub CenterMe(Shp As Shape, OverCells As Range)
     
    With OverCells
        Shp.Left = .Left + ((.Width - Shp.Width) / 2)
        Shp.Top = .Top + ((.Height - Shp.Height) / 2)
    End With
End Sub

Now I am using your wonderful code in a Loop whereby I can get each different Picture of a cell .

'This is just the relevant part for the Image Pasting..
    j = 7
    For i = 1 To 7
    
    Call ClickAndPaste(wsR.Cells(1, i), wsF.Cells(2, j))
    j = j + 1
    Next i

So looking at the style of loop I am not sure whether I can modify that in your code..so please help me with the same..

Thanks in advance

Al-Humdallah.

 

[Mohammad Basem]

You are posting fast!

Few questions:

[Post#13]…how do I lock these Images…

What do you mean by locking images?

[Post#13]…Like it creates Image as "Picture 1" etc so I can make it as "Picture" & "-" & the Value of the cell or just the cell Address as "A1" , "B1"..

Use something like,

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Selection.Name = "Picture-" & Range("A1").Address(False, False)[/COLOR][/SIZE][/FONT]

[Post#14]…so is it possible to keep it center Aligned as well as also if we could reduce the size of the Image by 10% ( Whole Image )

[Post#15]
Call ClickAndPaste(wsR.Cells(1, i), wsF.Cells(2, j))

Are you making an image of each cell covered by the loop? Are these the cells' images you want to reduce their sizes and align them in the centers of destination cells?

Is this what you are asking for?

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub CopySnapshots()

    Dim wsR As Worksheet, wsF As Worksheet
    Dim i As Long, j As Long
    Dim shShape As Shape

    Set wsR = Sheets("Report")
    Set wsF = Sheets("Formatting")

[COLOR="Green"]    '*
    '* Delete all images in wsF[/COLOR]
    For Each shShape In wsF.Shapes
        If shShape.Type = msoPicture Then shShape.Delete
    Next shShape
    j = 7
    For i = 1 To 7
        ClickAndPaste_Adjust wsR.Cells(1, i), wsF.Cells(2, j)
        j = j + 1
    Next i

End Sub

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

[COLOR="Green"]    '* Copy range[/COLOR]
    rInputRng.CopyPicture
[COLOR="Green"]    '* Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial
    [COLOR="Green"]'* Adjust image size and alignment[/COLOR]
    With Sheets(rOutputRng.Parent.Name)
        With .Shapes(.Shapes.Count)
            .Width = 0.9 * .Width
            .Height = IIf(.LockAspectRatio, .Height, 0.9 * .Height)
            .Top = .Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .Left + (.TopLeftCell.Width - .Width) / 2
            .Name = "Picture-" & rInputRng.Address(False, False)
        End With
    End With

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

 

[all4excel]

You are posting fast!

Few questions:


What do you mean by locking images?


Use something like,

[FONT=Consolas][SIZE=2][COLOR=Navy]Selection.Name = "Picture-" & Range("A1").Address(False, False)[/COLOR][/SIZE][/FONT]

Are you making an image of each cell covered by the loop? Are these the cells' images you want to reduce their sizes and align them in the centers of destination cells?

Is this what you are asking for?

[FONT=Consolas][SIZE=2][COLOR=Navy]Sub CopySnapshots()

    Dim wsR As Worksheet, wsF As Worksheet
    Dim i As Long, j As Long
    Dim shShape As Shape

    Set wsR = Sheets("Report")
    Set wsF = Sheets("Formatting")

[COLOR=Green]    '*
    '* Delete all images in wsF[/COLOR]
    For Each shShape In wsF.Shapes
        If shShape.Type = msoPicture Then shShape.Delete
    Next shShape
    j = 7
    For i = 1 To 7
        ClickAndPaste_Adjust wsR.Cells(1, i), wsF.Cells(2, j)
        j = j + 1
    Next i

End Sub

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

[COLOR=Green]    '* Copy range[/COLOR]
    rInputRng.CopyPicture
[COLOR=Green]    '* Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial
    [COLOR=Green]'* Adjust image size and alignment[/COLOR]
    With Sheets(rOutputRng.Parent.Name)
        With .Shapes(.Shapes.Count)
            .Width = 0.9 * .Width
            .Height = IIf(.LockAspectRatio, .Height, 0.9 * .Height)
            .Top = .Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .Left + (.TopLeftCell.Width - .Width) / 2
            .Name = "Picture-" & rInputRng.Address(False, False)
        End With
    End With

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

Hey I know I was posting fast but really was not expecting responses at such a late Hour..
Though I was but I know others do sleep..

You know what I had actually managed the code on my own hah.. the one which you have renamed as Sub CopySnapshots().. so that keep me happy and awake late..

Anyways, what I mean about Locking is once the Image is fixed at that position, no one should be able to move it...

Now regarding the Resizing thing, it does work but it does not really show a drastic reduction to the naked eye only after I compared two images that I could make out..

I am sure the code works but are there are any other dimensions other than the above to reduce the Size..

What does this line do?

.Name = "Picture-" & rInputRng.Address(False, False)

Where do I write/include the above line?????

Also, two things apart from the above doubts.. when I ran your code I had a command button in my sheet which got reduced in size and after 2 - 3 runs it got disappeared..

So this SHape reduction would affect all shapes like command buttons too !


In regards with the Image/Picture being Renamed as "Picture" & cell Address of the wsR Worksheet, so is that possible in the Loop as everytime I select the Picture it shows it is "Picture 55" so on so forth..

Like Can it be Like "Picture A1"? If not then no big deal..

But please help me in placing the Picture in the center of the cell..
For example if Im placing the Picture in the cell G2 then I need that too be seen exactly in between like HorizontalAlignment and VerticalAlignment Center and once it is reduced substantially it would look better..

Modified code:

Sub ClickAndPaste_Adjust(ByVal rInputRng As Range, ByVal rOutputRng As Range)
Dim ResizeNo As Long
ResizeNo = (40 / 1000)


    '* Copy range
    rInputRng.CopyPicture
    '* Paste picture to output range
    rOutputRng.PasteSpecial
    '* Adjust image size and alignment
    With Sheets(rOutputRng.Parent.Name)
        With .Shapes(.Shapes.Count)
        If .Name <> "CommandButton1" Then
            .Width = ResizeNo * .Width
            .Height = IIf(.LockAspectRatio, .Height, ResizeNo * .Height)
            .Top = .Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .Left + (.TopLeftCell.Width - .Width) / 2
            .Name = "Picture-" & rInputRng.Address(False, False)
        Else
        Exit Sub
        End If
        End With
    End With


End Sub

Thanks in advance..

Al-Humdallah

 

[Mohammad Basem]

Anyways, what I mean about Locking is once the Image is fixed at that position, no one should be able to move it...

You may protect the sheet so all images will be inaccessible.

Now regarding the Resizing thing, it does work but it does not really show a drastic reduction to the naked eye

Yes, because the object is small (a cell) and the image is reduced 10%. The difference in size is marginal.

…are any other dimensions other than the above to reduce the Size..

No

What does this line do?
.Name = "Picture-" & rInputRng.Address(False, False)

Assign name to the copied image; Picture-A1, Picture-B1, etc.

when I ran your code I had a command button in my sheet which got reduced in size and after 2 - 3 runs it got disappeared..

So this SHape reduction would affect all shapes like command buttons too !

There are a variety of objects in the test sheet I use; shapes and, forms and ActiveX controls. The only shape affected by the macro is the copied images. Have you made any changes other than the posted one, which excludes the CommandButton from resizing?

But please help me in placing the Picture in the center of the cell..

It is in the centre of the cell. Many factors affecting what we can’t see it centred;
- Sheet zoom,
- Gridlines and/or borders of source cells,
- Horizontal and vertical alignment of source cells.

Try removing the gridlines and/or borders from the source sheet, align the range horizontally and vertically to centre then run the macro.

Here is a slightly modified version of ClickAndPaste_Adjust. The calculation of the image height was changed, but, again, we are dealing with marginal differences of a small object that cannot be recognised (easily) by eye.

[FONT="Consolas"][SIZE="2"][COLOR="Navy"]Sub ClickAndPaste_Adjust(ByVal rInputRng As Range, ByVal rOutputRng As Range)

[COLOR="Green"]    '*
    '* Copy range[/COLOR]
    rInputRng.CopyPicture
[COLOR="Green"]    '*
    '* Paste picture to output range[/COLOR]
    rOutputRng.PasteSpecial
    With Sheets(rOutputRng.Parent.Name)
        With .Shapes(.Shapes.Count)
            .LockAspectRatio = False
[COLOR="Green"]            '*
            '* Adjust image size[/COLOR]
            .Width = 0.9 * .TopLeftCell.Width
'            .Height = IIf(.LockAspectRatio, .Height, ResizeNo * .Height)
            .Height = 0.9 * .TopLeftCell.Height
[COLOR="Green"]            '*
            '* Adjust image alignment within destination cell[/COLOR]
            .Top = .Top + (.TopLeftCell.Height - .Height) / 2
            .Left = .Left + (.TopLeftCell.Width - .Width) / 2
[COLOR="Green"]            '*
            '* Change image name[/COLOR]
            .Name = "Picture " & rInputRng.Address(False, False)
        End With
    End With

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

You may further adjust the formulae for .Width, .Height, .Top and .Left. to show the desired results.

 

[all4excel]

Thanks again brother for being so very persevering however there are really no changes happening..
The size if I were to reduce it by 25-35% like lets say and Image of just a cell with the Column Width - 6.00 ( 73 pixels) and Row Height of 20.00 ( 40 pixels ) has to be reduced to make it between 65-75% of its original size..

Now what I am doing is I am maintaining the same Row Height of the Parent SHeet to the Formatting SHeet so this Image has to be copied renamed as Picture-A1 and pasted in the cell G2 which has the same Row Height and a Different Column Width of 26.00 ( 293 pixels )..

Then not only do i require this Image to be Renamed as "Picture-A1" when selected to show up but also the size slightly lesser than the original dimensions which can be easily noticed as its for Reference Purpose..

Now, this Image always gets Horizontal-Left Aligned whereas I need it to be Horizontal-Center Aligned..

Actually, I really do not know why after applying all your instructions to the "tee" its not happening..

Thanks in advance

Al-Humdallah

 

[Mohammad Basem]

If I understood correctly, you want to:

1. Copy cell A1 from Sheet Report to G2 in sheet Formatting,
2. Change column width and row height of G2 to be same as A1,
3. Re-size the copied image by 25-35%.

Is this correct?