title image


Smiley VBA-Makro-Programm


So?













Option Explicit



' von http://mypage.bluewin.ch/reprobst/WordFAQ/HL.htm#HL08





Sub HL_SubGeheZuNextHyperlink()

'

' HL_SubGeheZuNextHyperlink Makro

' Makro aufgezeichnet am 11.09.2004

'

    Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1, Name:= _

        "HYPERLINK"

        

End Sub



Sub HyperlinksExplizitMachen()

  

  Const strTitel = "Hyperlinks zusätzlich explizit einfügen"

  

  Dim oStory                                As Range

  ' Var strText wird verwendet, ist aber insgesamt überflüssig:

  Dim strText                               As String

  Dim strMsgTxt                             As String

  Dim intGesamt                             As Integer

  Dim intHLWarAnSichSchonExplizit           As Integer

  Dim intMakroHatDiesenHLSchonBearbeitet    As Integer

  Dim intVeraendert                         As Integer

  

  

  strMsgTxt = "Das Programm fügt hinter Hyperlinks den Hyperlink " & _

              "(Buchhandel) noch einmal" & _

              " explizit (http://www.amazon.de) ein. Es bemüht sich dabei, " & _

              "Dopplungen zu vermeiden " & _

              "(ein bereits expliziter Hyperlink soll nicht wiederholt werden; " & _

              "läuft der Makro mehrmals, so soll jeder Hyperlink nur einmal " & _

              "explizit gemacht werden (also nur neue Hyperlinks " & _

              "explizit machen))." & _

              vbNewLine & _

              vbNewLine & _

              "Sicherheitskopie erstellt? Wirklich ausführen?"

  If MsgBox(strMsgTxt, _

            vbQuestion + vbYesNoCancel, _

            strTitel) <> vbYes Then

    End

  End If

  

  intGesamt = 0

  intHLWarAnSichSchonExplizit = 0

  intMakroHatDiesenHLSchonBearbeitet = 0

  intVeraendert = 0

  strText = ""

  For Each oStory In ActiveDocument.StoryRanges

    HyperlinksAuslesenNextStory oStory, _

                                strText, _

                                intGesamt, _

                                intHLWarAnSichSchonExplizit, _

                                intMakroHatDiesenHLSchonBearbeitet, _

                                intVeraendert

    While Not (oStory.NextStoryRange Is Nothing)

      Set oStory = oStory.NextStoryRange

      HyperlinksAuslesenNextStory oStory, _

                                  strText, _

                                  intGesamt, _

                                  intHLWarAnSichSchonExplizit, _

                                  intMakroHatDiesenHLSchonBearbeitet, _

                                  intVeraendert

    Wend

  Next

  

  If strText = "" Then

    MsgBox "Das Dokument beinhaltet keine Hyperlinks.", _

           vbInformation, _

           strTitel

    Exit Sub

  End If

  

  MsgBox "Fertig." & _

         vbNewLine & vbNewLine & _

         "Gesamtanzahl Hyperlinks (ohne Inhaltsverzeichnis): " & _

         vbTab & intGesamt & "." & _

         vbNewLine & _

         "Hyperlinks an sich bereits explizit: " & _

         vbTab & vbTab & vbTab & intHLWarAnSichSchonExplizit & _

         vbNewLine & _

         "Hyperlinks, die (der Makro?) bereits explizit gemacht hatte: " & _

         vbTab & intMakroHatDiesenHLSchonBearbeitet & _

         vbNewLine & _

         "Hyperlinks, die verändert wurden: " & _

         vbTab & vbTab & vbTab & intVeraendert, _

         vbInformation, _

         strTitel

         

  ' Gegenprobe

  If intMakroHatDiesenHLSchonBearbeitet + _

     intHLWarAnSichSchonExplizit + _

     intVeraendert <> _

     intGesamt Then

        MsgBox "Die Summe " & _

               vbNewLine & _

               vbNewLine & _

               "Hyperlinks an sich bereits explizit + " & _

               vbNewLine & _

               "Hyperlinks, die (der Makro?) bereits explizit gemacht hatte + " & _

               vbNewLine & _

               "Hyperlinks, die verändert wurden " & _

               vbNewLine & vbNewLine & _

               "weicht ab von der " & _

               vbNewLine & vbNewLine & "Gesamtanzahl der Hyperlinks.", _

               vbExclamation, _

               strTitel

  End If

  

  If intGesamt <> ActiveDocument.Hyperlinks.Count Then

    MsgBox "Vom Programm gezählte Gesamtanzahl der " & _

           "Hyperlinks weicht ab vom Word-Wert " & _

           "(Grund: Inhaltsverzeichnis? Dokumentteile?) ", _

           vbInformation, _

           strTitel

  End If

    

