Resize photograph

**mukeshbaviskar** · 08-13-2013, 07:42 PM

Dear Friends,
I have inserted the photographs of persons in column range 'd8:d3000'. After inserting the photographs I have to adjust the size of it to fit in that particular cell and look better all the photographs in same size. To avoide this laborious task I need a macro for it. The photographs are not in all rows. Only when there is a entry of new person then I insert his/her photograph and other rows contains the personal information of him. So there may be blank cells in between two photographs and it depend upon how much information of him is available. It may be 2/3/4 or more cells blank between two photographs in column 'd'. I want to resize the photograph 'width = 3 cm, height = 4 cm' automatically resize.

Thanking you in anticipation.

Mukesh

**ajryan88** · 08-13-2013, 09:50 PM

Hi,

Here is some code that will resize every picture on the worksheet to the size that you requested. I had my code activated by a button (called CommandButton1), but feel free to insert this into a custom macro which is called by a keyboard shortcut or other function/subroutine.

Private Sub CommandButton1_Click()
    Dim pic As Shape
    
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture Then
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        End If
    Next pic
End Sub

Let me know how this goes for you

**mukeshbaviskar** · 08-13-2013, 11:20 PM

Hello ajryan88,
Thank you for solution. I'm new to vba so I didn't understand where to insert the macro. I inserted it in standard modul but it is not working. Will you please insert the code in proper place so that I can learn and solve my problem without error.

I want to resize the photographs in column 'd' range d8:d3000 respectively. There are some blank cells in between two photographs because there is other information in other columns regarding the same person.

Please do insert the code in attached file for me positively.

Thanking you in anticipation.

Mukesh

**ajryan88** · 08-13-2013, 11:27 PM

Sure thing! Here you go...

NB: This will not move the images into position for you, it will only resize them. You will have to move them to their location manually.

Please mark this thread as solved and say thanks by clicking on the star to the bottom-left of my post to add some reputation.

Thanks

**mukeshbaviskar** · 08-13-2013, 11:52 PM

Dear ajryan88,
Thank you for quick solution. It's working fine. Only I have a doubt that does it resize all the images on sheet or in column 'd' only. Actually I have other images on sheet like logo etc. and I do't want to resize it in same size in column 'd'. I want to resize the images in column 'd' only and not other images in the sheet. Is there any solution for it?
Is there any solution to set the images in there appropriate place automatically in my case in column 'd'?
Can we create a shortcut key to run it with a help of key board?

If so otherwise my problem is solved.

Thanking you in anticipation.

Mukesh

**ajryan88** · 08-14-2013, 12:01 AM

Yes it will resize all images. If you don't want it to resize certain images, you need to do this by name as it can't be done by column. So try this (just replace my old code):

Private Sub CommandButton1_Click()
    Dim pic As Shape
    
    For Each pic In ActiveSheet.Shapes
        If pic.Type = msoPicture And pic.Name <> "YourLogo" Then
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        End If
    Next pic
End Sub

Note that you must name your logo "YourLogo", or change the code to suit. You can also add in as many of these "And" statements as is necessary.

I'm sorry that they can't be moved automatically to where you want them to go, this will have to be done manually.

Thanks

**mukeshbaviskar** · 08-15-2013, 04:19 AM

Hello ajryan88,
I inserted the code in the file but I didn't understand how to name the logo which giving error in the code. I have inserted a image for example which I want to rename as 'logo'. The image is in cell 'b3'.

Please guide me how to rename the image and do necessary change in code for better understanding.

Thanking you in anticipation.

Mukesh

**xladept** · 08-14-2013, 12:56 PM

Adapting ajryan's code in this way could also just resize the column D pics:

Private Sub CommandButton1_Click() 
    Dim pic As Shape
    
    For Each pic In ActiveSheet.Shapes
    If Abs(pic.Left - Range("D1").Left) < 10 Then
        If pic.Type = msoPicture Then
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        End If: End If
    Next pic
End Sub

The red 10 is arbitrary and meant to be the tolerance level for definition of Column D's position - so you should experiment with that

BTW - you could also place them automatically using the top and left values.

**ajryan88** · 08-14-2013, 05:07 PM

