Copy Paste Edit Pictures in VBA

S

szmvsj

New Member
Joined
Jun 15, 2010
Messages
2
Hello and thank you in advance.
I have a spreadsheet form that is used to track parts. Users copy/paste pictures into their spreadsheet. These spreadsheets are then consolidated into a master sheet. I have written VBA to consolidate the data, but cannot figure out how to copy the pictures from the user sheets and paste them into the master sheet.
I would also like to be able to set the properties of the picture to "Move and size with cells".
I have tried a simple copy/paste of the cells that have the pictures, but when I run the macro, pictures do not get pasted.
Thanks,
Dave
 

Excel Facts

Is there a shortcut key for strikethrough?
Ctrl+S is used for Save. Ctrl+5 is used for Strikethrough. Why Ctrl+5? When you use hashmarks to count |||| is 4, strike through to mean 5.
Sort by date Sort by votes
Hi, This should paste Pictures to new sht in approx same position as original sheet.
Code: 
[COLOR=navy]Sub[/COLOR] MG15Jun43
[COLOR=navy]Dim[/COLOR] pic [COLOR=navy]As[/COLOR] Shape, rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] pic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
       [COLOR=navy]If[/COLOR] pic.Type = msoPicture [COLOR=navy]Then[/COLOR]
       pic.Copy
      [COLOR=navy]With[/COLOR] Sheets("Sheet2")
            .Select
            .Range(pic.TopLeftCell.Address).Select
            .Paste
        [COLOR=navy]End[/COLOR] With
    Selection.Placement = xlMoveAndSize
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] pic
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Upvote 0
thank you!!! you saved my job! :D
MickG said:
Hi, This should paste Pictures to new sht in approx same position as original sheet.
Code: 
[COLOR=navy]Sub[/COLOR] MG15Jun43
[COLOR=navy]Dim[/COLOR] pic [COLOR=navy]As[/COLOR] Shape, rng [COLOR=navy]As[/COLOR] Range
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] pic [COLOR=navy]In[/COLOR] ActiveSheet.Shapes
       [COLOR=navy]If[/COLOR] pic.Type = msoPicture [COLOR=navy]Then[/COLOR]
       pic.Copy
      [COLOR=navy]With[/COLOR] Sheets("Sheet2")
            .Select
            .Range(pic.TopLeftCell.Address).Select
            .Paste
        [COLOR=navy]End[/COLOR] With
    Selection.Placement = xlMoveAndSize
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR] pic
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...
 
Upvote 0
Anyway, when creating new sheets, the pictures are not positioned in the same coordinates as the original one. Do you think its possible to define the new position? (f.e. with x/y axis on the sheet)... thanks!
 
Upvote 0
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG01Feb48
[COLOR="Navy"]Dim[/COLOR] pic [COLOR="Navy"]As[/COLOR] Shape, rng [COLOR="Navy"]As[/COLOR] Range, Lt [COLOR="Navy"]As[/COLOR] Double, Tp [COLOR="Navy"]As[/COLOR] Double
Application.ScreenUpdating = False
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] pic [COLOR="Navy"]In[/COLOR] ActiveSheet.Shapes
       [COLOR="Navy"]If[/COLOR] pic.Type = msoPicture [COLOR="Navy"]Then[/COLOR]
       Lt = pic.Left
       Tp = pic.Top
       pic.Copy
      [COLOR="Navy"]With[/COLOR] Sheets("Sheet6")
            .Select
            .Range(pic.TopLeftCell.Address).Select
            .Paste
            Selection.Top = Tp
            Selection.Left = Lt
        [COLOR="Navy"]End[/COLOR] With
    Selection.Placement = xlMoveAndSize
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] pic
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0
raraschek said:
Thank you. Right now the sheet is used by management so can´t change it, but I ll try it soon.
Click to expand...

Dear all

Below is my partially successful effort of picking up an invoice template which includes some pictures by firstly incrementing the invoice number by 1, copying the entire sheet and its pictures to a new invoice to a new tab.


Sub StartInvoice2a()
'
' StartInvoice2 Macro
ActiveWorkbook.Save
Sheets("Invoice (0)").Select

Dim num As Integer
Range("InvNo").Select
num = Range("InvNo").Value
num = num + 1
Range("InvNo").Value = num

Sheets("Invoice (0)").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)

ActiveSheet.Select
Dim ActiveSheet As Worksheet
Sheets("Invoice (0)").Select
Dim pic As Shape, rng As Range
For Each pic In ActiveSheet.Shapes
If pic.Type = msoPicture Then
pic.Copy
With sht
'With Sheets("Invoice (0)")
.Select
.Range(pic.TopLeftCell.Address).Select
.Paste
End With
Selection.Placement = xlMoveAndSize
End If
Next pic

Selection.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
'Sheets("Invoice (0)").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Cells.Select
Range("B10").Activate
Selection.Copy
Range("A1").Select
Range("D5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Worksheets("Invoice (0)").Shapes("Picture 1").Copy
ActiveSheet.Paste Range("A1")
Selection.ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
Range("D5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A11").Select
End Sub


The script fails as it says I have a duplicate declaration in place ... any help would much appreciated.
 
Upvote 0
Hi
- I don’t know if the code does exactly what you want, but at least it’s executing without errors…
- It’s not necessary to select objects to work with them, but I left that alone for now.
- You may wrap your code with code tags to post it here in a formatted way.

Code: 
Option Explicit
Sub StartInvoice2a()
Dim num%, pic As Shape, rng As Range
ActiveWorkbook.Save
Sheets("Invoice (0)").Activate
num = Range("InvNo").Value
num = num + 1
Range("InvNo").Value = num
Sheets("Invoice (0)").Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
For Each pic In ActiveSheet.Shapes
    If pic.Type = msoPicture Then
        pic.Copy
        With Sheets("Invoice (0)")
            .Select
            .Range(pic.TopLeftCell.Address).Select
            .Paste
        End With
        Selection.Placement = xlMoveAndSize
    End If
Next pic
ActiveSheet.Copy After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count)
Cells.Select
Range("B10").Activate
Selection.Copy
Range("D5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Worksheets("Invoice (0)").Shapes("Picture 1").Copy
ActiveSheet.Paste Range("A1")
Selection.ShapeRange.ScaleWidth 1, msoFalse, msoScaleFromTopLeft
Selection.ShapeRange.ScaleHeight 1, msoFalse, msoScaleFromTopLeft
Range("D5").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("A11").Activate
End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

S
  • Solved
Pasting as an Image and then Re-sizing image
Replies
3
Views
78
rollis13
rollis13
T
  • Question
VBA- Copy & Paste Range into Outlook as a Picture
Replies
1
Views
118
Domenic
D
C
  • Question
Picture won't paste in cell overlay
Replies
0
Views
67
Cerka
C
J
  • Question
Inserting picture into cell via VBA
Replies
2
Views
409
Joek88
J
M
  • Question
Error 1004 - Can't Copy as Picture, but only on certain computer
2
Replies
10
Views
322
rlv01
R

Forum statistics

Threads
1,214,950
Messages
6,122,436
Members
449,083
Latest member
Ava19

Share this page

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