End Sub



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

' Hilfsroutine



Private Sub HyperlinksAuslesenNextStory(oStory As Range, _

                                        strText As String, _

                                        intGesamt, _

                                        intHLWarAnSichSchonExplizit, _

                                        intMakroHatDiesenHLSchonBearbeitet, _

                                        intVeraendert)

  

  Dim HL                                    As Hyperlink

  Dim oToc                                  As TableOfContents

  Dim Flag                                  As Boolean

  Dim strInsertText                         As String

  Dim rngTestRange                          As Range

  Dim boolHLWarAnSichSchonExplizit          As Boolean

  Dim boolMakroHatDiesenHLSchonBearbeitet   As Boolean

    

  

  For Each HL In oStory.Hyperlinks

    Flag = False

    strInsertText = ""

    

    ' Ggf. Check gegen Inhaltsverzeichnis

    If oStory.StoryType = wdMainTextStory Then

      'Testen, ob dies ein interner Hyperlink aus dem Inhaltsverzeichnis ist

      For Each oToc In ActiveDocument.TablesOfContents

        If HL.Range.InRange(oToc.Range) Then

          Flag = True

          Exit For

        End If

      Next  ' For Each oToc

    End If

    

    If Flag = False Then  ' oder if true then

      

      intGesamt = intGesamt + 1

      ' Für strInsertText ist dies "If" überflüssig

      If Val(Left(Application.Version, 1)) = 8 Then 'HL-Eigenschaften für WD97

        strText = strText & HL.Range.Text & vbTab & HL.Address & vbTab & _

                  HL.SubAddress & vbCrLf

        strInsertText = " [" & HL.Address & _

                        HL.SubAddress

      Else 'Hyperlink-Eigenschaften ab WD2000

        strText = strText & HL.Range.Text & vbTab & HL.Address & vbTab & _

                  HL.SubAddress & vbTab & HL.ScreenTip & vbCrLf

        strInsertText = " [" & HL.Address & _

                        HL.SubAddress

      End If ' If Val(Left(Application.Version, 1))

      

      ' Ggf. / am Ende entfernen

      If HL.SubAddress = "" And _

         Right(strInsertText, 1) = "/" Then

            strInsertText = Left(strInsertText, Len(strInsertText) - 1)

      End If   '  if HL.SubAddress  = ""

      strInsertText = strInsertText & "]"

      

      ' Ist der Hyperlink an sich bereits explizit?

      If HL.Range.Text <> HL.Address & HL.SubAddress And _

         HL.Range.Text & "/" <> HL.Address & HL.SubAddress Then

         boolHLWarAnSichSchonExplizit = False

      Else

         boolHLWarAnSichSchonExplizit = True

         intHLWarAnSichSchonExplizit = intHLWarAnSichSchonExplizit + 1

      End If

      

      ' Hat der Makro Diesen HL schon bearbeitet?

      ' Dann nur neue Links explizit machen.

      Set rngTestRange = HL.Range

      rngTestRange.SetRange HL.Range.End, HL.Range.End + Len(strInsertText)

      If rngTestRange.Text <> strInsertText Then

         boolMakroHatDiesenHLSchonBearbeitet = False

      Else

         boolMakroHatDiesenHLSchonBearbeitet = True

         intMakroHatDiesenHLSchonBearbeitet = intMakroHatDiesenHLSchonBearbeitet + 1

      End If

      

      ' Ergebnisse auswerten, ggf. einfügen

      If boolHLWarAnSichSchonExplizit = False And _

         boolMakroHatDiesenHLSchonBearbeitet = False Then

            ' Einfügen

            HL.Range.InsertAfter strInsertText

            intVeraendert = intVeraendert + 1

      Else

         ' Tue nichts

      End If

      

    End If ' If Flag = False Then

    

  Next  ' For Each HL

  

End Sub





Code eingefügt mit Syntaxhighlighter 2.2





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: