title image


Smiley Re: Erstellung von Vokabelkärtchen
Bitte ab option explicit einbringen.



neue Version:











Option Explicit



' Wie bringe ich einen Makro ein?

' Siehe

' http://mypage.bluewin.ch/reprobst/WordFAQ/Button.htm



' Auch möglich: Menü Datei|Neu, neue Vorlage mit leerem

' Dokument. Alt-F11 im VBA-Editor Menü Einfügen|Modul,

' den Quelltext einfügen. Mit Alt-F11 zu Word zurückkehren,

' Vokabelliste laden. Alt-F11 und die Zeile

' Public Sub Karteikarten() mit dem Cursor ansteuern,

' F5 drücken.



' Erstellt aus einer zweispaltigen Tabelle

' mit Vokabeln eine 4-spaltige Tabelle für

' Vokabelkarten. Dabei gehören je Seite 1 und 2,

' Seite 3 und 4, 5 und 6 etc. so zusammen, dass

' man sie als Vorder- und Rückseite (bzw. Duplexdruck)

' verwenden kann. Die Vokabeln des Ursprungsdokuments

' sind dabei so angeordnet, dass zusammengehörige

' Vokabeln auf Vorder- und Rückseite einer Karte

' zu stehen kommen.

' Die Werte von constIntZeilenanzahlSeite  und

' constLongHoeheZeileZentimeter können angepasst werden.

' Anpassungen sind auch in der sub DinA4Format möglich;

' hier z.B. Seitenränder anpassen.



' Code z.T. von

' http://mypage.bluewin.ch/reprobst/WordFAQ/Browse.htm#Browse4

' und anderen Passagen auf mypage.bluewin.ch übernommen

' (z.B. DateinameAllokierenUndFensterBenennen).



Const constIntZeilenanzahlSeite = 5          ' Zeilen pro Seite (z.B. 5)

Const constLongHoeheZeileZentimeter = 3.1    ' Höhe einer Zeile (z.B. 3.1)

Const constStrTitel = "Karteikarten aus Liste erstellen"



Public Sub Karteikarten()

    

    ' Hauptprogramm

    

    ' Dokumente:

    Dim docOldDoc            As Document

    Dim docNewDoc            As Document

    ' Ende der Ursprungstabelle erreicht Ja/Nein:

    Dim boolEnde             As Boolean

    ' Start und Ende des Bereichs der

    ' Ursprungstabelle, der ausgelesen wird

    Dim intStart             As Integer

    Dim intEnde              As Integer

    ' Tabelle auf Seite 1 und Seite 2 (3 und 4 etc.)

    Dim tableSeite1          As Table

    Dim tableSeite2          As Table

    ' Nummer der 4 Spalten, die im Zieldokument

    ' befüllt werden.

    ' intSpalteZielTabelle ist die Nummer der Zielspalte

    ' der Ziel-Tabelle; die Spalte bezieht sich

    ' auf die je erste Tabelle der beiden zusammengehörenden

    ' Tabellen. Die Zielspalte der zweiten Tabelle ergibt

    ' sich durch 5 - intSpalteZielTabelle.

    ' Dadurch ergeben sich für die Spalten folgenden Paare:

    ' 1 (auf der 1. Seite) und 4 (auf der 2. Seite)

    ' 2 (auf der 1. Seite) und 3 (auf der 2. Seite)

    ' 3 (auf der 1. Seite) und 2 (auf der 2. Seite)

    ' 4 (auf der 1. Seite) und 1 (auf der 2. Seite) ,

    ' 1 (auf der 1. Seite) und 4 und so fort für die

    ' Seitenpaare 3 und 4, 5 und 6 und so fort.

    Dim intSpalteZielTabelle As Integer

            

    

    ' Ggf. Abbruch

    If Documents.Count <= 0 Then

        MsgBox "Sorry, kein Dokument offen.", _

               vbCritical, _

               constStrTitel

        End

    End If

    

    ' Ggf. Abbruch

    If ActiveDocument.Tables.Count <= 0 Then

        MsgBox "Sorry, keine Tabelle gefunden.", _

               vbCritical, _

               constStrTitel

        End

    End If

    

    ' Ggf. Abbruch

    If ActiveDocument.Tables(1).Columns.Count <> 2 Then

        MsgBox "Sorry, die Anzahl der Spalten der ersten Tabelle " & _

               "beträgt nicht zwei Spalten (sie beträgt " & _

               ActiveDocument.Tables(1).Columns.Count & _

               " Spalten).", _

               vbCritical, _

               constStrTitel

        End

    End If

    

    ' Initialisierungen

    boolEnde = False

    

    Set docOldDoc = ActiveDocument

    Set docNewDoc = Documents.Add

    

    DinA4Format

    Selection.InsertParagraphAfter

    

    intStart = 1

    intEnde = constIntZeilenanzahlSeite

    ZweiTabellenUndEinenSeitenumbruchAnlegen docNewDoc, tableSeite1, tableSeite2

    intSpalteZielTabelle = 1

    

    ' Schleife durch die Ursprungstabelle

    Do

        

        ' Tabelle befüllen

        TabellenBefuellen boolEnde, docOldDoc, docNewDoc, intStart, intEnde, _

                  intSpalteZielTabelle, _

                  5 - intSpalteZielTabelle, _

                  tableSeite1, tableSeite2

        

        ' Ursprungszeilenstart und -ende erhöhen

        intStart = intStart + constIntZeilenanzahlSeite

        intEnde = intEnde + constIntZeilenanzahlSeite

        

        ' Zielspalte erhöhen

        intSpalteZielTabelle = intSpalteZielTabelle + 1

        

        ' Wenn Zielspalte 4 war, diese zurücksetzen

        If intSpalteZielTabelle > 4 Then

            intSpalteZielTabelle = 1

            ' Wenn Ende der Ursprungstabelle noch nicht erreicht

            If boolEnde = False Then

                ' Dann neue Seite anlegen

                Selection.EndKey unit:=wdStory, Extend:=wdMove

                Selection.InsertBreak Type:=wdPageBreak

                ' zwei neue Tabellen auf 2 Seiten anlegen

                ZweiTabellenUndEinenSeitenumbruchAnlegen docNewDoc, _

                                                         tableSeite1, _

                                                         tableSeite2

            End If

        End If

        

    Loop Until boolEnde = True  ' Schleifenende

    

    ' Abschlussarbeiten

    docNewDoc.Activate

    FormatiereDokument

    subDateinameAllokierenUndFensterBenennen "Vokabelkarten"

    Selection.HomeKey unit:=wdStory, Extend:=wdMove

    Set docNewDoc = Nothing

    Set docOldDoc = Nothing

    

    MsgBox "Fertig.", vbInformation, constStrTitel

    

