Importing Pictures

Kdilas

Board Regular
Joined
Jul 11, 2002
Messages
100
Hello All,
I would like to have a macro that will automatically import a picture file from the clipboard and autosize it to fit the current range. The picture is placed on the clipboard using a screen capture program. if anybody has any suggestions that would help I would really appreciate it.

Thanks
K Dilas
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type

MartinK

Active Member
Joined
Oct 30, 2003
Messages
384
Paste a picture so that it fits the CurrentRegion?
try this:
Code:
Sub PastePicture()
    ActiveSheet.Paste
    With ActiveSheet.Shapes(1)
        .Top = [b3].CurrentRegion.Top
        .Left = [b3].CurrentRegion.Left
        .Width = [b3].CurrentRegion.Width
        ScaleH = [b3].CurrentRegion.Height / .Height
        .ScaleHeight ScaleH, msoFalse, msoScaleFromTopLeft
    End With
End Sub

I had some data in cells B3:C6 for example.
regards
Martin
 

Kdilas

Board Regular
Joined
Jul 11, 2002
Messages
100
Hi Martin,

Thanks alot for the fast reply. The code merges the picture in but doesn.t make it as large as possible to fit the range selected. Currently Cells A5:H25 have been merged together and I need the picture to be as large as possible. Any suggestions?

Thanks
K Dilas
 

MartinK

Active Member
Joined
Oct 30, 2003
Messages
384
No, it doesn't. You've spoken about CurrentRegion. This is a method returning the range of the adjacent cells to the referenced cell (in my example, B3). :biggrin:

try to replace
Code:
[b3].CurrentRegion

'with

Selection

or any valid range object, e.g. Range("A5:H25") etc.
regards
Martin
 

Kdilas

Board Regular
Joined
Jul 11, 2002
Messages
100

ADVERTISEMENT

Hello Again,

In your code the line that says "With ActiveSheet.Shapes(1)"
i beliave you are telling excel to execute next command on
shape #1. If this is true how would i find the name of the picture i just pasted in as the document contains many buttons and pictures already.

Thanks
K Dilas
 

MartinK

Active Member
Joined
Oct 30, 2003
Messages
384
Hi,¨
try
Code:
Activesheet.Shapes(Activesheet.Shapes.Count)
to get the reference to the last object pasted.
Martin
 

Kdilas

Board Regular
Joined
Jul 11, 2002
Messages
100
the code is working good. as you can see in the code below i have added another line to scale the picture in the width the same amount as the height. the problem with this is that sometimes the picture falls outside of the range allocated for the picture. how would i get it to scale as big as possible(using the same scale amount in both directions) without going outside of the range and then center inside range. would this be alot of work or can it be done without to much of a headache?

Thanks
KDilas

Code:
Sub Button1_Click()
Application.DisplayAlerts = False
   On Error GoTo Button1_Click_Error
    ActiveSheet.Paste
    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        .Top = Range("D12:N43").Top
        .Left = Range("D12:N43").Left
        .Width = Range("D12:N43").Width
         ScaleH = Range("D12:N43").Height / .Height
        .ScaleHeight ScaleH, msoFalse, msoScaleFromTopLeft
        .ScaleWidth ScaleH, msoFalse, msoScaleFromTopLeft
    End With
Range("A1").Select
   On Error GoTo 0
   Exit Sub
   
Button1_Click_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ") There is No Picture on The Clipboard" & vbCrLf & "Please use a screen capture to place the picture on the clipboard and try again."
Application.DisplayAlerts = True

End Sub
 

Kdilas

Board Regular
Joined
Jul 11, 2002
Messages
100
Well, I figured it out with a little help from the macro recorder and a lot of trial and error. Thanks again for the helping hand in the right direction. The finished code will import a picture from the clipboard and past it into a range specified in the code. then it auto scales the picture as large as possible and centers it in the range .

Code:
Sub Button1_Click()
Application.DisplayAlerts = False
   On Error GoTo Button1_Click_Error
    Range("D12:N43").Select
    ActiveSheet.Paste
    With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
        .Top = Range("D12:N43").Top
        .Left = Range("D12:N43").Left
        .Width = Range("D12:N43").Width
        .Height = Range("D12:N43").Height
         ScaleH = Range("D12:N43").Height / .Height
         scaleW = Range("D12:N43").Width / .Width
         If ScaleH < scaleW Then GoTo Line1 Else GoTo Line2:
Line1:
         AA = ScaleH
         GoTo Line3:
Line2:
         AA = scaleW
         GoTo Line3:
Line3:
        .ScaleHeight AA, msoFalse, msoScaleFromTopLeft
        .ScaleWidth AA, msoFalse, msoScaleFromTopLeft
        If AA = ScaleH Then GoTo Line4 Else GoTo Line5:
        
Line4:
        .IncrementLeft -(.Width - Range("D12:N43").Width) / 2
        GoTo Line6:
Line5:
        .IncrementTop -(.Height - Range("D12:N43").Height) / 2
        GoTo Line6:
Line6:
Range("A1").Select
    End With
   On Error GoTo 0
Exit Sub
   
Button1_Click_Error:

    MsgBox "Error " & Err.Number & " (" & Err.Description & ")"
Application.DisplayAlerts = True
End Sub

Thanks again Martin,
kDilas (y)
 
Master Excel Bundle

Excel contains over 450 functions, with more added every year. That’s a huge number, so where should you start? Right here with this bundle.

Forum statistics

Threads
1,151,891
Messages
5,766,966
Members
425,391
Latest member
Alono23

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top