VBA - Page Setup and Print Macros

Contents

• Individual Sub Modules
• Setup and Optimization
• Set Print DPI
• Set Print to Black and White
• Unhide All Sheets
• All Read Only
• Entire Print and Page Module
• Appendix: Links

Individual Sub Modules

The following Sub’s are included:

• Setup and Optimization
• Set Print DPI
• Set Print to Black and White
• Unhide All Sheets
• All Read Only

Setup and Optimization

• Setup & InitGlobalFastApp()

Option Explicit

' These are used to speed up vba code
Public DefCalcState As Integer
Public DefEventState As Integer
Public DefScrUpdState As Integer

Sub InitGlobalFastApp()
' Used to speed up vba code.
' Created on: 3/26/12
' By: S Conrad

' Stores default settings and changes them to speed up code
With Application
    DefCalcState = .Calculation
    DefEventState = .EnableEvents
    DefScrUpdState = .ScreenUpdating
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
    End With

End Sub

Set Print DPI

• SetPrintDPI()

Sub SetPrintDPI()
' Allows the user to select from a list of available print qualities and changes
' all pages in the current workbook.
' Created on: 3/14/12
' By: S Conrad

Dim bExitLoop As Boolean
Dim oldStatusBar As Boolean
Dim i As Double
Dim sDefDPI As Double
Dim dDPI As Double
Dim vDPI As Variant
Dim wsWkSheet As Worksheet
Dim wsAW As Worksheet
Dim Ans As Double
Dim sAnsMsg As String
Dim SampleDPI As String
Dim sFormQuest As String

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

' Stores initial settings
'InitGlobalFastApp
Set wsAW = ActiveSheet
sDefDPI = CStr(wsAW.PageSetup.PrintQuality(1))
oldStatusBar = Application.DisplayStatusBar

' Sets print quality to 600 if available
On Error Resume Next
ActiveSheet.PageSetup.PrintQuality = 600
If Err = 0 Then
    Application.DisplayStatusBar = True
    For Each wsWkSheet In Sheets
        Application.StatusBar = wsWkSheet.Name & "'s print quality is being changed to 600 DPi."
        wsWkSheet.PageSetup.PrintQuality = 600
        wsWkSheet.DisplayPageBreaks = False
        Next
    wsAW.Activate
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    Exit Sub
    Else
    sAnsMsg = "This printer does not have a print setting of 600 DPi." & vbCrLf & _
        "Would you like to see a list of available resolutions?"
    Ans = MsgBox(sAnsMsg, vbOKCancel, "Setting Print Resolution")
    If Ans = vbCancel Then Exit Sub
    End If

Application.DisplayStatusBar = True
Application.StatusBar = "Please wait. A list of available print qualities is being populated"

' Populate a list of possible print qualities
SampleDPI = ""
For i = 100 To 1200 Step 50
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = i
    If Err = 0 Then SampleDPI = SampleDPI & i & vbCrLf
    Next

ActiveSheet.DisplayPageBreaks = False
' Returns status bar to original state
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Construction of messages to send to the user
SampleDPI = Left(SampleDPI, Len(SampleDPI) - 2)

sFormQuest = "Please choose a print quality.  The drop down list "
sFormQuest = sFormQuest & "contains some available print qualities.  "
sFormQuest = sFormQuest & "Other print qualities are allowed.  Refer "
sFormQuest = sFormQuest & "to the page setup form of the page layout tab "
sFormQuest = sFormQuest & "for other available qualities."

' This loop shows the combo form and waits for the user to enter an acceptable answer
bExitLoop = False
Do
    vDPI = ComboForm(SampleDPI, sFormQuest, "Print Quality", sDefDPI, _
    "DPI")
    ' Exits if the user cancels
    If vDPI = vbCancel Or cmbCancel = vbCancel Then
'        With Application
'            .Calculation = DefCalcState
'            .ScreenUpdating = DefScrUpdState
'            .EnableEvents = DefEventState
'            End With
        wsAW.Activate
        wsAW.PageSetup.PrintQuality = sDefDPI
        wsAW.DisplayPageBreaks = False
        Unload FmComboBox
        Exit Sub
        End If

    ' Only allows integers
    If WorksheetFunction.IsNumber(vDPI) Or vDPI > 1 Then
        dDPI = CDbl(vDPI)
        Else
        MsgBox "Please enter a value greater than one.", vbOKOnly, "Print Settings"
        dDPI = 0
        End If

    ' Checks if the DPI is available
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = dDPI
    If Err <> 0 Then
        dDPI = 0
        MsgBox "The selected pring quality is not availabe for this printer.", vbOKOnly, _
            "Print Quality"
        Else
        bExitLoop = True
        End If
        Unload FmComboBox
    Loop Until bExitLoop = True

' Change each pages print quality and hide page breaks
Application.DisplayStatusBar = True
For Each wsWkSheet In Sheets
    Application.StatusBar = wsWkSheet.Name & "'s print quality is being changed to " & dDPI & " DPi."
    wsWkSheet.PageSetup.PrintQuality = dDPI
    wsWkSheet.DisplayPageBreaks = False
    Next

' Returns status bar to original state
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Return application to original state
wsAW.Activate
'With Application
'    .Calculation = DefCalcState
'    .ScreenUpdating = DefScrUpdState
'    .EnableEvents = DefEventState
'    End With

End Sub

Set Print to Black and White

• SetPrintBlackandWhite()

Sub SetPrintBlackandWhite()
' Changes print
' Revised on: 2/18/12
' by: Scott Conrad

Dim oldStatusBar As Boolean
Dim wsSheet As Worksheet

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

' Stores initial settings
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'InitGlobalFastApp

' Change print to black and white and hide page breaks
For Each wsSheet In Sheets
    Application.StatusBar = wsSheet.Name & " is being set to Black and White"
    wsSheet.PageSetup.BlackAndWhite = True
    wsSheet.DisplayPageBreaks = False
    Next wsSheet

Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Returns to original state
'With Application
'    .Calculation = DefCalcState
'    .ScreenUpdating = DefScrUpdState
'    .EnableEvents = DefEventState
'    End With

End Sub

Unhide All Sheets

• UnhideAllSheets()

Sub UnhideAllSheets()
' Unhides all sheets. This works with or without index tab.
' Revised on: 2/18/12
' by: Scott Conrad

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

Dim wsSheet As Worksheet

' Change sheets visibility
For Each wsSheet In Worksheets
    wsSheet.Visible = xlSheetVisible
    Next

End Sub

All Read Only

• AllReadOnly()

Sub AllReadOnly()
' Changes every file to read only without the save dialog
' Created on: 3/13/12
' By: S Conrad

Dim i As Integer
Dim aw As Workbook

' Exits if workbooks are not open
If Workbooks.Count < 1 Then Exit Sub

' Changes each open workbook to read only and deactivates the save application popup.
Set aw = ActiveWorkbook
For i = 1 To Workbooks.Count
    On Error Resume Next
    Workbooks(i).Saved = True ' Tricks excel into thinking file is saved
    Workbooks(i).ChangeFileAccess xlReadOnly
    Next i

' Returns Excel to original state
aw.Activate

End Sub

Entire Print and Page Module

• ModPrintAndPage.bas

Option Explicit

' These are used to speed up vba code
Public DefCalcState As Integer
Public DefEventState As Integer
Public DefScrUpdState As Integer

Sub SetPrintDPI()
' Allows the user to select from a list of available print qualities and changes
' all pages in the current workbook.
' Created on: 3/14/12
' By: S Conrad

Dim bExitLoop As Boolean
Dim oldStatusBar As Boolean
Dim i As Double
Dim sDefDPI As Double
Dim dDPI As Double
Dim vDPI As Variant
Dim wsWkSheet As Worksheet
Dim wsAW As Worksheet
Dim Ans As Double
Dim sAnsMsg As String
Dim SampleDPI As String
Dim sFormQuest As String

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

' Stores initial settings
'InitGlobalFastApp
Set wsAW = ActiveSheet
sDefDPI = CStr(wsAW.PageSetup.PrintQuality(1))
oldStatusBar = Application.DisplayStatusBar

' Sets print quality to 600 if available
On Error Resume Next
ActiveSheet.PageSetup.PrintQuality = 600
If Err = 0 Then
    Application.DisplayStatusBar = True
    For Each wsWkSheet In Sheets
        Application.StatusBar = wsWkSheet.Name & "'s print quality is being changed to 600 DPi."
        wsWkSheet.PageSetup.PrintQuality = 600
        wsWkSheet.DisplayPageBreaks = False
        Next
    wsAW.Activate
    Application.StatusBar = False
    Application.DisplayStatusBar = oldStatusBar
    Exit Sub
    Else
    sAnsMsg = "This printer does not have a print setting of 600 DPi." & vbCrLf & _
        "Would you like to see a list of available resolutions?"
    Ans = MsgBox(sAnsMsg, vbOKCancel, "Setting Print Resolution")
    If Ans = vbCancel Then Exit Sub
    End If

Application.DisplayStatusBar = True
Application.StatusBar = "Please wait. A list of available print qualities is being populated"

' Populate a list of possible print qualities
SampleDPI = ""
For i = 100 To 1200 Step 50
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = i
    If Err = 0 Then SampleDPI = SampleDPI & i & vbCrLf
    Next

ActiveSheet.DisplayPageBreaks = False
' Returns status bar to original state
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Construction of messages to send to the user
SampleDPI = Left(SampleDPI, Len(SampleDPI) - 2)

sFormQuest = "Please choose a print quality.  The drop down list "
sFormQuest = sFormQuest & "contains some available print qualities.  "
sFormQuest = sFormQuest & "Other print qualities are allowed.  Refer "
sFormQuest = sFormQuest & "to the page setup form of the page layout tab "
sFormQuest = sFormQuest & "for other available qualities."

' This loop shows the combo form and waits for the user to enter an acceptable answer
bExitLoop = False
Do
    vDPI = ComboForm(SampleDPI, sFormQuest, "Print Quality", sDefDPI, _
    "DPI")
    ' Exits if the user cancels
    If vDPI = vbCancel Or cmbCancel = vbCancel Then
'        With Application
'            .Calculation = DefCalcState
'            .ScreenUpdating = DefScrUpdState
'            .EnableEvents = DefEventState
'            End With
        wsAW.Activate
        wsAW.PageSetup.PrintQuality = sDefDPI
        wsAW.DisplayPageBreaks = False
        Unload FmComboBox
        Exit Sub
        End If

    ' Only allows integers
    If WorksheetFunction.IsNumber(vDPI) Or vDPI > 1 Then
        dDPI = CDbl(vDPI)
        Else
        MsgBox "Please enter a value greater than one.", vbOKOnly, "Print Settings"
        dDPI = 0
        End If

    ' Checks if the DPI is available
    On Error Resume Next
    ActiveSheet.PageSetup.PrintQuality = dDPI
    If Err <> 0 Then
        dDPI = 0
        MsgBox "The selected pring quality is not availabe for this printer.", vbOKOnly, _
            "Print Quality"
        Else
        bExitLoop = True
        End If
        Unload FmComboBox
    Loop Until bExitLoop = True

' Change each pages print quality and hide page breaks
Application.DisplayStatusBar = True
For Each wsWkSheet In Sheets
    Application.StatusBar = wsWkSheet.Name & "'s print quality is being changed to " & dDPI & " DPi."
    wsWkSheet.PageSetup.PrintQuality = dDPI
    wsWkSheet.DisplayPageBreaks = False
    Next

' Returns status bar to original state
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Return application to original state
wsAW.Activate
'With Application
'    .Calculation = DefCalcState
'    .ScreenUpdating = DefScrUpdState
'    .EnableEvents = DefEventState
'    End With

End Sub
Sub SetPrintBlackandWhite()
' Changes print
' Revised on: 2/18/12
' by: Scott Conrad

Dim oldStatusBar As Boolean
Dim wsSheet As Worksheet

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

' Stores initial settings
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
'InitGlobalFastApp

' Change print to black and white and hide page breaks
For Each wsSheet In Sheets
    Application.StatusBar = wsSheet.Name & " is being set to Black and White"
    wsSheet.PageSetup.BlackAndWhite = True
    wsSheet.DisplayPageBreaks = False
    Next wsSheet

Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar

' Returns to original state
'With Application
'    .Calculation = DefCalcState
'    .ScreenUpdating = DefScrUpdState
'    .EnableEvents = DefEventState
'    End With

End Sub
Sub UnhideAllSheets()
' Unhides all sheets. This works with or without index tab.
' Revised on: 2/18/12
' by: Scott Conrad

' Cancels procedure if no workbooks are open
If Workbooks.Count = 0 Then
    MsgBox "No workbooks are open.", , "Change Print Resolution"
    Exit Sub
    End If

Dim wsSheet As Worksheet

' Change sheets visibility
For Each wsSheet In Worksheets
    wsSheet.Visible = xlSheetVisible
    Next

End Sub
Sub AllReadOnly()
' Changes every file to read only without the save dialog
' Created on: 3/13/12
' By: S Conrad

Dim i As Integer
Dim aw As Workbook

' Exits if workbooks are not open
If Workbooks.Count < 1 Then Exit Sub

' Changes each open workbook to read only and deactivates the save application popup.
Set aw = ActiveWorkbook
For i = 1 To Workbooks.Count
    On Error Resume Next
    Workbooks(i).Saved = True ' Tricks excel into thinking file is saved
    Workbooks(i).ChangeFileAccess xlReadOnly
    Next i

' Returns Excel to original state
aw.Activate

End Sub

Sub InitGlobalFastApp()
' Used to speed up vba code.
' Created on: 3/26/12
' By: S Conrad

' Stores default settings and changes them to speed up code
With Application
    DefCalcState = .Calculation
    DefEventState = .EnableEvents
    DefScrUpdState = .ScreenUpdating
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
    End With

End Sub

---

Appendix: Links

• Code
• Development
• Excel
• Microsoft Office
• Excel - VBA

Backlinks:

list from [[VBA - Page Setup and Print Macros]] AND -"Changelog"