End Sub



Private Sub TabellenBefuellen(boolEnde As Boolean, _

                              docOldDoc As Document, _

                              docNewDoc As Document, _

                              intStart As Integer, _

                              intEnde As Integer, _

                              intSpalteSeite1 As Integer, _

                              intSpalteSeite2 As Integer, _

                              tableSeite1 As Table, _

                              tableSeite2 As Table)

    

    ' zwei Tabellen aus der Ursprungstabelle befüllen

    

    Dim i                   As Integer ' Zeile Ursprungstabelle

    Dim k                   As Integer ' Zeile Zieltabelle

    

    

    ' Ggf. Ende-Wert Zeile Ursprungstabelle anpassen

    If intEnde > docOldDoc.Tables(1).Rows.Count Then

        intEnde = docOldDoc.Tables(1).Rows.Count

        boolEnde = True

    End If

    

    k = 1

    For i = intStart To intEnde

        tableSeite1.Cell(k, intSpalteSeite1).Range.Text = _

              Convert(docOldDoc.Tables(1).Cell(i, 1).Range.Text)

        tableSeite2.Cell(k, intSpalteSeite2).Range.Text = _

              Convert(docOldDoc.Tables(1).Cell(i, 2).Range.Text)

        k = k + 1

    Next i

    

End Sub



Private Sub ZweiTabellenUndEinenSeitenumbruchAnlegen( _

                                docNewDoc As Document, _

                                tableSeite1 As Table, _

                                tableSeite2 As Table)

    

    ' zwei Tabellen und einen Seitenumbruch anlegen

        

    Selection.EndKey unit:=wdStory, Extend:=wdMove

    

    Set tableSeite1 = docNewDoc.Tables.Add(Selection.Range, constIntZeilenanzahlSeite, 4)

    FormatiereTabelle tableSeite1

    

    Selection.EndKey unit:=wdStory, Extend:=wdMove

    Selection.InsertBreak Type:=wdPageBreak

    Selection.EndKey unit:=wdStory, Extend:=wdMove

    

    Set tableSeite2 = docNewDoc.Tables.Add(Selection.Range, constIntZeilenanzahlSeite, 4)

    FormatiereTabelle tableSeite2

    

End Sub



Private Sub FormatiereTabelle(tableMyTable As Table)



    With tableMyTable

        .Rows.Height = CentimetersToPoints(constLongHoeheZeileZentimeter)

        .Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter

        .Range.Paragraphs.Alignment = wdAlignParagraphCenter

        .Rows.Alignment = wdAlignRowCenter

    End With

    

End Sub



Private Function Convert(strConvertWhat As String) _

                               As String



    ' kann kleinere Konvertierungen und Formatierungen vornehmen,

    ' wenn eine Vokabel aus dem alten Dokument in das neue übernommen

    ' wird



    strConvertWhat = Replace(strConvertWhat, Chr(11), "")

    strConvertWhat = Replace(strConvertWhat, Chr(7), "")

    strConvertWhat = Replace(strConvertWhat, Chr(13), "")

    Convert = Trim(strConvertWhat)



End Function



