Re: Matthias -> Quellcode
16.05.2002 08:10:24
Klaus-Dieter
Hi Matthias,da ich nicht deine E-Mail-Adresse habe, zeige ich Dir hier den Code von dem einem Modul, in dem der Druckvorgang gestartet werden soll:
Sub Suchen()
Dim DateiName As String
Dim PortID As String
Dim BenGrp As String
Dim PfadUndDatei As String
Dim Jahr As String
Dim Monat As Double
Dim AMonat As String
Dim Tag As Double
Dim ATag As String
Dim BefDat As String
Dim pfad As String
Dim FBEPfad As String
Dim QuellDatPGP As String
Dim QuellDatDOC As String
Dim Zielpfad As String
Dim Wahl As String
Dim Letzte As Long
Dim datei As String
Dim PN As String
'Dim sFileName As String
'Dim wApp As New Word.Application
'Dim Start As Single
PN = "TRANSFER-TOOL"
datei = "Transfer-Tool.xls"
Set FBESuche = Application.FileSearch
PfadLZ = "J:\Projekte\Land_BW\LVN III Betrieb\Laufzettel\3.) Laufzettel"
pfad = "J:\Projekte\Land_BW\LVN III Betrieb\Laufzettel\"
FBEPfad = "J:\Projekte\Land_Bw\LVN III Betrieb\Laufzettel\4.) Funktionsbereitschaftserklärung\"
Jahr = Year(Date) 'Datum für Betreff generieren
Monat = Month(Date)
If Monat < 10 Then
AMonat = "0" & Monat
End If
Tag = Day(Date)
If Tag < 10 Then
ATag = "0" & Tag
Else
ATag = Tag
End If
Jahr = Right(Jahr, 2)
BefDat = Jahr & AMonat & ATag
With FBESuche
.LookIn = "J:\Projekte\Land_Bw\LVN III Betrieb\Laufzettel\4.) Funktionsbereitschaftserklärung"
.FileName = "FBE*.doc.pgp"
If .Execute > 0 Then
MsgBox "Es wurde(n) " & .FoundFiles.Count & " FBE(s) gefunden, die zur Versendung bereitstehen.", vbInformation, PN
For I = 1 To .FoundFiles.Count
.FileName = .FoundFiles(I)
PfadUndDatei = .FoundFiles(I)
DateiName = .FileName
PortID = Right(DateiName, 21)
BenGrp = Left(PortID, 4)
PortID = Right(PortID, 16)
PortID = Left(PortID, 8)
MkDir pfad & PortID
QuellDatPGP = "FBE_" & Jahr & AMonat & ATag & "_" & BenGrp & "_" & PortID & ".doc.pgp"
QuellDatDOC = "FBE_" & Jahr & AMonat & ATag & "_" & BenGrp & "_" & PortID & ".doc"
eMailAusExcelVersenden.eMailVersenden BefDat, BenGrp, PortID, PfadUndDatei
Zielpfad = pfad & PortID & "\"
FileCopy FBEPfad & QuellDatPGP, Zielpfad & QuellDatPGP
FileCopy FBEPfad & QuellDatDOC, Zielpfad & QuellDatDOC
' sFileName = FBEPfad & QuellDatDOC
' With wApp
' .Documents.Open sFileName
' .ActiveDocument.PrintOut
' Start = Timer ' Anfangszeit setzen.
' Do While Timer < Start + 40
' DoEvents ' Steuerung an andere Prozesse
' Loop
' .Quit
' End With
' Set wApp = Nothing
Kill FBEPfad & QuellDatPGP 'VORSICHT mit diesem Befehl!
Kill FBEPfad & QuellDatDOC 'löscht ohne zu fragen!
Workbooks(datei).Sheets(1).Activate
Letzte = ActiveSheet.UsedRange.Rows.Count
Workbooks(datei).Sheets(1).Cells(Letzte + 1, 1).Value = PortID
Workbooks(datei).Sheets(1).Cells(Letzte + 1, 2).Value = ATag & "." & _
AMonat & "." & Jahr
Workbooks(datei).Sheets(1).Cells(Letzte + 1, 3).Value = QuellDatDOC
Workbooks(datei).Sheets(1).Cells(Letzte + 1, 4).Value = QuellDatPGP
Next I
MsgBox "Es wurde(n) " & .FoundFiles.Count & " eMail(s) verschickt.", vbInformation, PN
Wahl = MsgBox("Sollen die Laufzettel jetzt automatisch in die Archiv-Ordner verschoben werden?", vbYesNo, PN)
If Wahl = vbYes Then
LaufzettelSuchenAblegen.Laufzettel
End If
MsgBox "Vergessen Sie nicht die FBEs und Laufzettel auszudrucken!", vbInformation, PN
Else
MsgBox "Es liegen keine FBEs zur Versendung vor!" & Chr(13) & Chr(13) & _
"Info:" & Chr(13) & Chr(13) & _
"Evtl. haben Sie vergessen, die Dateien zu verschlüsseln.", vbCritical, PN
End If
Workbooks(datei).Save
End With
End Sub