title image


Smiley Re: Index anlegen?
Hallo!



Hier ist ein Paket zur Erstellung neuer

Indices.



Gepflegt wird nicht der Index direkt, sondern die zweispaltige

Konkordanzdatei, aus der der Index jeweils neu generiert werden

kann.



Es geht das ganze Dokument durch und

erfragt für jedes Wort, ob es aufgenommen

werden soll. Dabei merkt es sich die Worte,

die aufgenommen werden sollen oder nicht

aufgenommen werden sollen.

Dadurch kann man das Programm später über ein

geändertes Word-Dokument rüber laufen lassen und

es erfragt nur neue Worte.



Einige Worte, die nicht auf genommen werden sollen,

kennt das Programm schon.

Andere lassen sich in

http://wortschatz.uni-leipzig.de/Papers/top10000de.txt

auf

http://wortschatz.uni-leipzig.de

finden.



Diese List sollte nach einer Sichtung in

die Datei

Const strPfad_NichtAufnehmen = "U:\Index_NichtAufnehmen.doc"

aufgenommen werden.

Sie wird vom Programm dann weiter ergänzt.



Pfade

' Pfad der Konkordanzdatei mit den Worten, die in den Index aufzunehmen sind.

' Pfad gilt fürs ganze Modul

Const strPfad_Aufnehmen = "U:\Index_Aufnehmen.doc"

' Pfad der Datei mit den Worten, die nicht in den Index aufzunehmen sind.

Const strPfad_NichtAufnehmen = "U:\Index_NichtAufnehmen.doc"



bitte anpassen!



Gruß, Chrisir







Option Explicit



' Modul mit Thema Index (Stichwortverzeichnis, Konkordanz) am Ende

' des Dokuments.

'

' Gepflegt wird nicht der Index direkt, sondern die zweispaltige

' Konkordanzdatei, aus der der Index jeweils neu generiert werden

' kann.

'

' Weitere Kommentare unten; weitere Worte, die nicht

' in den Index aufzunehmen sind, auch unten.

'

' Pfad der Konkordanzdatei mit den Worten, die in den Index aufzunehmen sind.

' Pfad gilt fürs ganze Modul

Const strPfad_Aufnehmen = "U:\Index_Aufnehmen.doc"

' Pfad der Datei mit den Worten, die nicht in den Index aufzunehmen sind.

Const strPfad_NichtAufnehmen = "U:\Index_NichtAufnehmen.doc"

' Titel

Const strTitel = "Index-Pflege"





' **********************************************************

' Hauptroutinen

' **********************************************************



Sub MakroIndex_ZurWartungAufzunehmendeWorteLaden()      ' Laden

    Documents.Open (strPfad_Aufnehmen) ' Pfad wie oben angegeben

End Sub



Sub MakroIndex_ZurWartungNichtAufzunehmendeWorteLaden()      ' Laden

    Documents.Open (strPfad_NichtAufnehmen) ' Pfad wie oben angegeben

End Sub



Sub MakroIndex_EintraegeUndIndexLoeschenUndNeuErstellen()

    DeleteAlleIndexEintraegeUndDenIndex

    MakroIndex_IndexAmEndeUndAlleEintraegeEinfuegen

End Sub