Private Sub FormatiereDokument()

    

    ' kann kleinere Formatierungen vornehmen,

    ' die das ganze Dokument betreffen



    Selection.Sections(1).Footers(1).PageNumbers.Add PageNumberAlignment:= _

        wdAlignPageNumberRight, FirstPage:=True

        

    Selection.Sections(1).Footers(1).Range.Text = Date & _

                                                  ", " & _

                                                  Time

                                                  

    Selection.Sections(1).Footers(1).PageNumbers.Add _

                  PageNumberAlignment:=wdAlignPageNumberRight, _

                  FirstPage:=True

                      

End Sub



Private Sub DinA4Format()

    

    ' Seite einrichten, Seitenränder recht klein

    

    With ActiveDocument.PageSetup

        .LineNumbering.Active = False

        .Orientation = wdOrientPortrait

        

        .TopMargin = CentimetersToPoints(1.1)

        .BottomMargin = CentimetersToPoints(1.3)

        .LeftMargin = CentimetersToPoints(0.9)

        .RightMargin = CentimetersToPoints(0.9)

        

        .Gutter = CentimetersToPoints(0)

        .HeaderDistance = CentimetersToPoints(1.25)

        .FooterDistance = CentimetersToPoints(1.25)

        .PageWidth = CentimetersToPoints(21)

        .PageHeight = CentimetersToPoints(29.7)

        .FirstPageTray = wdPrinterDefaultBin

        .OtherPagesTray = wdPrinterDefaultBin

        .SectionStart = wdSectionNewPage

        .OddAndEvenPagesHeaderFooter = False

        .DifferentFirstPageHeaderFooter = False

        .VerticalAlignment = wdAlignVerticalTop

        .SuppressEndnotes = False

        .MirrorMargins = False

        .TwoPagesOnOne = False

        .GutterPos = wdGutterPosLeft

    End With

    

End Sub



Private Sub subDateinameAllokierenUndFensterBenennen(strTitel As String)

  

  ' Das neue Dokument bekommt einen Namen

  

  Dim windowFenster     As Window

  

  

  With Dialogs(wdDialogFileSummaryInfo)

    .Title = strTitel

    .Execute

  End With



  For Each windowFenster In ActiveDocument.Windows

    windowFenster.Caption = strTitel

  Next

  

End Sub



' Symbolleiste erstellen **************************************************



Private Sub SetCommandBar()

    

    ' Erzeugt eine neue Symbolleiste

    

    Dim xLeiste   As CommandBar

    Dim Titel     As String

    Dim CmdBar    As CommandBar

    Dim CBut      As CommandBarButton

    

    

    CustomizationContext = Application.Templates(strFuncSelektierteVorlageDetektieren)

    

    ' Erzeugen der Symbolleiste

    Titel = "Vokabelkarten"

    

    'Prüfen, ob die Symbolleiste existiert

    For Each xLeiste In CommandBars

     If xLeiste.Name = Titel Then

       xLeiste.Delete '  Visible = True

       ' Exit Sub

     End If

    Next xLeiste

     

    CustomizationContext = Application.Templates(strFuncSelektierteVorlageDetektieren)

    

    Set CmdBar = CommandBars.Add( _

                        Name:=Titel, Position:=msoBarFloating, menubar:=False, temporary:=False)

    

    With CmdBar

          On Error Resume Next

          .Visible = True

          If Err.Number <> 0 Then

            MsgBox Err & "  " & Err.Description

          End If

          On Error GoTo 0

          .Protection = msoBarNoProtection

          .Enabled = True

    End With

    

    Set CBut = CmdBar.Controls.Add(Type:=msoControlButton)

    

    With CBut

         .Style = msoButtonCaption

         .Caption = "Vokabelkarten erstellen"

         .TooltipText = "Vokabelkarten aus Liste erstellen"

         .OnAction = "Karteikarten"

    '      .FaceId = 30

    End With



End Sub



Private Function strFuncSelektierteVorlageDetektieren() As String

    

    ' Dient dazu, das im VBA-Editor aktive Modul zu ermitteln.

    ' Achtung: Wenn das Editorfenster links nicht den Focus hat oder

    ' keines offen ist, so gilt das Modul (die Form), das im

    ' Projekt-Explorer markiert ist.

    

    Dim strBuffer       As String

    

    

    strBuffer = ""

    ' Modul ermitteln

    On Error Resume Next

    strBuffer = Application.VBE.ActiveVBProject.FileName

    On Error GoTo 0

    strFuncSelektierteVorlageDetektieren = strBuffer

    

End Function



' Andere subs ****************************************************



Private Sub TabelleBefuellen()

    

    ' für Testzwecke: Tabelle erstellen und

    ' befüllen

    

    Dim tableSeite1     As Table

    Dim i               As Integer

    Dim docNewDoc       As Document

    

    

    Documents.Add

    Set docNewDoc = ActiveDocument

    Set tableSeite1 = docNewDoc.Tables.Add(Selection.Range, 320, 2)

    

    For i = 1 To 320

        tableSeite1.Cell(i, 1).Range.Text = "Links " & i

        tableSeite1.Cell(i, 2).Range.Text = "rechts " & i

    Next i

    

End Sub







Code eingefügt mit Syntaxhighlighter 2.2











geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: