Option Explicit
-><<< A N P A S S E N >>>
->zu suchende Datei-Endung
Const cDATEIENDUNG = .doc
->Kennzeichen zum finden der Tabelle
Const cTXT_UEBERSCHRIFT = Die ist meine gesuchte Ueberschrift
->Verifizierung der der Überschrift folgenden Tabelle durch
Const cTAB_UEBERSCHRIFT_SP1 = Datum
Const cTAB_UEBERSCHRIFT_SP2 = Wertgegenstand
Const cTAB_UEBERSCHRIFT_SP3 = Status
Const cTAB_UEBERSCHRIFT_SP4 = Schätzpreis
Const cTAB_UEBERSCHRIFT_SP5 = Interessent
Const cTAB_ANZSPALTEN = 5
->zu löschende Spalte
Const cTAB_ZULOESCHENDESPALTE = 3
-><<< A N P A S S E N E N D E >>>
Sub Word_AlleFilesImDirectoryUndSubDirectoryBearbeiten()
->Bearbeitet alle Files im Directory und Subdirectories,
->die dem Filetyp msoFileTypeWordDocuments entsprechen
->und die Endung *.doc haben.
->
->Bearbeitung eines Files
->a) Datei öffnen
->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
->c) vorhandene Tabelle untersuchen, welche die nächste zur Überschrift ist.
-> Diese als Kandidat ansehen.
->d) Wenn ein Tabellen-Kandidat vorliegt, weiter Prüfungen
->- Tabellenüberschriften
->- Anzahl Spalten
->es kann noch mehr geprüft werden
->e) Sicherung der Datei anlegen (Dateiname um _SAVEyyyymmdd erweitern)
->g) Spalte in tatsächlicher Datei löschen
->h) 'Datei speichern
->
-> Bearbeitung, Veränderungen und Fehler werden in der Protokoll-Datei festgehalten
->
Const c_LOGFILE = Protokolldatei.txt
Dim fileNum_Protokolldatei As Integer, s_Protokoll_Fullname As String
Dim sFullDateiName As String, sPfad As String, sDateifilter As String
Dim x As Long, attr As Integer
->Pfad und zu suchende Datei-Endung
sPfad = ThisDocument.Path
sDateifilter = *.doc
->Protokolldatei öffen
s_Protokoll_Fullname = ThisDocument.Path & Application.PathSeparator & c_LOGFILE
fileNum_Protokolldatei% = FreeFile()
Open s_Protokoll_Fullname For Append As fileNum_Protokolldatei
Print #fileNum_Protokolldatei, String(80, *)
Print #fileNum_Protokolldatei, String(3, *) & Bearbeitung vom & Format(Now(), yyyy.mm.dd hh:nn)
Print #fileNum_Protokolldatei, String(80, *)
->Alle Files suchen und bearbeiten
With Application.FileSearch
.NewSearch
.LookIn = sPfad
.SearchSubFolders = True
.MatchTextExactly = False
.FileType = msoFileTypeWordDocuments
If .Execute() > 0 Then
For x = 1 To .FoundFiles.Count
If LCase(Right(.FoundFiles(x), Len(cDATEIENDUNG))) = _
LCase(cDATEIENDUNG) Then 'nur Dateien mit gesuchter Datei-Endung
If Left(.FoundFiles(x), 1) <> ~ Then ->temporäre files ausschliessen
If LCase(.FoundFiles(x)) <> _
LCase(ThisDocument.FullName) Then ->die Makro-Datei ausschliessen
attr = GetAttr(.FoundFiles(x))
If 0 <> (attr And vbReadOnly) Then ->Dateischreibschutz ?
->Schreibschutz protokollieren
Print #fileNum_Protokolldatei, FEHLER: Datei-Schreibschutz & .FoundFiles(x)
Else
->Datei bearbeiten
sFullDateiName = .FoundFiles(x)
Call Word_TabelleSpalteLoeschen_EineDatei(fileNum_Protokolldatei, sFullDateiName)
End If
End If
End If
End If
DoEvents->damit die Nachrichtenschlange abgearbeitet werden kann
Next
End If
End With
->Protokolldatei schliessen
Close fileNum_Protokolldatei
MsgBox Protokoll-Datei: & s_Protokoll_Fullname
End Sub
Sub Word_TabelleSpalteLoeschen_EineDatei(fileNum_Protokolldatei As Integer, _
sFullDateiName As String)
Dim doc As Document, t As Table
Dim sFullDateiName_Save As String, sDateiEndung As String
Dim ues() As Long, uesCnt As Long->Fundstellen Überschrift
Dim x As Long, tabInd As Long
Application.StatusBar = sFullDateiName
->Dateiname protokollieren
Print #fileNum_Protokolldatei, String(3, *) & Format(Now(), yyyymmdd_hh:nn:ss ) & String(25, *)
Print #fileNum_Protokolldatei, sFullDateiName
->a) Datei öffnen
On Error Resume Next
Set doc = Documents.Open(FileName:=sFullDateiName)
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Print #fileNum_Protokolldatei, FEHLER: Datei konnte nicht geöffnet werden.
GoTo AUFRAEUMEN
End If
->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
Call UeberschriftSuchen(doc, cTXT_UEBERSCHRIFT, ues(), uesCnt)
If uesCnt = 0 Then
Print #fileNum_Protokolldatei, Überschrift nicht enthalten.
GoTo AUFRAEUMEN
End If
If uesCnt > 1 Then
Print #fileNum_Protokolldatei, FEHLER: Überschrift mehrmals enthalten.
GoTo AUFRAEUMEN
End If
->c) vorhandene Tabelle untersuchen, welche die nächste zur Überschrift ist. Diese als Kandidat ansehen.
Call NaechsteTabelleSuchen(doc, tabInd, ues(1))
If tabInd = 0 Then
Print #fileNum_Protokolldatei, keine passende Tabelle enthalten.
GoTo AUFRAEUMEN
End If
->d) Wenn ein Tabellen-Kandidat vorliegt, weiter Prüfungen
Set t = doc.Tables(tabInd)
->- Tabellenüberschriften
->- Anzahl Spalten
->es kann noch mehr geprüft werden
->(-2 wegen CRLF am Textende)
If Not ( _
(t.Columns.Count = cTAB_ANZSPALTEN) And _
(Left(t.Cell(1, 1).Range.Text, Len(t.Cell(1, 1).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP1) And _
(Left(t.Cell(1, 2).Range.Text, Len(t.Cell(1, 2).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP2) And _
(Left(t.Cell(1, 3).Range.Text, Len(t.Cell(1, 3).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP3) And _
(Left(t.Cell(1, 4).Range.Text, Len(t.Cell(1, 4).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP4) And _
(Left(t.Cell(1, 5).Range.Text, Len(t.Cell(1, 5).Range.Text) - 2) = cTAB_UEBERSCHRIFT_SP5) _
) Then
Print #fileNum_Protokolldatei, keine passende Tabelle enthalten.
GoTo AUFRAEUMEN
End If
Set t = Nothing
Print #fileNum_Protokolldatei, passende Tabelle gefunden.
->e) Sicherung der Datei anlegen (Dateiname um _SAVEyyyymmdd erweitern)
sDateiEndung =
For x = Len(sFullDateiName) To 1 Step -1
If Mid(sFullDateiName, x, 1) = . Then
sDateiEndung = Right(sFullDateiName, Len(sFullDateiName) - x + 1)
ElseIf Mid(sFullDateiName, x, 1) = Application.PathSeparator Then
Exit For
End If
Next
sFullDateiName_Save = Left(sFullDateiName, Len(sFullDateiName) - Len(sDateiEndung)) & _
_SAVE & Format(Now, yyyymmdd) & sDateiEndung
doc.SaveAs FileName:=sFullDateiName_Save
doc.Close
Set doc = Documents.Open(FileName:=sFullDateiName)
->f) in Protokolldatei Sicherung protokollieren (Datei)
Print #fileNum_Protokolldatei, SICHERUNG: & sFullDateiName_Save
->g) Spalte in Tatsächlicher Datei löschen
Set t = doc.Tables(tabInd)
On Error Resume Next
t.Columns(cTAB_ZULOESCHENDESPALTE).Delete
If Err.Number <> 0 Then
Err.Clear: On Error GoTo 0
Print #fileNum_Protokolldatei, FEHLER: Spalte konnte nicht gelöscht werden.
GoTo AUFRAEUMEN
End If
On Error GoTo 0
->h) in Protokolldatei Spaltenlöschung protokollieren
Print #fileNum_Protokolldatei, Spalte gelöscht
->Datei speichern
doc.Save
Print #fileNum_Protokolldatei, Datei gespeichert
AUFRAEUMEN:
On Error Resume Next
doc.Close Savechanges:=wdDoNotSaveChanges
Err.Clear: On Error GoTo 0
Application.StatusBar =
Set doc = Nothing: Set t = Nothing
End Sub
Private Function NaechsteTabelleSuchen(doc As Document, tabInd As Long, StartUeberschrift As Long)
Dim tabStart As Long, x As Long
tabStart = 2147483647->maximum long
tabInd = 0
For x = 1 To doc.Tables.Count
With doc.Tables(x).Range
If .start < tabStart And .start > StartUeberschrift Then tabStart = .start: tabInd = x
End With
Next
End Function
Private Function UeberschriftSuchen(doc As Document, sUeberschrift As String, ues() As Long, uesCnt As Long)
->b) Überschrift suchen (eventuell mehrere Fundorte behandeln)
uesCnt = 0: ReDim ues(1 To 1)
With doc.Content.Find
.ClearFormatting
.Forward = True
.Format = False
.MatchCase = True
.Wrap = wdFindStop
.Text = sUeberschrift
Do While .Execute() = True
With .Parent
uesCnt = uesCnt + 1: ReDim Preserve ues(1 To uesCnt)
ues(uesCnt) = .start
End With
Loop
End With
End Function
?