Office Forum
www.Office-Loesung.de
Access :: Excel :: Outlook :: PowerPoint :: Word :: Office :: Wieder Online ---> provisorisches Office Forum <-
VBA-Beispiele mit Datei
Gehe zu Seite 1, 2, 3  Weiter
zurück: Gesamten Text aus Word.doc nach Excel kopieren weiter: Bedeutung der Befehle wie dim, while, wend etc. Unbeantwortete Beiträge anzeigen
Neues Thema eröffnen   Neue Antwort erstellen     Status: Antwort Facebook-Likes Diese Seite Freunden empfehlen
Zu Browser-Favoriten hinzufügen
Autor Nachricht
Lisa
Moderator; Word seit Word 5.0 (für DOS)


Verfasst am:
19. März 2009, 21:33
Rufname:
Wohnort: Leipzig

VBA-Beispiele mit Datei - VBA-Beispiele mit Datei

Nach oben
       

Hallo,

in diesem Beitrag möchte ich VBA-Beispiele (mit hochgeladenen Dateien) sammeln, damit sie leichter wiedergefunden werden. Wer einen guten Beitrag weiß, schickt bitte eine PN mit dem Link an mich, dann füge ich den Beitrag hier ein.
Komplette Makros als Code-Schnipsel


Zuletzt bearbeitet von Lisa am 04. Aug 2010, 21:31, insgesamt 2-mal bearbeitet
Lupussilvae
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Nov 2009, 14:22
Rufname:


Tabellensuche - Tabellensuche

Nach oben
       Version: Office 2003

Hallo Lisa,

hier kommt Tabellensuche:
Code:
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsLookForTablesBetweenHeaders"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Option Explicit
'*******************************************************************************
'* Enum
'*******************************************************************************
Public Enum HeadStyles
   HdIdx1 = 0
   HdIdx2 = 1
   HdIdx3 = 2
End Enum 'Indizes der Fromatbezeichner Überschrift (Styles)

Public Enum TableStyles
   tblIdx = 3
End Enum 'Indizes der Fromatbezeichner Tabelle (Styles)

Public Enum Stepping
   up = 1
   dwn = -1
End Enum 'Inkrement oder Dekrement

'*******************************************************************************
'* Meldungs Texte
'*******************************************************************************
'-- Fehler in der Property, die nach Tabellen sucht:
Private Const CROAKLOOK4TBL As String = "Property TblExists"
Private Const CROAKNOTFOUND As String = " wurde nicht gefunden. Bitte Schreibweise überprüfen."

'*******************************************************************************
'* Konstanten in der Klasse
'*******************************************************************************

'*******************************************************************************
'* globale Konstanten
'*******************************************************************************
Public Property Get StylesArr() As Variant
' ----------------------------------------------------------
' Feld mit den Format Stilen
' ----------------------------------------------------------
'  Lupussilvae 30.11.09
' ----------------------------------------------------------
   Dim arrStyles() As Variant
   
   arrStyles = Array("Überschrift 1", _
                     "Überschrift 2", _
                     "Überschrift 3", _
                     "Tabellengitternetz")
   StylesArr = arrStyles

End Property

Public Property Get ErrNoSuchText() As Long
' ----------------------------------------------------------
' Dieser Fehler stammt aus der Liste "Auffangbare Fehler"
' und besagt, dass der Suchtext nicht gefunden wurde
' ----------------------------------------------------------
'  Lupussilvae 30.11.09
' ----------------------------------------------------------
   ErrNoSuchText = 744
End Property

'*******************************************************************************
'* globale Eigenschaften
'*******************************************************************************
Public Property Get TblExists(ByVal FstHeader As String, _
                              ByVal SdHeader As String, _
                              ByVal FstHeaderStyle As Long, _
                              ByVal SdHeaderStyle As Long, _
                              ByVal FstCellText As String) As Boolean
