Shrink print to 1 page wide not working

Posted on 2012-08-25
Last Modified: 2012-08-26
I have some code which essentially prints sheets after doing some formatting.  I usually print to the Adobe PDF printer.  This all works well but it doesnt seem to want to stick to shrinking to 1 page wide (it can be as long as necessary).

Could anyone give me any pointers?

Sub print_all()
Dim startadd As Integer
Dim endadd As Integer
fn = ThisWorkbook.Name
For Each ws In Sheets
sheetno = ws.Name
If Sheets(sheetno).Visible = True And Sheets(sheetno).Name <> "Start" And Sheets(sheetno).Name <> "Query" And Sheets(sheetno).Name <> "LookupPos" Then
printyn = MsgBox("Print " & sheetno & "?", vbYesNoCancel)
Select Case printyn
Case vbYes
fullsheetno = showname & " - " & sheetno & ".xls"

VariableToClipboard (fullsheetno)
startpa = False
endpa = False

For a = 1 To Sheets(sheetno).UsedRange.Columns.Count
If Columns(a).Hidden = False And startpa = False Then
startpa = True
startadd = a
End If
Next a

For B = Sheets(sheetno).UsedRange.Columns.Count To 1 Step -1
If Columns(a).Hidden = False And endpa = False Then
endpa = True
endadd = B
End If
Next B

endpa = False

ActiveSheet.PageSetup.PrintArea = ""
ActiveSheet.PageSetup.PrintArea = "$" & ColumnLetter(startadd) & ":$" & ColumnLetter(endadd)
'With Sheets(sheetno).PageSetup
'.FitToPagesWide = 1
'End With
If Sheets(sheetno).Name = "Deads" Or Sheets(sheetno).Name = "IO" Then
With Sheets(sheetno).PageSetup
        .Orientation = xlPortrait
        .CenterHeader = Left(fn, Len(fn) - 4) & " - &A"
        .RightFooter = "Page &P of &N"
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PaperSize = xlPaperA4
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1

With Sheets(sheetno).PageSetup
        .Orientation = xlLandscape
        .CenterHeader = showname & " - &A"
        .RightFooter = "Page &P of &N"
        .LeftMargin = Application.InchesToPoints(0.25)
        .RightMargin = Application.InchesToPoints(0.25)
        .TopMargin = Application.InchesToPoints(0.75)
        .BottomMargin = Application.InchesToPoints(0.75)
        .HeaderMargin = Application.InchesToPoints(0.3)
        .FooterMargin = Application.InchesToPoints(0.3)
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .PaperSize = xlPaperA4
End With
ActiveWindow.SelectedSheets.PrintOut Copies:=1

End If

Case vbNo
Case vbCancel
Exit Sub

End Select
End If
Next ws

End Sub

Public Sub VariableToClipboard(StringToCopy As String)
   Dim objData As Object
   Set objData = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

   With objData
      .SetText StringToCopy
   End With

End Sub

Function ColumnLetter(ColumnNumber As Integer) As String
  If ColumnNumber > 26 Then

    ' 1st character:  Subtract 1 to map the characters to 0-25,
    '                 but you don't have to remap back to 1-26
    '                 after the 'Int' operation since columns
    '                 1-26 have no prefix letter

    ' 2nd character:  Subtract 1 to map the characters to 0-25,
    '                 but then must remap back to 1-26 after
    '                 the 'Mod' operation by adding 1 back in
    '                 (included in the '65')

    ColumnLetter = Chr(Int((ColumnNumber - 1) / 26) + 64) & _
                   Chr(((ColumnNumber - 1) Mod 26) + 65)
    ' Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function

Open in new window

Question by:simonwait
    LVL 44

    Accepted Solution

    Try adding

    .Zoom = False
    LVL 1

    Author Comment

    Perfect Thank you
    LVL 44

    Expert Comment

    by:Martin Liss
    You're welcome and I'm glad I was able to help.

    Marty - MVP 2009 to 2012

    Write Comment

    Please enter a first name

    Please enter a last name

    We will never share this with anyone.

    Featured Post

    Highfive Gives IT Their Time Back

    Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

    INDEX and MATCH can be used to great effect to replace HLOOKUP and VLOOKUP as it does not have the limitation of needing the data to be sorted so that the reference value is in the first column or row. It also has the ability to perform a bi-directi…
    Approximate matching with VLOOKUP and MATCH seems to me to be a greatly under-used technique, and one which is vital for getting good performance out of large lookups. Until recently I would always have advised using an exact match for simplicity an…
    The view will learn how to download and install SIMTOOLS and FORMLIST into Excel, how to use SIMTOOLS to generate a Monte Carlo simulation of 30 sales calls, and how to calculate the conditional probability based on the results of the Monte Carlo …
    The viewer will learn how to create a normally distributed random variable in Excel, use a normal distribution to simulate the return on an investment over a period of years, Create a Monte Carlo simulation using a normal random variable, and calcul…

    761 members asked questions and received personalized solutions in the past 7 days.

    Join the community of 500,000 technology professionals and ask your questions.

    Join & Ask a Question

    Need Help in Real-Time?

    Connect with top rated Experts

    8 Experts available now in Live!

    Get 1:1 Help Now