Embedding an image/picture and changing it

    I need to embed/insert a picture in a sheet at a certain location and then when I run a macro to copy some values from this sheet to another, remove this image and insert the next one in the list. I need to do this upto 90-100 times.


    Any thoughts?

    The files are in a folder on the c drive called products and are called prod1.jpg -> prod70.jpg (the max number of files could go upto 500)


    The macro I am using to copy and paste the dat is below. Any thoughts?


    Sub submit()
    Range("B2:B13").Select
    Selection.Copy
    Sheets("Data Input").Select
    Range("A3").Select
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1).Select
    Loop
    If ActiveCell.Column <= 251 Then
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Sheets("Marking sheet").Select
    Application.CutCopyMode = False
    Selection.ClearContents


    'This is where I need to delete the current picture and the insert the next one.


    Range("B2").Select
    Else
    Range("A18").Select
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1).Select
    Loop
    If ActiveCell.Column <= 251 Then
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Sheets("Marking sheet").Select
    Application.CutCopyMode = False
    Selection.ClearContents


    'This is where I need to delete the current picture and the insert the next one.


    Range("B2").Select
    End If
    End If
    End Sub

    Hello,


    here is some code to insert and delete a picture:


    activeSheet.Pictures.Insert("Product1.jpg").Select
    ActiveSheet.Shapes(1).Select
    Selection.Delete


    To delete use 1 assuming that there will always be just 1 picture at the time on the sheet.


    If you want to some actions for all the pictures you should create a loop:


    dim strFile as string
    dim strDirectory as string 'directory where the pictures are ex.: c:\tmp\


    strFile = Dir(strDirectory & "*.jpg", vbNormal)
    Do While Not strFile = ""
    'Your actions ********


    'Delete picture
    ActiveSheet.Shapes(1).Select
    Selection.Delete

    'Insert next picture
    activeSheet.Pictures.Insert(strDirectory & "\" & strFile).Select

    strFile = Dir(strDirectory & "*.*", vbNormal)
    Loop
    Hope this helps you starting.


    Gollem

    Thanks Gollem


    Will this allow me to have picture 1 on the sheet then when I run the submit macro to copy the entered data it will copy the data, delete the current picture and insert the next picture in the series?


    Phooey.

    Hi Gollem,


    Bit more info


    I have got this far (see below)


    Sub submit()
    Range("B2:B13").Select
    Selection.Copy
    Sheets("Data Input").Select
    Range("A3").Select
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1).Select
    Loop
    If ActiveCell.Column <= 251 Then
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Sheets("Marking sheet").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Shapes(14).Select
    Selection.Delete
    Range("F2").Select
    ActiveSheet.Pictures.Insert("c:\products\prod#.jpg").Select
    Selection.Name = "pic1"
    Range("B2").Select
    Else
    Range("A18").Select
    ActiveCell.Offset(0, 1).Select
    Do While Not IsEmpty(ActiveCell)
    ActiveCell.Offset(0, 1).Select
    Loop
    If ActiveCell.Column <= 251 Then
    Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
    False, Transpose:=False
    Sheets("Marking sheet").Select
    Application.CutCopyMode = False
    Selection.ClearContents
    ActiveSheet.Shapes(14).Select
    Selection.Delete
    Range("F2").Select
    ActiveSheet.Pictures.Insert("c:\products\prod#.jpg").Select
    Selection.Name = "pic1"
    Range("B2").Select
    End If
    End If
    End Sub


    What I need to do now is to be able to increment the # in the two lines on each run so that the first time it runs it will insert the file prod2.jpg then the next time it runs it will insert the file prod3.jpg and so on until it gets to the stage where there is no more files to insert and then it will stop (safely) and save the file.


    Hope this makes more sense


    Phooey

    Hi Phooey,


    two ways to do it:


    First solution will mean that you have to run the macro for each picture.
    You use a cell on the sheet for example "A1", you put a 1 in it.


    Then you make this code:
    ActiveSheet.Pictures.Insert("c:\products\prod" & activesheet.range("A1").value &".jpg").Select


    At the end, before the end sub:


    activesheet.range("A1").value = activesheet.range("A1").value + 1 =>increment


    This means if you want to start over(if you want to begin again from picture 1), you have to fill in 1 in cell "A1"



    Solution2 with a loop: you have to run the macro 1 time
    add module:


    Public Sub Main()
    Dim intCounter As Integer

    intCounter = 1
    'Perform for picture 1 - 10
    Do While intCounter < 11
    Submit intCounter
    intCounter = intCounter + 1
    Loop
    End Sub
    => Adapt Submit


    public sub submit(intCounter as integer)


    ....


    ActiveSheet.Pictures.Insert("c:\products\prod" & intCounter & "#.jpg").Select


    .....


    end sub


    Hope this works for you.


    Gollem

    Hi Gollem,


    Thanks very much.


    I used the first option as the second looked a bit complicated for a moron like me.


    I had to put the whole macro in a If/Then/Else loop to get it to stop and not crash but it's now working as required.


    Thanks again.


    Phooey.

Participate now!

Don’t have an account yet? Register yourself now and be a part of our community!

Register Yourself Login