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

GedSalter

New Member
Joined
Apr 24, 2019
Messages
29
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.
 

Some videos you may like

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,648
Office Version
365
Platform
Windows
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:

GedSalter

New Member
Joined
Apr 24, 2019
Messages
29
It did not work. I was wondering if it helps that Ive noticed the actual picture is named Picture 44.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
5,648
Office Version
365
Platform
Windows
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
 

Watch MrExcel Video

Forum statistics

Threads
1,095,727
Messages
5,446,166
Members
405,388
Latest member
Arlind

This Week's Hot Topics

Top