Sub MakroIndex_AlleWorteImDokumentDurchgehen()

    

    ' Makro geht alle Worte in einem Dokument durch und erfragt für jedes,

    ' ob es in den Index soll oder nicht.

    ' Beide Dateien, strPfad_Aufnehmen und strPfad_NichtAufnehmen,

    ' müssen schon existieren,

    ' strPfad_Aufnehmen muss eine zweispaltige Tabelle enthalten.

    ' In der linken Spalte stehen dabei die Wortformen, die im

    ' Dokument auftauchen (z.B. lief laufend gelaufen), in der

    ' rechten Spalte das Wort, das im Index stehen soll (Laufen).

    ' Praktisch ist die Möglichkeit, die Tabelle nach Ende des Makros zu

    ' sichten ("Laufen" eintragen!) und dann zu

    ' sortieren (Menü Tabelle).

    '

    ' Achtung! Triviale Worte "constStrTrivialeWorte1"

    ' im Makro ggf. noch anpassen (s.u.).

    

    ' Liste der trivialen Worte; erstreckt sich über mehrere Konstanten.

    Const constStrTrivialeWorte1 = "der#die#das#der die das ein eine einer eines einem " & _

    "in im bei um und dass daß über den von ohne " & _

    "den soll hier nur das behandelt werden D.h. ein von mehreren soll in" & _

    "ab  diesen  große  numerischen  transputernetz" & _

    "aber  dieser  großen  nun  über" & _

    "ablaufen  dieses  haben  nur  um" & _

    "abschnitt  dimension  häufig  oben  unabhängig" & _

    "adaption  direkt  hardware  oder  und" & _

    "adaptionsschritt  dort  hat  ohne  ungleichgewichte" & _

    "algorithmen  drei  heute  operationen  unstrukturierten" & _

    "algorithmus  durch  hier  optimal  unter" & _

    "alle  durchgeführt  hilfe  optimale  unterschiede" & _

    "allen  dynamische  im  optimierung  untersuchen" & _

    "als  dynamischen  immer  optimierungsschritte  varianten" & _

    "also  ebenfalls  implementiert  parallel  verfahren" & _

    "am  effekte  in  parallele  verfahrens" & _

    "an  effiziente  indem  parallelen  verfeinert" & _

    "andere  effizienz  innerhalb  parallelisierung  verfeinerung" & _

    "anderen  effizienzen  insbesondere  parallelität" & _

    "anzahl  ein  ist  parix  verhalten" & _

    "eine  jede  periodische  verschieben" & _

    "arbeiten  einem  jedem  periodischen  verschiedene" & _

    "arbeitet  einen  jeden  phase  verschiedenen" & _

    "art  einer  jeder  phasen  version" & _

    "auch  eines  jedes  praktisch  verteilt"



    Const constStrTrivialeWorte2 = "auf  einfach  jetzt  verteilung" & _

    "aufgrund  einfache  jeweils  verwenden" & _

    "aufteilung  einige  kann  verwendet" & _

    "aus  einigen  verwendete" & _

    "austausch  einmal  kein  programm  verwendeten" & _

    "bearbeitet  einsatz  keine  programme  verwendung" & _

    "behandelt  einzelnen  klar  programms  viele" & _

    "bei  element  kleine  prozessor  vielen" & _

    "beiden  elemente  kleinen  prozessoren  vier" & _

    "beim  elementen  kleiner  prozessorzahlen  virtuellen" & _

    "benötigt  elements  knoten  punkt  völlig" & _

    "berechnen  enthalten  können  punkte  vollständig" & _

    "berechnet  entsprechend  kommunikation  ränder  vom" & _

    "berechnung  entsprechenden  kommunikationen  rand  von" & _

    "berechnungen  entwickelt  koordinaten  randbedingungen  vor" & _

    "bereich  er  kurz  rechenzeit  vorhanden" & _

    "berücksichtigt  ergeben  läßt  rechner  vorigen" & _

    "beschleunigung  ergebnis  lassen  relativ  während" & _

    "beschränkt  ergebnisse  last  schon  war" & _

    "beschrieben  ergibt  lastverteilung  schritt  was" & _

    "beschriebenen  erhalten  laufzeit  weitere" & _

    "besonders  erreicht  laufzeiten  sehen  weiteren" & _

    "besteht  erst  liegen  sehr  weiterer" & _

    "bestimmt  ersten  liegt  sein  wenige" & _

    "erweiterungen  links  seine  wenn"

 

    Const constStrTrivialeWorte3 = " beteiligt  erzeugt  listen  seite  werden " & _

    "beteiligten  es  selbst  wert" & _

    "betrachten  etwa  lösungen  sequentiellen  werte" & _

    "betrachtet  exakt  lokal  sich  wesentlichen" & _

    "betriebssystem  fällen  lokale  sie  wie" & _

    "bild  fall  lokalen  sind  wieder" & _

    "bis  fast  man  sinnvoll  wir" & _

    "bzw  fein  massiv  so  wird" & _

    "da  feste  maximal  solche  wo" & _

    "dabei  finiten  mehr  solchen  wobei" & _

    "dagegen  folgende  mehrere  solcher  wollen" & _

    "daher  folgenden  meist  solches  workstation" & _

    "damit  frage  messungen  soll  wurde" & _

    "danach  führen  methode  sollen  wurden" & _

    "dann  führt  mit  sollte  zahl" & _

    "daraus  für  möglich  sondern  zeigt" & _

    "dargestellt  funktionen  möglichst  speedup  zeilen" & _

    "das  ganz  müssen  speedups  zeit" & _

    "daß  gebiets  muß  speicher  zeiten" & _

    "daten  geeignet  nach  spezielle  zeitschritt" & _

    "datenstrukturen  geeigneten  natürlich  speziellen  zeitschritte"

 

    Const constStrTrivialeWorte4 = " dazu  gegen  netz  startverteilung  zu" & _

    "dem  genau  netzaufteilung  strategie  zugehörigen" & _

    "den  geometrie  netzdichte  strömungen  zum" & _

    "denen  gerade  netze  strömungsgrößen  zunächst" & _

    "der  gibt  netzen  struktur  zur" & _

    "des  gilt  netzes  system  zusätzlich" & _

    "deutlich  gleichungen  neue  systeme  zusätzliche" & _

    "die  globale  neuen  systemen  zusätzlichen" & _

    "dies  globalen  nicht  tatsache  zwar" & _

    "diese  grenzen  noch  teil  zwei" & _

    "dieselben  größe  notwendig  teile  zweite" & _

    "diesem  größen  notwendigen  transputer  zwischen" & _

    "Die  häufigsten Worte aus einer naturwissenschaftlichen Dissertation." & _

    "Die Stichprobe hat einen Umfang von  Worten. Es gibt  verschiedene Worte,  kommen einmal vor,  kommen mindestens  mal vor." & _

    "Der typische Sprachumfang eines Engländers beträgt  Wörter, eines Deutschen  Wörter. Goethe beherrschte etwa  Wörter. Englische Verben haben etwa  Flexionen, deutsche etwa :" & _

    "speak spreche speaks sprichst spoke spricht spoken sprechen   sprecht   sprach" & _

    "sprachst   sprachen   spracht   spräche   sprächest   sprächen" & _

    "sprächet Durch Komposita und Derivationen entstehen im Deutschen neue Wörter" & _

    "Elbe Mündung = Elbmündung" & _

    "Hochzeit Torte = Hochzeitstorte" & _

    "hin fahren = hinfahren" & _

    "Insgesamt führt dies im deutschen Sprachraum zu etwa  Wortformen." & _

    "Eine zusätzliche Schwierigkeit verursachen die Homophone, z.B. Meer/mehr; floh/Floh. Ihre korrekte Schreibweise läßt sich nur kontextbezogen ermitteln:" & _

    "Der junge Junge fiel viel und fällt noch immer viel auf dem Feld." & _

    "Der gefangene Floh."

        

    Dim wordMyWord                                  ' Worte im Dokument

    Dim strTrivialeWorte                            ' Triviale Worte aus Konstanten oben

    Dim strTrivialeWorteNeu                         ' Gelernte (neu) triviale Worte aus Dokument und aus Eingaben

    Dim strAufzunehmendeWorte                       ' soll in den Index augenommen werden

    Dim intAntwort                  As Integer      ' Antwort

    Dim docQuellDoc                 As Document     ' Dokument, das duchgegangen wird

    Dim docDokument_Aufnehmen       As Document     ' Dokument mit den aufzunehmen Worten

    Dim strMeldung                  As String       ' für MsgBox

    

    

    If Documents.Count <= 0 Then Exit Sub



    strTrivialeWorte = constStrTrivialeWorte1 & _

                       constStrTrivialeWorte2 & _

                       constStrTrivialeWorte3 & _

                       constStrTrivialeWorte4

    

    Set docQuellDoc = ActiveDocument

    

    ' Laden

    Documents.Open strPfad_NichtAufnehmen

    strTrivialeWorteNeu = strTrivialeWorteNeu & ActiveDocument.Range.Text

    ' Schließen

    ActiveDocument.Close

    

    ' Laden, bleibt offen

    Set docDokument_Aufnehmen = Documents.Open(strPfad_Aufnehmen) ' Pfad wie oben angegeben

    strAufzunehmendeWorte = strAufzunehmendeWorte & ActiveDocument.Range.Text

    If docDokument_Aufnehmen.Tables.Count <= 0 Then

        MsgBox "Keine Tabelle in " & strPfad_Aufnehmen & "gefunden. Deshalb Abbruch.", vbCritical, strTitel

        Exit Sub

    End If

    

    ' Alle Worte im Dokument durchgehen:

    For Each wordMyWord In docQuellDoc.Words

    

        ' Ist das Wort lang genug und unbekannt?

        If Trim(wordMyWord) <> "" And _

           Len(Trim(wordMyWord)) > 1 And _

           InStr(1, UCase(strAufzunehmendeWorte), UCase(Trim(wordMyWord))) <= 0 And _

           InStr(1, UCase(strTrivialeWorteNeu), UCase(Trim(wordMyWord))) <= 0 And _

           InStr(1, UCase(strTrivialeWorte), UCase(Trim(wordMyWord))) <= 0 _

           Then

            

           ' Dann erfragen, ob es aufgenommen werden soll:

           intAntwort = MsgBox(wordMyWord & " aufnehmen?" & vbNewLine & _

                               "Sie können jederzeit Abbrechen drücken, da bei Abbruch noch gespeichert wird.", _

                               vbQuestion + vbYesNoCancel, _

                               strTitel)

           

           ' Antwort auswerten

           Select Case intAntwort

             Case vbYes

                ' Ja

                strAufzunehmendeWorte = strAufzunehmendeWorte & Trim(wordMyWord) & vbNewLine

                docDokument_Aufnehmen.Tables(1).Rows.Add

                docDokument_Aufnehmen.Tables(1).Rows.Last.Cells(1).Range.Text = Trim(wordMyWord)

             Case vbNo

                ' Nein

                strTrivialeWorteNeu = strTrivialeWorteNeu & " " & Trim(wordMyWord)

             Case vbCancel

                ' Abbruch der Schleife

                Exit For

             Case Else

                ' Fehler

                MsgBox "Fehler bei Select Case.", vbCritical, strTitel

            End Select

            

        End If

        

    Next wordMyWord



    ' Dokument komplett neu schreiben :

    Documents.Open strPfad_NichtAufnehmen

    ActiveDocument.Range.Delete

    ActiveDocument.Range.Text = strTrivialeWorteNeu

    ' Speichern und Schließen

    ActiveDocument.Close wdSaveChanges

    

    ' Meldung

    strMeldung = "Fertig. Speichern Sie nun das Dokument mit der Tabelle." & _

           vbNewLine & _

           "Benutzen Sie den Makro MakroIndexUndEintraegeAmEndeEinfuegen oder wählen Sie im Quelldokument Menü Einfügen | Index und hier AutoMarkierung." & _

           vbNewLine & _

           "Verweisen Sie auf das entsprechende Dokument: " & _

           strPfad_Aufnehmen & _

           "."

    MsgBox strMeldung, _

           vbInformation, _

           strTitel & "Info"

           