' ----------------------------------------------------------
' Es wird geprüft, ob zwischen zwei Überschriften sich eine
' Tabelle befindet. Die Eigenschaft bricht mit dem Fehler
' 744, Text nicht gefunden, ab, wenn mindestens einer der
' übergebenen Überschriften Strings nicht existiert. Diese
' Funktion geht davon aus, dass die erste Zelle der zu
' suchenden Tabelle eine Beschreibun der zugehörigen Spalte
' ist. Damit die Suche schneller vonstatten geht, wird über
' eine statische Variable der Beginn des Suchbereiches dynamisch
' verwaltet. Eine zusätzliche statische Variable merkt sich
' das Ende des Absatzes.
' ----------------------------------------------------------
'
' Übergabe:
' =========
' FstHeader       Erste Überschrift; markiert Beginn des Suchbereiches
' SdHeader        Zweite Überschrift; markiert Ende des Suchbereiches
' FstHeaderStyle  Stil der ersten Überschrift
' SdHeaderStyle   Stil der zweiten Überschrift
' FstCellText     Inhalt der ersten Zelle der zu suchenden Tabelle
'
' Enum:
' =====
' HeadStyles      Indizes der Überschriften Stile
' TableStyles     Index des Tabellenmstils
' Stepping        Inkrement oder Dekrement
'
' Globale Konstanten:
' ===================
' arrStyles       Liste mit den Formatierungsstilen Tabelle oder Überschrift
'
' Meldungstexte:
' ==============
' CROAKLOOK4TBL
' CROAKNOTFOUND
'
'-----------------------------------------------------------
'  Lupussilvae 30.11.09
' ----------------------------------------------------------
'## Deklarationen
   Static rngSectionStart As Long, _
          rngSectionEnd As Long
   Dim RangeTestDescr As Range
   Dim cntSection As Long
   Dim FstStart As Long, _
       FstEnd As Long, _
       SdStart As Long, _
       SdEnd As Long, _
       AddrBuffer As Long, _
       LenOfSdHeader As Long, _
       LenOfFstHeader As Long
       
   Const NOSDHEADER As Integer = 0
   Const FSTRUN As Integer = 0
       
'## Suchen
   With ActiveDocument
      '-- Initiierung
      If rngSectionStart = FSTRUN Or rngSectionEnd = FSTRUN Then
         '-- Grenzen des Suchbereiches laden und permanent sichern --
         cntSection = .Sections.Count
         rngSectionEnd = .Sections(cntSection).Range.End
         rngSectionStart = .Sections(cntSection).Range.Start
         
         '-- Erste Überschrift suchen --
         Set RangeTestDescr = .Range(Start:=rngSectionStart, End:=rngSectionEnd)
         With RangeTestDescr.Find
            '-- Überschriftentyp festlegen --
            Select Case FstHeaderStyle
               Case HeadStyles.HdIdx1
                  .Style = StylesArr(HeadStyles.HdIdx1)
               Case HeadStyles.HdIdx2
                  .Style = StylesArr(HeadStyles.HdIdx2)
               Case Else
                  .Style = StylesArr(HeadStyles.HdIdx3)
            End Select ' Bezeichnung der Formatvorlage der Überschrift
         
            '-- Suchparameter --
            .MatchWholeWord = True
            .MatchCase = False
            .Forward = True
         
            '-- Suche nach der ersten Übefschrift starten und auswerten --
            If .Execute(FindText:=FstHeader) Then
               rngSectionStart = .Parent.End + Stepping.up
               FstEnd = rngSectionStart
            Else
               ' Dieser Fehler stammt aus der Liste "Auffangbare Fehler"
               ' und besagt, dass der Suchtext nicht gefunden wurde
               Err.Raise ErrNoSuchText, _
                         CROAKLOOK4TBL, _
                         FstHeader & CROAKNOTFOUND
            End If ' Bei Erfolg, Ende der ersten Überschrift als Suchbeginn merken
         
         End With ' suche Ende der ersten Überschrift im Abschnitt der Testtabellen
      Else
         '-- Ende der ersten Überschrift ist der Beginn des Suchbereiches --
         FstEnd = Len(FstHeader) + rngSectionStart + Stepping.up
         
      End If ' Setzen der Start und Endwerte des Bereichs mit den Testfällen
     
      '-- Zweite Überschrift suchen
      LenOfSdHeader = Len(SdHeader)
      If LenOfSdHeader > NOSDHEADER Then
         Set RangeTestDescr = .Range(Start:=FstEnd, End:=rngSectionEnd)
         With RangeTestDescr.Find
            ' Überschriftentyp festlegen
            Select Case SdHeaderStyle
               Case HeadStyles.HdIdx1
                  .Style = StylesArr(HeadStyles.HdIdx1)
               Case HeadStyles.HdIdx2
                  .Style = StylesArr(HeadStyles.HdIdx2)
               Case Else
                  .Style = StylesArr(HeadStyles.HdIdx3)
            End Select ' Bezeichnung der Formatvorlage der Überschrift
           
            ' Suchparameter
            .MatchWholeWord = False
            .MatchCase = False
            .Forward = True
           
            ' Suche ausführen und auswerten
            If Not .Execute(FindText:=SdHeader) Then
               ' Dieser Fehler stammt aus der Liste "Auffangbare Fehler"
               ' und besagt, dass der Suchtext nicht gefunden wurde
               Err.Raise ErrNoSuchText, _
                         CROAKLOOK4TBL, _
                         SdHeader & CROAKNOTFOUND
            End If 'Bei Misserfolg Eigenschaft mit Fehlermeldung verlassen
           
            ' Beginn und Ende der zweiten Überschrift
            SdStart = .Parent.Start
            SdEnd = .Parent.End
               
            ' Check, ob das Ergebnis Bereichsrichtig ist
            If SdStart < FstEnd Then
               AddrBuffer = FstStart
               FstStart = SdStart
               SdStart = AddrBuffer
               AddrBuffer = FstEnd
               FstEnd = SdEnd
               SdEnd = AddrBuffer
            End If 'Wenn die Bereichsadressen umgekehrt der Reihenfolge im Word Dokument sind: umschubsen
           
         End With ' suche zweite Überschrift
         
      Else
         ' Virtueller Beginn der zweiten Überschrift
         SdStart = rngSectionEnd
         
      End If ' prüfen, ob wir am Ende des Dokumentes angelangt sind

      '-- Tabelle suchen (wenn möglich)
      FstEnd = FstEnd + Stepping.up
      SdStart = SdStart + Stepping.dwn
      If SdStart <= FstEnd Then
         TblExists = False
      Else
         '-- wir haben ausreichend Platz zur Suche
         Set RangeTestDescr = .Range(Start:=FstEnd, End:=SdStart)
         With RangeTestDescr.Find
            ' Formatierungstyp
            .Style = StylesArr(TableStyles.tblIdx)
           
            ' Suchparameter
            .MatchWholeWord = True
            .MatchCase = False
            .Forward = True
           
            ' Suchen und auswerten
            If .Execute(FindText:=FstCellText) Then
               TblExists = True
            Else
               TblExists = False
            End If ' Tabellensuche
           
         End With ' Suche in dem Bereich nach mindestens einer Tabelle
         
      End If ' Nur dann nach den Tabellen suchen, wenn zwischen zwei Überschriften ausreichend Platz ist
     
   End With ' Suchbereich ermitteln und instanzieren

