Code
26.11.2004 12:59:01
Jan
Sub PDF_printing()
i = 2
Do Until IsEmpty(Cells(i, 2).Value)
Dim strFileName As String
Dim strOriginPath As String
Dim strTargetPath As String
Dim strSubPath As String
strFileName = Cells(i, 2).Value & Cells(i, 3).Value
strOriginPath = "K:\BBA\BBAR\REPO\REPOSAVE\"
strTargetPath = "K:\BBA\BBAR\REPO\REPOSAVE\"
f1_JahresIndex = Right(strFileName, 6)
JahresIndex = Left(f1_JahresIndex, 2)
LängeSTRFILENAME = Len(strFileName)
'MsgBox LängeSTRFILENAME
If LängeSTRFILENAME = 11 Then
Monatsindex = Mid(strFileName, 5, 1)
ElseIf LängeSTRFILENAME = 12 Then
Monatsindex = Mid(strFileName, 5, 2)
End If
'MsgBox Monatsindex & JahresIndex
If Monatsindex = 1 Then
Monat = "01 Januar"
ElseIf Monatsindex = 2 Then
Monat = "02 Februar"
ElseIf Monatsindex = 3 Then
Monat = "03 März"
ElseIf Monatsindex = 4 Then
Monat = "04 April"
ElseIf Monatsindex = 5 Then
Monat = "05 Mai"
ElseIf Monatsindex = 6 Then
Monat = "06 Juni"
ElseIf Monatsindex = 7 Then
Monat = "07 Juli"
ElseIf Monatsindex = 8 Then
Monat = "08 August"
ElseIf Monatsindex = 9 Then
Monat = "09 September"
ElseIf Monatsindex = 10 Then
Monat = "10 Oktober"
ElseIf Monatsindex = 11 Then
Monat = "11 November"
ElseIf Monatsindex = 12 Then
Monat = "12 Dezember"
End If
'MsgBox Monat
If JahresIndex = 0 Then
Jahr = "2000 Reposave"
ElseIf JahresIndex = 1 Then
Jahr = "2001 Reposave"
ElseIf JahresIndex = 2 Then
Jahr = "2002 Reposave"
ElseIf JahresIndex = 3 Then
Jahr = "2003 Reposave"
ElseIf JahresIndex = 4 Then
Jahr = "2004 Reposave"
ElseIf JahresIndex = 5 Then
Jahr = "2005 Reposave"
End If
'MsgBox Jahr
strSubPath = strTargetPath & Jahr & "\" & Monat & "\"
'MsgBox strSubPath
Workbooks.Open Filename:= _
"K:\BBA\BBAR\REPO\REPOSAVE\" & strFileName, _
UpdateLinks:=0
Dim objDistiller As New ACRODISTXLib.PdfDistiller6
Dim OldPname As String
Dim TempPname As String
OldPname = Application.ActivePrinter
For J = 0 To 99
On Error Resume Next
If J < 10 Then
TempPname = "Adobe PDF on Ne0" & J & ":"
Application.ActivePrinter = TempPname
ElseIf J >= 10 Then
TempPname = "Adobe PDF on Ne" & J & ":"
Application.ActivePrinter = TempPname
End If
If Application.ActivePrinter = TempPname Then
Exit For
End If
Next J
Application.ActivePrinter = "TempPname"
objDistiller.bShowWindow = False
ActiveWindow.SelectedSheets.PrintOut , printtofile:=True, _
Collate:=True, prtofilename:=strOriginPath & strFileName & ".ps"
objDistiller.FileToPDF strOriginPath & strFileName & ".ps", strSubPath & strFileName & ".pdf", ""
Kill strOriginPath & strFileName & ".ps"
Set objDistiller = Nothing
Workbooks(strFileName).Activate
Application.Wait TimeSerial(Hour(Now), Minute(Now), Second(Now) + 1)
ActiveWindow.Close SaveChanges:=False
Kill strSubPath & strFileName & ".log"
On Error Resume Next
i = i + 1
Loop
End Sub
Sub Auswahl_drucken()
ScreenUpdate = False
i = 2
Application.Dialogs(xlDialogPrinterSetup).Show
Do Until IsEmpty(Cells(i, 1).Value)
ZR = Cells(i, 2).Value
ANZ_KOP = Cells(i, 1).Value
BERICHTSMONAT = Cells(i, 3).Value
ChDir "K:\BBA\BBAR\REPO\REPOSAVE\"
Workbooks.Open Filename:= _
"K:\BBA\BBAR\REPO\REPOSAVE\" & ZR & BERICHTSMONAT, _
UpdateLinks:=0
ActiveWindow.SelectedSheets.PrintOut Copies:=ANZ_KOP, Collate:=True
ActiveWindow.Close SaveChanges:=False
On Error Resume Next
i = i + 1
Loop
ScreenUpdate = True
End Sub