End Sub



Sub MakroIndex_IndexAmEndeUndAlleEintraegeEinfuegen()

'

' Erstellt auf Basis eines vorhandenen Konkordanz-Dokuments (Konkordanzdatei) alle

' Index-Einträge und den Index am Ende des Dokuments.

'

' Makro am 21.08.2003

'

    

    If Documents.Count <= 0 Then Exit Sub



    ActiveWindow.ActivePane.View.ShowAll = True

    ActiveDocument.Indexes.AutoMarkEntries ConcordanceFileName:=strPfad_Aufnehmen  ' Pfad wie oben



    Selection.HomeKey unit:=wdStory

    Selection.EndKey unit:=wdStory

    

    Selection.TypeParagraph

    Selection.TypeParagraph

    Selection.TypeParagraph

    Selection.Range.Bold = True

    Selection.TypeText Text:="Index"

    Selection.Range.Bold = False

    Selection.TypeParagraph

    Selection.TypeParagraph

    Selection.TypeParagraph

    Selection.MoveUp unit:=wdLine, Count:=1

    With ActiveDocument

        .Indexes.Add Range:=Selection.Range, HeadingSeparator:= _

            wdHeadingSeparatorNone, Type:=wdIndexIndent, RightAlignPageNumbers:= _

            False, NumberOfColumns:=2, IndexLanguage:=wdGerman

        .Indexes(1).TabLeader = wdTabLeaderDots

        

    End With

    

    With ActiveDocument.Indexes(1)

        .HeadingSeparator = wdHeadingSeparatorLetter

        .Type = wdIndexIndent

        .RightAlignPageNumbers = True

        .NumberOfColumns = 2

        .IndexLanguage = wdGerman

        .TabLeader = wdTabLeaderDots

    End With

    

    MsgBox "Fertig.", vbInformation, strTitel

    

