Importing Pictures

[Kdilas]

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

 

[MartinK]

Paste a picture so that it fits the CurrentRegion?
try this:

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]

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]

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).

try to replace

[b3].CurrentRegion

'with

Selection

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

 

[Kdilas]

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]

Hi,¨
try

Activesheet.Shapes(Activesheet.Shapes.Count)

to get the reference to the last object pasted.
Martin

 

[Kdilas]

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

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]

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 .

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