'## Fertig
   rngSectionStart = SdStart
   Set RangeTestDescr = Nothing

End Property ' TblExists

_________________
Coeio ergo sum
Lupussilvae
Im Profil kannst Du frei den Rang ändern


Verfasst am:
30. Nov 2009, 14:25
Rufname:

Auslesen des Inhaltsverzeichnisses (TOC) - Auslesen des Inhaltsverzeichnisses (TOC)

Nach oben
       

Hallo Lisa,

hier kommt das Auslesen des ToC
Code:
VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsGetTheToc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'*******************************************************************************
' Klassenmodul clsToCasList
'*******************************************************************************

'*******************************************************************************
'* ENUMs
'*******************************************************************************
Public Enum WhiteSpace
   BEL = 7
   BS = 8
   HT = 9
   LF = 10
   VT = 11
   FF = 12
   CR = 13
End Enum ' Steuerungszeichen (Whitespaces)

Public Enum PathDelimiter
   Backslash = 92
   Slash = 47
End Enum ' PfadTrenner

Public Enum Stepping
   up = 1
   dwn = -1
End Enum 'Inkrement oder Dekrement

'*******************************************************************************
'* globale Konstante
'*******************************************************************************
Public Property Get ErrNoSuchText() As Long
' -----------------------------------------------------------------
' Dieser Fehler stammt aus der Liste "Auffangbare Fehler"
' und besagt, dass der Suchtext nicht gefunden wurde
' -----------------------------------------------------------------
'  Lupus Silvae 30.11.2009
' -----------------------------------------------------------------
   ErrNoSuchText = 744
End Property

'*******************************************************************************
'* Meldungs Texte
'*******************************************************************************
Private Const CROAKLOOK4TBL As String = "Funktion ToCasList"
Private Const CROAKNOTFOUND As String = " wurde nicht gefunden. Bitte Schreibweise überprüfen."