End Sub



Sub DeleteAlleIndexEintraegeUndDenIndex()



    ' Löscht alle Einträge und den Index am Ende



    Dim fieldMyField1   As Field    ' Alle Felder im Dokument durchgehen

    Dim strMeldung      As String   ' Für MsgBox

    

    

    If Documents.Count <= 0 Then Exit Sub

    

    strMeldung = "Sind Sie sicher, dass Sie alle Einträge und den Index löschen wollen?" & _

                 vbNewLine & _

                 "Aktives Dokument ist " & _

                 ActiveDocument.Name & _

                 "."

    If MsgBox(strMeldung, vbCritical + vbYesNoCancel, strTitel) <> vbYes Then End

    

    strMeldung = "             Sind Sie wirklich sicher? "

    If MsgBox(strMeldung, vbCritical + vbYesNo, strTitel) <> vbYes Then End

    

    For Each fieldMyField1 In ActiveDocument.Fields

        If fieldMyField1.Type = wdFieldIndexEntry Then

            fieldMyField1.Delete

        End If

    Next fieldMyField1

    

    If ActiveDocument.Indexes.Count > 0 Then

        With ActiveDocument.Indexes(1)

            .Delete

        End With

    End If

    

    MsgBox "Löschen beendet.", vbInformation, strTitel & ": Löschen"

    

End Sub



Sub VordieZellenEtwasEinsetzen()



    ' Vor jede der markierten Zellen einen bestimmten Text setzen.



    Dim cellMyCell    As Cell      ' Alle Zellen in der Markierung durchgehen

    Dim strText       As String    ' eingegebener Text

    Dim strMeldung    As String    ' Für InputBox

    



    If Documents.Count <= 0 Then Exit Sub

    strMeldung = "Bitte geben Sie den Text an, der vor jede der markierten Zellen gesetzt werden soll."

    strText = InputBox(strMeldung, _

                       "Text einfügen", _

                       "")

    If Right(strText, 1) <> ":" Then strText = strText + ":"

    

    For Each cellMyCell In Selection.Cells

    

        cellMyCell.Range.Text = strText & strFuncZellenInhalt(cellMyCell)



    Next cellMyCell

    

End Sub



' **********************************************************

' Hilfsroutinen

' **********************************************************



Private Function strFuncZellenInhalt(cellMyCell As Cell) As String



    ' Liefert der Zellinhalt ohne Absatzmarke und Zellenendzeichen

    

    strFuncZellenInhalt = Left(cellMyCell.Range.Text, Len(cellMyCell.Range.Text) - 2)



End Function







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: