Creating new WS and exporting the original picture format has different aspect ratio on new sheets

GedSalter

Board Regular
Joined
Apr 24, 2019
Messages
80
I have a picture in my WS which when saving to another WS as different WS name and also PDF at the same time the picture format is all screwed up in regards to aspect ratio.

This is what I have so far.

Sub AddSheet()
Dim ws As Worksheet
Dim wh As Worksheet
Set ws = Worksheets(ActiveSheet.Name)

ActiveSheet.Copy After:=Worksheets(Sheets.Count)
Set wh = Worksheets(Sheets.Count)
If ws.Range("e14").Value <> "" Then
wh.Name = ws.Range("E14").Value
ActiveSheet.Protect
End If

strPath = ActiveWorkbook.Path & "\Invoices\"

ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & Range("E14"), _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False

End Sub


Hope you guys can help.
 

Excel Facts

Which Excel functions can ignore hidden rows?
The SUBTOTAL and AGGREGATE functions ignore hidden rows. AGGREGATE can also exclude error cells and more.
Unable to recreate your issue. Does this help ?

Note
1. If there are several shapes (not necessarily images) in the worksheet ..
Amend the 4 lines containing .Shapes(1) to .Shapes("Actual Name of Image")
2. Saving to PDF placed inside the IF test
- if wanting to export regardless of value in E14, move line commencing .ExportAs below End If

VBA Code:
Sub AddSheet()
    Dim strPath As String, strName As String, h As Double, w As Double
    strPath = ActiveWorkbook.Path & "\Invoices\"
 
    With ActiveSheet
        strName = .Range("E14").Value
        h = .Shapes(1).Height
        w = .Shapes(1).Width
        .Copy After:=Sheets(Sheets.Count)
    End With
 
    With Sheets(Sheets.Count)
        .Shapes(1).Height = h
        .Shapes(1).Width = w
        If strName <> "" Then
            .Name = strName
            .Protect
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strName, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
    End With
End Sub
 
Last edited:
Upvote 0
It did not work. I was wondering if it helps that Ive noticed the actual picture is named Picture 44.
 
Upvote 0
Try this ...

VBA Code:
Sub AddSheet()
    Dim strPath As String, strName As String
    strPath = ActiveWorkbook.Path & "\Invoices\"
 
    With ActiveSheet
        .Shapes("Picture 44").LockAspectRatio = msoTrue
        strName = .Range("E14").Value
        .Copy After:=Sheets(Sheets.Count)
    End With
 
    With Sheets(Sheets.Count)
        If strName <> "" Then
            .Name = strName
            .Protect
            .ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath & strName, _
                Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
        End If
    End With
End Sub
 
Upvote 0

Forum statistics

Threads
1,213,543
Messages
6,114,237
Members
448,555
Latest member
RobertJones1986

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