'*******************************************************************************
'* Funktion
'*******************************************************************************
Public Property Get ToCasList(Optional StartingHeader As String, _
                              Optional NbrOfSection As Long) As Variant
' -----------------------------------------------------------------
' Auslesen des Inhaltsverzeichnisses (ToC). Es wird davon ausgegangen,
' dass die Überschriften nummeriert sind (1, 1.1, 1.1.1, ...)
' -----------------------------------------------------------------
' Optionale Übergaben:
' =====================
' StartingHeader: Sofern man nur an einem Teil des ToC interessiert
'                 ist ist das der Startpunkt für den Bereich (Range),
'                 den man haben möchte.
' NbrOfSection:   Abschnitt des Word Dokument, das den ToC beherbergt
'
' Hilfsfunktionen:
' ================
' ./.
'
' Globale Konstanten:
' ===================
' ErrNoSuchText
'
' Konstanten im Modul:
' ====================
' CROAKLOOK4TBL
' CROAKNOTFOUND
'
' ENUM:
' =====
' WhiteSpace
' Stepping
' -----------------------------------------------------------------
'  Lupus Silvae 30.11.2009
' -----------------------------------------------------------------
'## Deklarationen
   Dim tocItem As Word.TableOfContents
   Dim TextArray() As String               ' Der Inhalt des ToC wird als ein String
                                           ' ausgelesen und an seinen Delimtern zerlegt
   Dim TextSplitted() As String            ' Listenwert, dessen Delimiter entfernt wurden
                                           ' Er wird immer drei Teilelemente aufnehmen
   Dim x  As Long                          ' Schleifenzähler bei der Verarbeitung
   Dim FstElement As Long                  ' Erste Überschrift in der Liste
   Dim LstElement As Long                  ' Letze, echte Überschrift in der Liste
   Dim IdxChapterNbr As Long               ' Kapitelnummer als Index
   Dim myToCasList() As Variant            ' Zwischenergebnis
   Dim idxSection As Long                  ' Abschnittszähler
       
   Const OFFSETCHAPTERNBR As Integer = 2   ' Zahl der "Überschrift 1" + einen Tabulator
   Const LEASTSECTION As Integer = 1       ' mindestens ein Abschnitt
   Const NOTOC As Integer = 0              ' Da gibt es kein ToC
   Const NOVALUE As Integer = 0            ' Es gibt keine Startüberschrift
   
'## Prozess
   With ActiveDocument
      idxSection = .TablesOfContents.Count
      If idxSection > NOTOC Then
         ' Abschnittskontrolle
         If NbrOfSection > LEASTSECTION Then
            Set tocItem = .TablesOfContents(NbrOfSection)
         Else
            Set tocItem = .TablesOfContents(idxSection)
         End If ' Wo steht das ToC
         
         '-- Sofern eine Startüberschrift mit gegeben wurde --
         If Len(StartingHeader) > NOVALUE Then
            With tocItem.Range
               '-- Erste Überschrift zu den Tabellen zzgl. Kapitelnummer holen --
               LstElement = .End ' Sichern des Endewertes des Bereichs
               With .Find
                  ' Suchparameter
                  .MatchWholeWord = True
                  .MatchCase = False
                  .Forward = True
                 
                  ' Suchvorgang und Auswertung
                  If .Execute(FindText:=STARTCHAPTER) Then
                     '-- Die Kapitelnummer ist ein Zahl gefolgt von einem horizontalen Tabulator
                     FstElement = .Parent.Start - OFFSETCHAPTERNBR
                  Else
                     Err.Raise Number:=ErrNoSuchText, _
                               Source:=CROAKSRCTOCTBLLST, _
                               Description:=CROAKFSTCHPDESC
                  End If ' Suche erste Überschrift zu den Testtabellen
               
               End With ' Suche nach vorgegebener Überschrift abgeschlossen
           
               '-- den Bereich des ToC neu festlegen
               .Start = FstElement
               .End = LstElement
               
            End With ' Optionsle Auswertung des ToC Bereichs
               
         End If ' Startüberschrift suchen und den Bereich des ToC String festlegen
           
         '-- ToC-String in eine Liste umwandeln und diese auswerten --
         With tocItem.Range
            '-- aus dem ToC-String eine Liste machen
            TextArray = Split(Expression:=.Text, _
                              Delimiter:=Chr(WhiteSpace.CR))
                             
            '-- Liste mit den Überschriften zu den Testtabelle auswerten --
            ' 1.) Anfangs- und Endwert der String Liste
            FstElement = LBound(TextArray)
            LstElement = UBound(TextArray) + Stepping.dwn ' Meucheln des überflüssigen CR
           
            ' 2.) Liste für das Zwischenergebnis:
            ReDim myToCasList(Chapters.Nbr, LstElement) As Variant
            ReDim myToCasList(Chapters.Nme, LstElement) As Variant
           
            ' 3.) Auswertung
            For x = FstElement To LstElement
               If Not (TextArray(x) = "") Then
                  '-- Teilstring in Kapitelnummer und Überschrift trennen. --
                  '-- Die Seitenzahlen werden nicht verwendet              --
                  TextSplitted = Split(Expression:=TextArray(x), _
                                       Delimiter:=Chr(WhiteSpace.HT))
                  IdxChapterNbr = LBound(TextSplitted)
                  myToCasList(Chapters.Nbr, x) = TextSplitted(IdxChapterNbr)
                  myToCasList(Chapters.Nme, x) = TextSplitted(IdxChapterNbr + Stepping.up)
                  ReDim TextSplitted(FstElement)
               Else ' überflüssige Teilstrings meucheln
                  x = LstElement
               End If ' Wenn ein Teilstring, also Element der String Liste,
                      ' nicht leer ist, dann bearbeiten
                     
            Next x ' Liste iterativ auswerten
           
         End With ' Finale Bearbeitung des ToC
         
      Else ' Meckern und weitere Verarbeitung abbrechen lassen
         Err.Raise Number:=ErrNoSuchText, Source:=CROAKSRCTOC, Description:=CROAKNOTOC
      End If 'Gültiges Inhaltsverzeichnis auswerten
     
   End With ' Auswertung des Aktiven Dokumentes
   
'## Die Routine abschließen und verlassen
   Set tocItem = Nothing
   ToCasList = myToCasList

End Function 'ToCasList

_________________
Coeio ergo sum
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:12
Rufname:

Alle Felder und Textfelder aktualisieren - Alle Felder und Textfelder aktualisieren

Nach oben
       Version: Office 2003

Code:
Sub AlleFelderMitTextfelderAktualisieren()
    Dim rngDoc As Range
    Dim oDoc As Document
    Dim docSec As Section
    Dim oHF As HeaderFooter
    Dim shp As Shape
   
    Set oDoc = ActiveDocument
    For Each docSec In oDoc.Sections
        For Each oHF In docSec.Headers
            For Each shp In oHF.Shapes
                With shp.TextFrame
                    If .HasText Then
                        .TextRange.Fields.Update
                    End If
                End With
            Next shp
        Next oHF
        For Each oHF In docSec.Footers
            For Each shp In oHF.Shapes
                With shp.TextFrame
                    If .HasText Then
                        .TextRange.Fields.Update
                    End If
                End With
            Next shp
        Next oHF
        For Each rngDoc In oDoc.StoryRanges
            rngDoc.Fields.Update
            While Not (rngDoc.NextStoryRange Is Nothing)
                Set rngDoc = rngDoc.NextStoryRange
                rngDoc.Fields.Update
            Wend
        Next rngDoc
    Next docSec
    Set rngDoc = Nothing
    Set oDoc = Nothing
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:13
Rufname:


Wasserzeichen - Wasserzeichen

Nach oben
       Version: Office 2003

Code:
Sub WasserzeichenEin()
    Dim Wasserzeichen As String
   
    'Call WasserzeichenAus
    Wasserzeichen = InputBox("Bitte geben Sie die Bezeichnung für das " _
                           & "Wasserzeichen ein?" _
                           , "Wasserzeichen (c) 1997 by M. Steinhoff")
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes.AddTextEffect(PowerPlusWaterMarkObject1 _
                                              , Wasserzeichen _
                                              , "Times New Roman", 1, False _
                                              , False, 0, 0).Select
    Selection.ShapeRange.Name = "PowerPlusWaterMarkObject1"
    Selection.ShapeRange.TextEffect.NormalizedHeight = False
    Selection.ShapeRange.Line.Visible = False
    Selection.ShapeRange.Fill.Visible = True
    Selection.ShapeRange.Fill.Solid
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(192, 192, 192)
    Selection.ShapeRange.Fill.Transparency = 0.5
    Selection.ShapeRange.Rotation = 315
    Selection.ShapeRange.LockAspectRatio = True
    Selection.ShapeRange.Height = CentimetersToPoints(7.52)
    Selection.ShapeRange.Width = CentimetersToPoints(15.04)
    Selection.ShapeRange.WrapFormat.AllowOverlap = True
    Selection.ShapeRange.WrapFormat.Side = wdWrapNone
    Selection.ShapeRange.WrapFormat.Type = 3
    Selection.ShapeRange.RelativeHorizontalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.RelativeVerticalPosition = _
        wdRelativeVerticalPositionMargin
    Selection.ShapeRange.Left = wdShapeCenter
    Selection.ShapeRange.Top = wdShapeCenter
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub

Sub WasserzeichenAus()
    ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
    Selection.HeaderFooter.Shapes("PowerPlusWaterMarkObject1").Select
    Selection.Delete
    ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:15
Rufname:

Schriftarten im Dokument auflisten - Schriftarten im Dokument auflisten

Nach oben
       

Code:
Public Sub ListFontsInDoc()
    Dim FontList(199) As String
    Dim FontCount As Integer
    Dim FontName As String
    Dim j As Integer, K As Integer, l As Integer
    Dim x As Long, y As Long
    Dim FoundFont As Boolean
    Dim rngChar As Range
    Dim strFontList As String

    FontCount = 0
    x = Activedocument.Characters.Count
    y = 0
    ' For-Next loop through every character
    For Each rngChar In Activedocument.Characters
        y = y + 1
        FontName = rngChar.Font.Name
        StatusBar = y & ":" & x
        ' check if font used for this char already in list
        FoundFont = False
        For j = 1 To FontCount
           If FontList(j) = FontName Then FoundFont = True
        Next j
        If Not FoundFont Then
            FontCount = FontCount + 1
            FontList(FontCount) = FontName
        End If
    Next rngChar
    ' sort the list
    StatusBar = "Sorting Font List"
    For j = 1 To FontCount - 1
        l = j
        For K = j + 1 To FontCount
            If FontList(l) > FontList(K) Then l = K
        Next K
        If j <> l Then
            FontName = FontList(j)
            FontList(j) = FontList(l)
            FontList(l) = FontName
        End If
    Next j
    StatusBar = ""
    ' put in new document
    Documents.Add
    Selection.TypeText Text:="Im Dokument sind " & FontCount _
                           & " Fonts enthalten:"
    Selection.TypeParagraph
    Selection.TypeParagraph
    For j = 1 To FontCount
        Selection.TypeText Text:=FontList(j)
        Selection.TypeParagraph
    Next j
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:16
Rufname:

Zwei Seiten pro Blatt drucken - Zwei Seiten pro Blatt drucken

Nach oben
       

Code:
Sub Drucken2SeitenProBlatt()
    On Error Resume Next
    Options.PrintReverse = False
    Application.PrintOut FileName:="", Range:=wdPrintAllDocument _
                       , Item:=wdPrintDocumentContent, Copies:=1, Pages:="" _
                       , PageType:=wdPrintAllPages, Collate:=True _
                       , Background:=False, PrintToFile:=False _
                       , PrintZoomColumn:=2, PrintZoomRow:=1 _
                       , PrintZoomPaperWidth:=0, PrintZoomPaperHeight:=0
    On Error GoTo 0
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:17
Rufname:

Textmarken listen - Textmarken listen

Nach oben
       Version: Office 2003

Code:
Sub TextmarkenListen()
    Dim aDoc As Word.Document
    Dim nDoc As Word.Document
    Dim i As Long
     
    i = 0
    Set aDoc = Activedocument
    If aDoc.Bookmarks.Count < 1 Then
        MsgBox "Keine Textmarken im Dokument enthalten!"
        Exit Sub
    End If
    ReDim strArray(aDoc.Bookmarks.Count, 1)
    Selection.HomeKey Unit:=wdStory
    For i = 1 To (aDoc.Bookmarks.Count)
        strArray(i, 0) = aDoc.Bookmarks(i).Name
        strArray(i, 1) = aDoc.Bookmarks(i).Range
    Next i
    Set nDoc = Documents.Add
    For i = 1 To (aDoc.Bookmarks.Count)
        With Selection
            .TypeText strArray(i, 0)
            .TypeText vbTab
            .TypeText vbTab
            .TypeText strArray(i, 1)
            .TypeParagraph
            .TypeParagraph
        End With
    Next i
    Set aDoc = Nothing
    Set nDoc = Nothing
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:17
Rufname:

Falzmarke einfügen - Falzmarke einfügen

