Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 645
  • Last Modified:

Shrink print to 1 page wide not working

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
Application.Dialogs(xlDialogPrinterSetup).Show
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
Sheets(sheetno).Activate
ActiveWindow.SelectedSheets.PrintOut Copies:=1
Else

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
Sheets(sheetno).Activate
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
      .PutInClipboard
   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)
  Else
    ' Columns A-Z
    ColumnLetter = Chr(ColumnNumber + 64)
  End If
End Function

Open in new window

0
simonwait
Asked:
simonwait
  • 2
1 Solution
 
Martin LissRetired ProgrammerCommented:
Try adding

.Zoom = False
0
 
simonwaitAuthor Commented:
Perfect Thank you
0
 
Martin LissRetired ProgrammerCommented:
You're welcome and I'm glad I was able to help.

Marty - MVP 2009 to 2012
0

Featured Post

Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now