Copy Image from Clipboard into Excel in Certain Cells

ashani

Active Member
Joined
Mar 14, 2020
Messages
343
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
 

Excel Facts

When did Power Query debut in Excel?
Although it was an add-in in Excel 2010 & Excel 2013, Power Query became a part of Excel in 2016, in Data, Get & Transform Data.
Sorry forgot to write - is it possible to have a date and time in the bottom when pasted. Thanks
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
hi @rlv01
just normal windows snipping tool - this one

1590099266676.png
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,491
Messages
6,113,963
Members
448,536
Latest member
CantExcel123

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
Back
Top