Shums Faruk
asked on
Copy Picture from one workbook to newly created workbook
Good Day Experts,
I have below code which used to work fine;
So I added below line before creating new workbook, which took off all the images, which I don't wanted;
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
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
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
and below line before closing new workbook:Application.CopyObjectsWithCells=True
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
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Could you send a dummy?
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Here is the dummy file..
EE_Test.xlsm
EE_Test.xlsm
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Yes,
This is what exactly I did following Proffessor's code. Below is my final code which works perfect:
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
You can try something like this...
After creating the workbook, call the following sub routine which will delete all the unwanted shapes from it.
Then in your main routine, call the above procedure 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
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
ASKER
Thanks Rgonzo & Professor for your guidance
you are welcome.
ASKER
Oops Sorry Neeraj,
I saw your code after accepting the solution :(
I saw your code after accepting the solution :(
No problem. Glad your issue is resolved. :)
ASKER
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?