Nach oben
       Version: Office 2003

Code:
Sub FalzmarkeEinfügen()
    Dim oKz As Object
    Dim FM As Object
   
    Set oKz = Activedocument.Sections(1).Headers(1)
    Set FM = oKz.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal _
                                 , Left:=CentimetersToPoints(0.5) _
                                 , Top:=CentimetersToPoints(10.4) _
                                 , Width:=CentimetersToPoints(0.2) _
                                 , Height:=CentimetersToPoints(0.02))
    FM.LockAnchor = True
    Set FM = Nothing
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:18
Rufname:

Hyperlinks entfernen - Hyperlinks entfernen

Nach oben
       Version: Office 2003

Edit: Achtung! Diese Variante löst jegliche Felder im Dokument auf, also auch Querverweise innerhalb des Dokuments:
Code:
Sub VerlinkungAllerFelderImDokumentAufloesen()
    Selection.WholeStory
    Selection.Fields.Unlink
    Selection.Collapse wdCollapseStart
End Sub
Diese Variante von Lisa löst NUR die Hyperlinks auf:
Code:
Sub NurHyperlinksEntfernen()
    Dim fld As Word.Field
   
    For Each fld In ActiveDocument.Fields
        If fld.Type = wdFieldHyperlink Then
            fld.Unlink
        End If
    Next fld
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:18
Rufname:

Inhalt aus Kopfzeilen und Fusszeilen entfernen - Inhalt aus Kopfzeilen und Fusszeilen entfernen

Nach oben
       Version: Office 2003

Code:
Sub InhaltAusKopfzeilenUndFusszeilenEntfernen()
    Dim hdf As HeaderFooter
    Dim Sec As Section
   
    For Each Sec In Activedocument.Sections
        For Each hdf In Sec.Headers
            hdf.Range.Text = ""
        Next hdf
        For Each hdf In Sec.Footers
            hdf.Range.Text = ""
        Next hdf
    Next Sec
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:19
Rufname:

Seriendruck in einzelne Dateien - Seriendruck in einzelne Dateien

Nach oben
       Version: Office 2003

Code:
Public Sub SeriendruckInEinzelneDateien()
On Error GoTo Fehler
    Dim iBrief As Integer, sBrief As String

    Application.Visible = False
    With Activedocument.MailMerge
       .DataSource.ActiveRecord = 1
       Do
          .Destination = wdSendToNewDocument
          .SuppressBlankLines = True
          With .DataSource
             .FirstRecord = .ActiveRecord
             .LastRecord = .ActiveRecord
             sBrief = "C:\" & .DataFields("Name").Value & ".doc"
          End With
          .Execute Pause:=False
          Activedocument.SaveAs FileName:=sBrief
          Activedocument.Close False
          If .DataSource.ActiveRecord < .DataSource.RecordCount Then
             .DataSource.ActiveRecord = wdNextRecord
          Else
             Exit Do
          End If
       Loop
    End With
Fehler:
    Application.Visible = True
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:21
Rufname:

Word Dokument als Anhang in Outlook - Word Dokument als Anhang in Outlook

Nach oben
       Version: Office 2003

Code:
Sub SendDocumentAlsAnhang()
    'Verweis uf Outlook-Library ist Voraussetzung
    Dim Otl As Outlook.Application
    Dim OtlItem As MailItem
   
    Set Otl = New Outlook.Application
    With Otl
        Set OtlItem = .CreateItem(olMailItem)
        With OtlItem
            .To = "test.t@test.de"
            .Subject = "Hallo"
            .Attachments.Add Activedocument.FullName
            .Display ' nur anzeigen
            '.Send ' abschicken
        End With
    End With
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:21
Rufname:

Bild an Cursorposition einfügen - Bild an Cursorposition einfügen

Nach oben
       Version: Office 2003

Code:
Sub InsertPicture()
    Dim strDateiname As String
    Dim strEingabe As String
    '
    With Dialogs(wdDialogInsertPicture)
        'Dialog zur Auswahl der Grafikdatei anzeigen
        If .Display = -1 Then
            'gewählten Dateinamen merken
            strDateiname = .Name
            'an Cursorposition in Dokument einfügen
            Selection.InlineShapes.AddPicture FileName:=strDateiname _
                                            , LinkToFile:=False _
                                            , SaveWithDocument:=True
            Selection.Collapse Direction:=wdCollapseEnd
        End If
    End With