@xladept: I am aware that they can be moved using code, but I didn't think it would be possible to have them all moved to their correct locations using some simple code, as it would take more than a For...Next loop to get everything correct. Good idea with the tolerance level though, the only reason I didn't suggest using Range("D1").Left was because I figured that it wouldn't resize any picture that was even slightly to the left of cell D1, but you have overcome that very nicely.

**xladept** · 08-14-2013, 05:39 PM

Hi ajryan,

Nice code by the way - if the cells were correctly sized, as Mukesh indicated then you could use:

pic.Top=Range("D" & i).Top: pic.Left=Range("D" & i).Left

etc.

**mukeshbaviskar** · 08-15-2013, 11:46 AM

Hi xladept,
Excellent! It's the excellent output I expect without renaming the image. It fulfil my requirement.

I didn't understand the second reply mentioning the range "d" & I. What is the meaning of 'i' here? Do you mean to say that range (d8:d3000)?

Thank you for excellent solution.

Thank you to both of you for solving my problem quickly.
Mukesh

**ajryan88** · 08-15-2013, 07:52 AM

The code that you will need to use is in one of my posts above. As for renaming the photo, this link should point you in the right direction:

http://www.ozgrid.com/forum/showthread.php?t=81972

**mukeshbaviskar** · 08-15-2013, 11:21 AM

Hello ajryan88,
Thank you. I rename the image in 'b3' as 'Logo' and made necessary change in code but the result is not per my expectation. The image in cell 'b3' also resize after running the macro with other images in column 'd' which I don't want. Solution please.

I have other buttons in my original file for other macros. The button of this macro is not moves in other location, why? Can we make it automatic after inserting the image in column 'd' or any other cells in the sheet? The button can not be resize. Can we create a shortcut key to run it instead of button? Actually I don't want the name to my logo which looks bad. So can we avoide renaming the logo and achieve the appropriate result in other way?

Thanking you in anticipation.

Mukesh

**xladept** · 08-15-2013, 01:51 PM

Hi Mukesh,

The i is an index so that you could run right down the column - but the spacing would have to be regular.

Here's some code to Name "N" Resize and Move a picture in Range "R" to Range "S":

Sub PositionPic() 'Use this code to invoke the actual procedure
Call NameandMovePic("Logo",Range("B3"), Range("D3"))
End Sub



Sub NameandMovePic(N As String,R As Range, S As Range)
Dim pic As Object, ws As Worksheet
                Set ws = ActiveSheet
    For Each pic In ws.Shapes
    If Abs(pic.Left - R.Left) < 10 Then
    pic.Name = N: pic.Left = S.Left: pic.Top = S.Top
    Exit Sub: End If: Next
End Sub

This seemed to work pretty well a tolerance of 22 was too much but needed to be 21 to catch President Obama:

Private Sub CommandButton1_Click() 
    Dim pic As Object, N As String, ws As Worksheet, R As Range
                Set ws = ActiveSheet
    
    For Each pic In ws.Shapes
    If Abs(pic.Left - Range("D1").Left) < 21 Then
        If pic.Type = msoPicture Then
        N = pic.Name
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        End If: End If
For Each R In Range("D1:D" & Range("B" & Rows.Count).End(xlUp).row)
        If Abs(pic.Top - R.Top) < 21 Then
    pic.Left = R.Left: pic.Top = R.Top: R.RowHeight = pic.Height
        Exit For: End If: Next
    Next pic
End Sub

**mukeshbaviskar** · 08-15-2013, 07:42 PM

Hello xladept,
Thank you for codes. I don't want to rename the image. The codes are excellent. Thank you for your explanation to understand the the code better.

Is there any way so that the macro should run automatically after enter image in column 'd' or create a shortcut key for it? There are other buttons in my original file and the button of this macro overlap them. I tried to move it but it is not moveable. Can we mention in the code where to create a button to avoide this problem?

I like your first macro which fulfils my requirement. Do solve the button problem.

Thanking you in anticipation.

Mukesh

**xladept** · 08-15-2013, 08:18 PM

Hi Mukesh,

I put in a Hot Key (Ctrl+Shift+Z) that will trigger the Resizer as well your CommandButton and I resized the Column Width also - you may still want to play with the tolerance - let me know how it works out: Mukesh.xlsm

**mukeshbaviskar** · 08-15-2013, 08:56 PM

Hi xladept,
Excellent! It's working fine but only a little modification is require. It renames the logo in cell 'b3' and moves the logo in cell 'd2' which I don't want. I don't want to resize the logo in cell 'b3' nor want to rename it in cell 'b3'. I want to resize only the images in column 'd'. The hot key is good and working fine. Still the button is not moveable. If it can not created automatically then I can create it manually in appropriate place where I want to create as other buttons.

Modifications require:

The logo should not be rename
The logo should not be move from it's location 'b3'
The logo should not be resize
The button should not be created automatically by code

Please see the output in attached file.

Thank you.

Mukesh

**mukeshbaviskar** · 08-17-2013, 11:18 AM

Hello xladept,
Eagerly waiting for your response with a excellent solution today. With these modification our program will be complete.

Thanking you in anticipation.

Mukesh

**xladept** · 08-17-2013, 03:18 PM

Hi Mukesh,

The logo should not be rename
The logo should not be move from it's location 'b3'
The logo should not be resize
The button should not be created automatically by code

None of these things are happening now - still, we may not be finished as the Lock Aspect Ratio being disabled
distorts many of the pics - perhaps cropping is a better way??

See if this will suit you:

Sub ResizePicinD()
    Dim pic As Object, N As String, ws As Worksheet, R As Range, T As Single
                     Set ws = ActiveSheet: T = 10
    
    For Each pic In ws.Shapes
    If pic.Type = msoPicture Then
        If Abs(pic.Left - Range("D1").Left) < T Then
                    N = pic.Name
        If InStr(1, N, "Butt") Then GoTo GetNext
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        
For Each R In Range("D1:D" & Range("B" & Rows.Count).End(xlUp).Row)
 
    If Abs(pic.Top - R.Top) < T And Abs(pic.Left - R.Left) < T Then
    pic.Left = R.Left: pic.Top = R.Top: R.RowHeight = pic.Height
        Exit For: End If: Next: End If: End If
GetNext:    Next pic
End Sub

**mukeshbaviskar** · 08-18-2013, 12:36 AM

Hello xladept,
Excellent! It suits my requirement but only one little problem is there. After running the macro the cell width and height is not adjusting as per image size. I don't want to manually format it. Can we make it automatic to fit as per picture size to avoide trouble?

If the cell width and height will be adjusted automatically as per picture size then it will be more perfect macro as per my desire. Is it possible?

Thanking you in anticipation.

Mukesh

**xladept** · 08-18-2013, 03:02 PM

Hi Mukesh,

I did have the Cell height adjusting and thought that I had included the column width - you may need to play with the setting but the column width and tolerance are right up top in the code:

Sub ResizePicinD()
    Dim pic As Object, N As String, ws As Worksheet, R As Range, T As Single
     Set ws = ActiveSheet: ws.Range("D:D").ColumnWidth = 15.43: T = 10
    
    For Each pic In ws.Shapes
    If pic.Type = msoPicture Then
        If Abs(pic.Left - Range("D1").Left) < T Then
                    N = pic.Name
        If InStr(1, N, "Butt") Then GoTo GetNext
            pic.LockAspectRatio = msoFalse
            pic.Width = Application.CentimetersToPoints(3)
            pic.Height = Application.CentimetersToPoints(4)
        
For Each R In Range("D1:D" & Range("B" & Rows.Count).End(xlUp).Row)
 
    If Abs(pic.Top - R.Top) < T And Abs(pic.Left - R.Left) < T Then
    pic.Left = R.Left: pic.Top = R.Top: R.RowHeight = pic.Height
        Exit For:End If: Next: End If: End If
GetNext:    Next pic
End Sub

**mukeshbaviskar** · 08-18-2013, 08:42 PM

Hello xladept,
Excellent! Now it's working as per my desire. It's working fine.

Thank you for your kind cooperation and guidance to solve my problem.

Mukesh

**xladept** · 08-18-2013, 09:29 PM

You're welcome!

Hybrid View

Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Re: Resize photograph

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] [SOLVED] I could NOT resize the axis title but excel allows me to resize gr

[SOLVED] How do I insert text on a photograph

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions