Link to home
Start Free TrialLog in
Avatar of Shums Faruk
Shums FarukFlag for India

asked on

Copy Picture from one workbook to newly created workbook

Good Day Experts,

I have below code which used to work fine;
Sub Printing_Statement_To_XLS()
Dim Ws As Worksheet
Dim myFile As Variant
Dim strFile As String
Dim NewWb As Workbook
On Error GoTo errHandler

Set Ws = Sheets("Statement_Template")

'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(Ws.Range("A12").value & " " & Ws.Range("G10").value & " " & Ws.Range("J1").value, " ", " "), ".", "_")
strFile = ThisWorkbook.Path & "\" & strFile

myFile = Application.GetSaveAsFilename(InitialFileName:=strFile, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx,", _
            Title:="Select Folder and FileName to save")

If myFile <> "False" Then
    Select Case LCase(Right(myFile, Len(myFile) - InStrRev(myFile, ".", , 1)))
            Case "xls": FileFormatValue = 56
            Case "xlsx": FileFormatValue = 51
            Case "xlsm": FileFormatValue = 52
            Case "xlsb": FileFormatValue = 50
            Case Else: FileFormatValue = 0
    End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                Ws.Copy
                With ActiveSheet.UsedRange
                    .value = .value
                End With
                With ActiveSheet
                    .Name = "Statement"
                End With
            
                Set NewWb = ActiveWorkbook
                NewWb.SaveAs myFile, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                                
                
            End If
    MsgBox "Excel file has been created."
    
End If
NewWb.Close False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file"

    Resume exitHandler
End Sub

Open in new window

But it was copying all the images (Picture plus Shape) to new workbook.

So I added below line before creating new workbook, which took off all the images, which I don't wanted;
Application.CopyObjectsWithCells=False

Open in new window

and below line before closing new workbook:
Application.CopyObjectsWithCells=True

Open in new window


So I removed above line and tried to print statement again, still its not copying any Image (Picture or Shape), I closed the workbook without saving and re-opened and tried to print statement again, but problem still persist, its not copying any image.

Picture is the Logo ("Picture 1") of the company and Shape is the execution of above code. I need only logo to be copied to new workbook without Shape. Please advice any revised code.

Regards,
Shums
SOLUTION
Avatar of Rgonzo1971
Rgonzo1971

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Avatar of Shums Faruk

ASKER

Thanks Rgonzo Sir,

It wasn't ticked, I ran code after making changes, it does copies all the images again :). Can you advice, how to just copy Logo without Shape?
Avatar of Rgonzo1971
Rgonzo1971

Could you send a dummy?
SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Here is the dummy file..
EE_Test.xlsm
ASKER CERTIFIED SOLUTION
Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
Yes,

This is what exactly I did following Proffessor's code. Below is my final code which works perfect:
Sub Printing_Statement_To_XLS()
Dim Ws As Worksheet
Dim myFile As Variant
Dim strFile As String
Dim NewWb As Workbook
Dim LogoPic As Shape
On Error GoTo errHandler

Set Ws = Sheets("Statement_Template")

'enter name and select folder for file
' start in current workbook folder
strFile = Replace(Replace(Ws.Range("A12").value & " " & Ws.Range("G10").value & " " & Ws.Range("J1").value, " ", " "), ".", "_")
strFile = ThisWorkbook.Path & "\" & strFile

myFile = Application.GetSaveAsFilename(InitialFileName:=strFile, filefilter:= _
            " Excel Macro Free Workbook (*.xlsx), *.xlsx,", _
            Title:="Select Folder and FileName to save")

If myFile <> "False" Then
    Select Case LCase(Right(myFile, Len(myFile) - InStrRev(myFile, ".", , 1)))
        Case "xls": FileFormatValue = 56
        Case "xlsx": FileFormatValue = 51
        Case "xlsm": FileFormatValue = 52
        Case "xlsb": FileFormatValue = 50
        Case Else: FileFormatValue = 0
    End Select

            'Now we can create/Save the file with the xlFileFormat parameter
            'value that match the file extension
            If FileFormatValue = 0 Then
                MsgBox "Sorry, unknown file extension"
            Else
                'Copies the ActiveSheet to new workbook
                Ws.Copy
                With ActiveSheet.UsedRange
                    .value = .value
                End With
                With ActiveSheet
                    .Name = "Statement"
                End With
            
                Set NewWb = ActiveWorkbook
                For Each LogoPic In NewWb.Worksheets("Statement").Shapes
                    If LogoPic.Type <> msoPicture Then
                        LogoPic.Delete
                    End If
                Next LogoPic
                NewWb.SaveAs myFile, FileFormat:= _
                             FileFormatValue, CreateBackup:=False
                                
                
            End If
    MsgBox "Excel file has been created."
    
End If
NewWb.Close False

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file"

    Resume exitHandler
End Sub

Open in new window

You can try something like this...

After creating the workbook, call the following sub routine which will delete all the unwanted shapes from it.

Sub DeleteShapesButLogo(ws As Worksheet)
Dim shp As Shape
For Each shp In ws.Shapes
    If Not shp.Name Like "Picture*" Then
        shp.Delete
    End If
Next shp
End Sub

Open in new window


Then in your main routine, call the above procedure like this...
    MsgBox "Excel file has been created."
    
End If
DeleteShapesButLogo NewWb.Sheets(1)
NewWb.Close True

exitHandler:
    Exit Sub
errHandler:
    MsgBox "Could not create Excel file"

    Resume exitHandler
End Sub

Open in new window

Thanks Rgonzo & Professor for your guidance
you are welcome.
Oops Sorry Neeraj,

I saw your code after accepting the solution :(
No problem. Glad your issue is resolved. :)