Copy Image from Clipboard into Excel in Certain Cells

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows
Hi everyone,

I'm using the below formula and I want to paste image from clipboard in certain area - however when i do it, the image doesn't fit in that section properly and either shrinks so much or so little.

Also, if there is no image on the clipboard or text - then I want the message box pop up to say "nothing to copy".

Thank you for your help.

VBA Code:
Sub copy()
    Dim p As Picture
    Dim Target As Range
    
    Application.ScreenUpdating = False
ActiveSheet.Unprotect Password:="abc"

    Set p = ActiveSheet.Pictures.Paste
    Set Target = Range("B3:I26")
       
    With Target
        p.ShapeRange.LockAspectRatio = msoFalse 'Allows Proper Sizing
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
    End With

ActiveSheet.Protect Password:="abc", DrawingObjects:=False, contents:=True, Scenarios:=True


End Sub
 

Some videos you may like

Excel Facts

Add Bullets to Range
Select range. Press Ctrl+1. On Number tab, choose Custom. Type Alt+7 then space then @ sign (using 7 on numeric keypad)

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows
Sorry forgot to write - is it possible to have a date and time in the bottom when pasted. Thanks
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771
Also, if there is no image on the clipboard or text - then I want the message box pop up to say "nothing to copy".

Thank you for your help.

One way.
VBA Code:
Sub copy2()
    Dim p As Picture
    Dim Target As Range
    Dim Sh As Shape
    Dim Pic As Object

    Application.ScreenUpdating = False
    ActiveSheet.Unprotect Password:="abc"

    With ThisWorkbook.Worksheets("ShapeTest")         'ShapeTest is a hidden worksheet that you must create
        .Cells.Clear
        For Each Sh In .Shapes
            Sh.Delete
        Next Sh

        .Range("A1").PasteSpecial xlPasteAll

        On Error Resume Next
        Set Pic = .Pictures(1)
        On Error GoTo 0
    End With

    If Pic Is Nothing Then
        MsgBox "nothing to copy"
        Exit Sub
    End If

    Set p = ActiveSheet.Pictures.Paste
    Set Target = Range("B3:I26")

    With Target
        p.ShapeRange.LockAspectRatio = msoFalse       'Allows Proper Sizing
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
        With .Offset(.Rows.Count, 1).Resize(1, 1)     'modify to suit yourself
            .Value = CStr(VBA.Date & "   " & VBA.Time)
            .EntireColumn.AutoFit
        End With
    End With

    ActiveSheet.Protect Password:="abc", DrawingObjects:=False, contents:=True, Scenarios:=True
End Sub
 

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows
Thank you for your response @rlv01
I'm getting error 1004 - PasteSpecial method of Range class failed
This line is highlighted :
.Range("A1").PasteSpecial xlPasteAll


Please can you take a look.
Thanks
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771

ADVERTISEMENT

Try this instead:
VBA Code:
Sub copy2()
    Dim p As Picture
    Dim Target As Range
    Dim Sh As Shape
    Dim Pic As Object

    Application.ScreenUpdating = False
    ActiveSheet.Unprotect Password:="abc"
    
    With ThisWorkbook.Worksheets("ShapeTest")         'ShapeTest is a hidden worksheet that you must create
        .UsedRange.Value = vbNullString
        For Each Sh In .Shapes
            Sh.Delete
        Next Sh

        On Error Resume Next
        .Range("A1").PasteSpecial xlPasteAll
        Set Pic = .Pictures(1)
        On Error GoTo 0
    End With

    If Pic Is Nothing Then
        MsgBox "nothing to copy"
        Exit Sub
    End If

    Set p = ActiveSheet.Pictures.Paste
    Set Target = Range("B3:I26")

    With Target
        p.ShapeRange.LockAspectRatio = msoFalse       'Allows Proper Sizing
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
        With .Offset(.Rows.Count, 1).Resize(1, 1)     'modify to suit yourself
            .Value = CStr(VBA.Date & "   " & VBA.Time)
            .EntireColumn.AutoFit
        End With
    End With

    ActiveSheet.Protect Password:="abc", DrawingObjects:=False, Contents:=True, Scenarios:=True
End Sub
 

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows
hi @rlv01
so sorry to bother you but it's not working - everytime i snip something and clip on the macro button only the message box pops up to say nothing to copy - in fact when i tried to paste it by Ctrl V it pasted. What could be the issue with the code.
thank you
 

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows

ADVERTISEMENT

I'm copying a picture from the website etc by snipping tool and wants to be copied over to Excel by Macro for whatever on the clipboard.
 

ashani

Board Regular
Joined
Mar 14, 2020
Messages
202
Office Version
  1. 365
Platform
  1. Windows
hi @rlv01
just normal windows snipping tool - this one

1590099266676.png
 

rlv01

Well-known Member
Joined
May 16, 2017
Messages
771
Ok. I tested this one with the Windows snipping tool and with SnagIt. It works for me in both cases.
VBA Code:
Sub copy2()
    Dim p As Picture
    Dim Target As Range
    Dim Sh As Shape
    Dim IsPictureData As Boolean

    Application.ScreenUpdating = False
    ActiveSheet.Unprotect Password:="abc"

    With ThisWorkbook.Worksheets("ShapeTest")         'ShapeTest is a hidden worksheet that you must create
        .UsedRange.Value = vbNullString
        For Each Sh In .Shapes
            Sh.Delete
        Next Sh
        .Paste
        IsPictureData = .Shapes.Count > 0
        If IsPictureData Then IsPictureData = .Shapes(1).Type = msoPicture

        If Not IsPictureData Then
            MsgBox "Clipboard data is not a picture", vbInformation, "Picture Paste"
            Exit Sub
        End If
    End With

    Set p = ActiveSheet.Pictures.Paste
    Set Target = Range("B3:I26")

    With Target
        p.ShapeRange.LockAspectRatio = msoFalse       'Allows Proper Sizing
        p.Top = .Top
        p.Left = .Left
        p.Width = .Width
        p.Height = .Height
        With .Offset(.Rows.Count, 1).Resize(1, 1)     'modify to suit yourself
            .Value = CStr(VBA.Date & "   " & VBA.Time)
            .EntireColumn.AutoFit
        End With
    End With

    ActiveSheet.Protect Password:="abc", DrawingObjects:=False, Contents:=True, Scenarios:=True
    ThisWorkbook.Worksheets("ShapeTest").Cells.Clear
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,126,992
Messages
5,622,038
Members
415,875
Latest member
Tarali

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