Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1348to1352
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Druckmanager

Druckmanager
12.02.2014 07:39:17
Daniel
Hallo Zusammen,
Habe den unten stehenden code für einen Printmanager (by Hui) auf Chandoo gefunden, bekomme aber nur eine Messagebox mit "400" drin und nix passiert wenn ich auf "setup Print control Named Formular" drücke. Liegt das an 2013 oder was passiert hier kann mit der Fehlermeldung halt nicht so viel anfangen ;-)
Hier der Link wo es auch das demofile gibt: http://chandoo.org/wp/2011/09/14/hui%E2%80%99s-excel-report-printer/#comment-469435
Hier der code:
Option Explicit
Public Sub Print_Reports()
' Print_Reports
' Written Nov 2002
' by Hui:
' Published at Chandoo.org
' August 2011
Dim PrintArea As Variant
Dim i As Integer
Dim j As Integer
Dim sht As Long
Dim Orientation As String
Dim NCopies As Integer
Dim PWide As Integer
Dim PTall As Integer
Dim Footer As String
Dim Header As String
Dim Sheets As String
Dim gRow As Integer
Dim gCol As Integer
Dim PaperSize As String
Dim msg As String
Dim tmp As String
Application.Calculation = xlCalculationManual
PrintArea = Worksheets("Print_Control").Range("Print_Control").Value 'Loads the Print_Control  _
Named Range
For j = 1 To [Copies].Value         'Loop through the No of Copies
For i = 1 To UBound(PrintArea, 1)   'Loop through the print area
If UCase(PrintArea(i, 3)) = "ON" Then    'When On is enabled Print using the settings
Header = PrintArea(i, 2)      'Set Header variable
Orientation = PrintArea(i, 6) 'Set Orientation variable
PWide = PrintArea(i, 8)       'Set Pages Wide variable
PTall = PrintArea(i, 9)       'Set Pages Tall variable
NCopies = PrintArea(i, 10)    'Set No Copies variable
gRow = PrintArea(i, 11)       'Set Row Group Expansion
gCol = PrintArea(i, 12)       'Set Column Group Expansion
Footer = PrintArea(i, 13)     'Set Footer variable
'Set Paper size
If PrintArea(i, 7) = "A4" Then
PaperSize = 9
ElseIf PrintArea(i, 7) = "A3" Then
PaperSize = 8
ElseIf PrintArea(i, 7) = "A5" Then
PaperSize = 11
ElseIf PrintArea(i, 7) = "Legal" Then
PaperSize = 5
ElseIf PrintArea(i, 7) = "Letter" Then
PaperSize = 1
ElseIf PrintArea(i, 7) = "Quarto" Then
PaperSize = 15
ElseIf PrintArea(i, 7) = "Executive" Then
PaperSize = 7
ElseIf PrintArea(i, 7) = "B4" Then
PaperSize = 12
ElseIf PrintArea(i, 7) = "B5" Then
PaperSize = 13
ElseIf PrintArea(i, 7) = "10x14" Then
PaperSize = 16
ElseIf PrintArea(i, 7) = "11x17" Then
PaperSize = 17
ElseIf PrintArea(i, 7) = "Csheet" Then
PaperSize = 24
ElseIf PrintArea(i, 7) = "Dsheet" Then
PaperSize = 25
Else
PaperSize = 9 'Defaults to A4
End If
'Activate the relevent Sheet
tmp = PrintArea(i, 4)
If Not SheetExists(tmp) Then
msg = "Sheet '" + PrintArea(i, 4) + "' not found." + vbCrLf + "Check the sheets Name."
msg = msg + vbCrLf + vbCrLf + "Processing will continue for remaining sheets."
tmp = MsgBox(msg, vbExclamation, "Sheet not Found")
Else
'The sheet exists now process
Application.Sheets(PrintArea(i, 4)).Select
If ActiveSheet.Type = -4167 Then 'Its a worksheet
Application.ScreenUpdating = False
ActiveSheet.PageSetup.PrintArea = PrintArea(i, 5) 'Select the relevent Print Area on  _
the Sheet
ActiveSheet.Outline.ShowLevels RowLevels:=gRow, ColumnLevels:=gCol   'Set Outline  _
Grouping
With ActiveSheet.PageSetup    'Set print settings
.PrintTitleRows = ""
.PrintTitleColumns = ""
.LeftHeader = ""
.CenterHeader = Header    'User Defined Header (Shift to Left or Right as required)
.RightHeader = ""
.LeftFooter = Footer      'User Defined Footer (Shift to Left or Right as required)
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.1)
.RightMargin = Application.InchesToPoints(0.1)
.TopMargin = Application.InchesToPoints(1#)
.BottomMargin = Application.InchesToPoints(0.4)
.HeaderMargin = Application.InchesToPoints(0.1)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.CenterHorizontally = False
.CenterVertically = False
.Draft = False
.PaperSize = PaperSize      ' User Defined Paper Size
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = PWide     'User Defined No Pages Wide
.FitToPagesTall = PTall     'User Defined No Pages Tall
.PrintErrors = xlPrintErrorsDisplayed
End With
If Orientation = "L" Then     'User Defined Page Orientation
ActiveSheet.PageSetup.Orientation = xlLandscape
Else
ActiveSheet.PageSetup.Orientation = xlPortrait
End If
Application.ScreenUpdating = True
'Finished setting up Worksheet goto Printing
Else  'Its a Chart page
Application.ScreenUpdating = False
With ActiveChart.PageSetup
.LeftHeader = ""
.CenterHeader = Header
.RightHeader = ""
.LeftFooter = Footer
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.1)
.RightMargin = Application.InchesToPoints(0.1)
.TopMargin = Application.InchesToPoints(1#)
.BottomMargin = Application.InchesToPoints(0.4)
.HeaderMargin = Application.InchesToPoints(0.1)
.FooterMargin = Application.InchesToPoints(0.3)
.ChartSize = xlScreenSize
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = True
.Orientation = xlLandscape
.Draft = False
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
.PaperSize = PaperSize
.FirstPageNumber = xlAutomatic
.BlackAndWhite = False
.Zoom = 100
End With
Application.ScreenUpdating = True
End If
ActiveWindow.SelectedSheets.PrintOut Copies:=NCopies, Collate:=True
End If
End If
Next i
Next j
PrintArea = Null
Application.Calculation = xlCalculationAutomatic
Application.Sheets("Print_Control").Select
End Sub

Sub Setup_Print_Control_Named_Formula()
'
' Setup Print Control Named Range
'
ActiveWorkbook.Names.Add Name:="Print_Control", RefersToR1C1:= _
"=OFFSET(Print_Control!R4C2,1,,COUNTA(Print_Control!R5C2:R24C2),COUNTA(Print_Control!R4))"
ActiveWorkbook.Names("Print_Control").Comment = _
"Used by the Print_Reports Subroutine"
ActiveWorkbook.Names.Add Name:="Copies", RefersToR1C1:= _
"=Print_Control!R26C13"
ActiveWorkbook.Names("Copies").Comment = _
"Specifies the No. of Copies for the Print_Reports Subroutine"
End Sub
Function SheetExists(SheetName As String) As Boolean
' Returns TRUE if the sheet exists in the active workbook
'
' http://www.exceltip.com/st/Determine_if_a_sheet_exists_in_a_workbook_using_VBA_in_Microsoft_Excel/485.html
'
SheetExists = False
On Error GoTo NoSuchSheet
If Len(Sheets(SheetName).Name) > 0 Then
SheetExists = True
Exit Function
End If
NoSuchSheet:
End Function

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Zwei Codezeilen auskommentieren...
12.02.2014 08:53:12
Case
Hallo, :-)
diese beiden Codezeilen auskommentieren:
ActiveWorkbook.Names("Print_Control").Comment = _
"Used by the Print_Reports Subroutine"

ActiveWorkbook.Names("Copies").Comment = _
"Specifies the No. of Copies for the Print_Reports Subroutine"
Servus
Case

Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige