Mit Makro andere xls-datei öffnen & Header einfüge
20.10.2005 08:57:30
Max
ich habe mir ein Makro geschrieben, welches ich mit dem Short-Key Strg+y aufrufe. Dann öffnet sich ein fenster in dem ich einen Ordner auswählen kann, aus welchem sich das Makro alle darin enthaltenen Dateien per Loop holt und mir die Datei-Details (Dateiname, Pfad,...) in meinem aktuellen Worksheet darstellt.
Soweit so gut. Jetzt zu meinem problem. Ich möchte, dass das Makro bei jeder dieser Dateien, die es im Ordner findet, die Seiteneigenschaften ändert, d.h. bei allen die gleiche Kop- und Fusszeile einfügt und dann die datei abspeichert. Wie kann ich das realisieren?
Ich habe sowohl den Code zum durchsuchen des Ordners und darstellen der Dateidetails (Dateiname, Pfad,...), als auch den Code zum ändern der Seiteneigenschaften (Kopf- und Fusszeile). Allerdings krieg ich es nicht gebacken, dass er eben bei jeder dieser dateien diesen code anwendet.
Hier der komplette Code, wäre super wenn ihr mir helfen könntet:
'#############################
'Dieser Bereich kann entfallen,
'wenn der Variable 'Laufwerk'
'ein fester Wert zugewiesen wird.
Public Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Declare
Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" _
(ByVal pidl As Long, ByVal pszPath As String) As Long
Declare
Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private z!
'Ruft das Dialogfeld zur Ordnerauswahl auf
Function GetDirectory(Msg) As String
Dim bInfo As BROWSEINFO
Dim path As String
Dim r As Long, x As Long, pos As Integer
With bInfo
.pidlRoot = 0&
.lpszTitle = Msg
.ulFlags = &H1
End With
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
GetDirectory = Left(path, pos - 1)
Else
GetDirectory = ""
End If
End Function
Sub Dateisuche(Laufwerk, Dateien)
Dim tmp, Wdhlg, Dateiname As String
On Error Resume Next
If Right(Laufwerk, 1) <> "\" Then Laufwerk = Laufwerk + "\"
tmp = Dir(Laufwerk & Dateien)
Do While Len(tmp)
Dateiname = Laufwerk & tmp
Application.StatusBar = Dateiname
Cells(z, 1).Select
Cells(z, 1) = Laufwerk & tmp 'Pfad
Cells(z, 2) = FileLen(Laufwerk & tmp) 'Größe
Cells(z, 3) = FileDateTime(Laufwerk & tmp) 'Datum/Zeit
Cells(z, 4) = tmp 'nur Dateiname
Pfadzurdatei = Laufwerk & tmp
'HIER WEISS ICH JETZT NICHT MEHR WEITER;
'WIE DER DEN JETZT FOLGEN DEN CODE AUF
'JEDE DATEI ANWENDET; D:H: BEI JEDER DATEI
'DIE KOPF-UND-FUSSZEILE ÄNDERT...
Dim wsSheet As Worksheet
For Each wsSheet In Worksheets
With wsSheet.PageSetup
.LeftHeader = "&""CorpoS,Standard""&8Max Maier"
.CenterHeader = "&""CorpoS,Standard""&8Information"
.RightHeader = ""
.LeftFooter = "&""CorpoS,Standard""&8Pfad" & Chr(10) & "&Z&F"
.CenterFooter = ""
.RightFooter = "&""CorpoS,Standard""&8Printed on &D, &T" 'CorpoS ist die Schriftart
.LeftMargin = Application.InchesToPoints(0.78740157480315)
.RightMargin = Application.InchesToPoints(0.78740157480315)
.TopMargin = Application.InchesToPoints(0.984251968503937)
.BottomMargin = Application.InchesToPoints(0.984251968503937)
.HeaderMargin = Application.InchesToPoints(0.511811023622047)
.FooterMargin = Application.InchesToPoints(0.511811023622047)
' .PrintHeadings = False
' .PrintGridlines = False
' .PrintComments = xlPrintNoComments
' .PrintQuality = 600
' .CenterHorizontally = False
' .CenterVertically = False
' .Orientation = xlLandscape
' .Draft = False
' .PaperSize = xlPaperA4
' .FirstPageNumber = xlAutomatic
' .Order = xlDownThenOver
' .BlackAndWhite = False
' .Zoom = 65
' .PrintErrors = xlPrintErrorsDisplayed
End With
Next wsSheet
Pfadzurdatei.Save
z = z + 1
tmp = Dir()
Loop
tmp = Dir(Laufwerk, vbDirectory)
Do While Len(tmp)
If (tmp <> ".") And (tmp <> "..") Then
If (GetAttr(Laufwerk & tmp) And vbDirectory) = vbDirectory Then
Dateisuche Laufwerk & tmp, Dateien
z = z - 1
Wdhlg = Dir(Laufwerk, vbDirectory)
z = z + 1
Do While Wdhlg <> tmp
Wdhlg = Dir()
Loop
End If
End If
tmp = Dir()
Loop
On Error GoTo 0
Application.StatusBar = False
End Sub
'Aufruf mit dem folgenden Makro
Sub Suchen()
Dim Laufwerk$, Dateien$
'Ersze Zeile, in der eine Eintragung erfolgt
z = 2
'Alte Eintragungen löschen
[a1:e5000] = ""
'Den Variablen Laufwerk und Dateien kann
'auch ein direkter Wert zugewiesen werden.
'Ersatz: ... = "C:\Eigene Dateien"
Laufwerk = GetDirectory("Bitte einen Ordner wählen")
If Laufwerk = "" Then Exit Sub
'Ersatz: Dateien = "*.*"
Dateien = InputBox("Nach welchen Dateien soll in" & _
Chr(10) & " " & Laufwerk & Chr(10) & _
"gesucht werden (z. B. *.xls)?", _
"Dateityp", "*.*")
If Dateien = "" Then Exit Sub
Dateisuche Laufwerk, Dateien
End Sub