End Sub
MarcSLK
Word seit 4.0 (DOS


Verfasst am:
03. Aug 2010, 10:23
Rufname:


Drucken der aktuellen Seite - Drucken der aktuellen Seite

Nach oben
       Version: Office 2003

Code:
Sub DruckenAktuelleSeite()
    On Error Resume Next
    Application.PrintOut FileName:="", Range:=wdPrintCurrentPage _
                       , Item:=wdPrintDocumentContent, Copies:=1, Pages:="" _
                       , PageType:=wdPrintAllPages, Collate:=True _
                       , Background:=True, PrintToFile:=False
End Sub
Neues Thema eröffnen   Neue Antwort erstellen Alle Zeiten sind
GMT + 1 Stunde

Gehe zu Seite 1, 2, 3  Weiter
Diese Seite Freunden empfehlen

Seite 1 von 3
Gehe zu:  
Du kannst Beiträge in dieses Forum schreiben.
Du kannst auf Beiträge in diesem Forum antworten.
Du kannst deine Beiträge in diesem Forum nicht bearbeiten.
Du kannst deine Beiträge in diesem Forum nicht löschen.
Du kannst an Umfragen in diesem Forum nicht mitmachen.
Du kannst Dateien in diesem Forum nicht posten
Du kannst Dateien in diesem Forum herunterladen

Verwandte Themen
Forum / Themen   Antworten   Autor   Aufrufe   Letzter Beitrag 
Keine neuen Beiträge Word Formate: Einfügen/Datei - Formatierungen übernehmen (Zeilenabstand) 5 Germknödl 188 05. Sep 2013, 22:58
MarkMH_K Einfügen/Datei - Formatierungen übernehmen (Zeilenabstand)
Keine neuen Beiträge Word Serienbriefe: Excel Datei als Datenquelle, Limit an Feldern? 1 mcflyjule 283 18. Jul 2013, 08:26
MarkMH_K Excel Datei als Datenquelle, Limit an Feldern?
Keine neuen Beiträge Word Serienbriefe: Inhaltssteuerelemente nach Öffnen der Datei löschbar 0 Daniel57 202 22. Okt 2012, 12:44
Daniel57 Inhaltssteuerelemente nach Öffnen der Datei löschbar
Keine neuen Beiträge Word Formate: Öffnen der Datei, Anzahl der Aufrufe weiterzählen! 3 melly89 988 06. Jul 2011, 10:46
Gast Öffnen der Datei, Anzahl der Aufrufe weiterzählen!
Keine neuen Beiträge Word Formate: Formatänderung beim einfügen einer Datei 0 sebastian.e 403 06. Nov 2010, 00:01
sebastian.e Formatänderung beim einfügen einer Datei
Keine neuen Beiträge Word Formate: PowerPoint Datei einbinden: Dateipfad anzeigen? 0 hans.merkel1983 1903 07. Mai 2010, 11:42
hans.merkel1983 PowerPoint Datei einbinden: Dateipfad anzeigen?
Keine neuen Beiträge Word Formate: dot Datei Format und Kästen festmachen 1 J.P.S. 1084 26. Aug 2009, 18:40
DocTemplate dot Datei Format und Kästen festmachen
Keine neuen Beiträge Word Serienbriefe: Word Template aus Feldern einer Quell- Datei füllen 1 realdave 892 10. Jul 2009, 12:10
Gast Word Template aus Feldern einer Quell- Datei füllen
Keine neuen Beiträge Word Formate: Autotext aus einer anderen Datei kopieren 7 ullistein 3814 29. Aug 2008, 11:49
ullistein Autotext aus einer anderen Datei kopieren
Keine neuen Beiträge Word Serienbriefe: Serienbrief - Daten aus 2 Tabellenblättern einer EXCEL Datei 1 drivetech01 5248 10. Jan 2008, 21:04
Hübi Serienbrief - Daten aus 2 Tabellenblättern einer EXCEL Datei
Keine neuen Beiträge Word Formate: Datei/Neu ist weg ! 1 Battlecat 602 09. Aug 2007, 13:37
iso Datei/Neu ist weg !
Keine neuen Beiträge Word Serienbriefe: jede Seite eines Worddokuments in eigene Datei speichern 1 computerschmied 2625 30. März 2007, 12:24
Gast jede Seite eines Worddokuments in eigene Datei speichern
 

----> Diese Seite Freunden empfehlen <------ Impressum - Besuchen Sie auch: Microsoft Word Serienbriefe