title image


Smiley Endlich!
Hallo !



Neue Version, mit der jetzt man

die Buttons auch zum Einfügen nutzen kann.



Ausserdem gibt es jetzt 5 Stück davon

(den Wert kannst Du auch noch erhöhen).



Gruß, Chrisir















Option Explicit



' Version 4



' Ersetzt die Clipboard-Symbolleiste in Word 2000.



' Bitte Modulnamen eintragen (wo jetzt ModulZwischenablage steht).

' Oder Modul gleich ModulZwischenablage nennen.

'

' Kann 5 Buttons mit Clipboardinhalte belegen.

' Fängt dann wieder beim ersten an.

' Anzahl 5 in intConstMaxintActiveButtonCount (Wert +1) abgelegt.

' Leider nur unformatierter Text.



' Zeilenumbrüche & Tabs werden durch "-" dargestellt



' Die Buttons sind per Maus oder

' per ALT-1, ALT-2 etc. ausführbar.

'

' Schon vorhandene Clipboardinhalte werden nicht erneut abgelegt.

' Leerer Clipboardinhalt ("" oder nur Leerzeichen ("    "))

' wird nicht abgelegt.

'

' Es gibt unten ein Programm KeyBindings_Definieren zur Belegung

' der Tastenzuordnung

' von Alt-1 Alt-2 und Alt-3; Alt-4 und Alt-5 lassen sich

' automat. über "&4" in der Caption regeln (was für

' Alt-1 etc. nicht geht);

' dann kann man mit diesen Tasten die

' Buttons in der Symbolleiste anwählen.

' Wird von den subs aufgerufen.

'

' Nach der Init-sub StarteNeuenButton kann diese entweder

' die TimerSchleife starten (Sub StarteSchleifeTimer())

' oder aufhören. Man kann dann die TimerSchleife manuell starten

' (Sub StarteSchleifeTimer()) oder die

' sub SetzeClipboardAlsButtonCaption verwenden; diese startet

' keinen Timer, sondern ist einmalig. Sie kann auch von einer

' anderen sub aufgerufen werden.

'

' Es gibt unten ein Programm zum Stoppen des Timers und zum

' Löschen der Symbolleiste strConstNameSL.

'

' Achtung: Die Tag-Eigenschaft hat nur die ersten 180

' des Zeichen Clipboards (Left(strText, 180)).

' Bei der Abfrage, ob der Clipboardinhalt schon existiert

' (Schleife) daher auch auf Left(strText, 180) prüfen

' (Function boolFuncTextInClipboardIstNeu(strText) As Boolean).



' Bitte beachten: Löschen von Buttons: Alt-Taste halten und

' Button mit der Maus von der Leiste ziehen.

' "Retten" von Buttons (diese dauerhaft machen):

' Alt-Taste halten und

' Button mit der Maus von der Leiste in eine

' andere Leiste ziehen (zum Kopieren dazu STRG

' gedrückt halten; dann die vorstehende Zahl aus

' der Caption des Buttons manuell entfernen).

'

' stets CustomizationContext = NormalTemplate





' Name der Symbolleiste (SL)

Const strConstNameSL = "Clipboard Anzeige"

' Titel für MsgBox etc.:

Const strConstTitel = "Clipboard in Symbolleiste anzeigen"

' Max Anzahl Buttons in der SL (+1)

Const intConstMaxintActiveButtonCount = 6



' Aktuelle Button-Nummer: Wird hogezählt und bei Wert >=

' intConstMaxintActiveButtonCount wieder auf 1 gesetzt

Public intActiveButtonCount As Integer

Dim MyData                  As DataObject



Sub StarteNeuenButton()

    

    ' Init

    

    Dim MyData      As DataObject

    Dim strText     As String

    Dim ctlControl  As CommandBarButton

    

    

    CustomizationContext = NormalTemplate

    

    KeyBindings_Definieren

    

    intActiveButtonCount = 1



    If funcBoolExistiertDieSymbolleiste(strConstNameSL) = False Then

        MsgBox "Symbolleiste " & _

               vbNewLine & _

               """" & _

               strConstNameSL & _

               """ existiert noch nicht. Sie wird angelegt.", _

               vbInformation, _

               strConstTitel

        CommandBars.Add strConstNameSL

        CommandBars(strConstNameSL).Position = msoBarTop

    End If

    

    CommandBars(strConstNameSL).Visible = True

    CommandBars(strConstNameSL).Enabled = True

    

    On Error Resume Next

    Set ctlControl = _

            CommandBars(strConstNameSL).Controls(intActiveButtonCount)

    On Error GoTo 0

    

    If funcBoolExistiertDerButton(ctlControl) = True Then

        '

    Else

        Set ctlControl = _

                 Application.CommandBars(strConstNameSL).Controls.Add

    End If

    

    strText = ""

    Set MyData = New DataObject

    

    MyData.GetFromClipboard

    strText = MyData.GetText(1)

    

    If Trim(strText) = "" Then strText = "Clipboard"

    SetzeWerteFuerCommandBarButton ctlControl, strText

    intActiveButtonCount = intActiveButtonCount + 1

    If intActiveButtonCount >= intConstMaxintActiveButtonCount Then

        intActiveButtonCount = 1

    End If

    

    If MsgBox("Timerschleife starten?", _

              vbYesNo + vbQuestion, _

              strConstTitel) = vbYes Then

          StarteSchleifeTimer

    End If

    

    Set MyData = Nothing

    

End Sub



Sub StarteSchleifeTimer()

    

    ' ruft sich selbst immer wieder

    ' zeitverzögert auf

    

    Dim strText           As String

    Dim ctlLocalControl   As CommandBarButton

    

    

    strText = ""

    Set MyData = New DataObject

    MyData.GetFromClipboard

    strText = MyData.GetText(1)

    

    If boolFuncTextInClipboardIstNeu(strText) = True Then

        

        CustomizationContext = NormalTemplate

        If funcBoolExistiertDieSymbolleiste(strConstNameSL) = False Then End

        KeyBindings_Definieren

       

        On Error Resume Next

        Set ctlLocalControl = _

                CommandBars(strConstNameSL).Controls(intActiveButtonCount)

        On Error GoTo 0

    

        If funcBoolExistiertDerButton(ctlLocalControl) = False Then

            Set ctlLocalControl = _

                   Application.CommandBars(strConstNameSL).Controls.Add

        End If

        SetzeWerteFuerCommandBarButton ctlLocalControl, strText

        intActiveButtonCount = intActiveButtonCount + 1

        If intActiveButtonCount >= intConstMaxintActiveButtonCount Then

            intActiveButtonCount = 1

        End If



    End If

    

    Application.OnTime When:=Now + TimeValue("00:00:01"), _

                       Name:="Normal.ModulZwischenablage.StarteSchleifeTimer"

                       

End Sub



Sub SetzeClipboardAlsButtonCaption()

    

    ' wird nur einmalig ausgeführt

    

    Dim MyData           As DataObject

    Dim strText          As String

    Dim ctlLocalControl  As CommandBarButton





    If funcBoolExistiertDieSymbolleiste(strConstNameSL) = False Then

        MsgBox "Symbolleiste nicht gefunden.", _

               vbExclamation, _

               strConstTitel

        End

    End If

    

    KeyBindings_Definieren

    CustomizationContext = NormalTemplate

    

    Set MyData = New DataObject

    

    MyData.GetFromClipboard

    strText = MyData.GetText(1)

    

    On Error Resume Next

    Set ctlLocalControl = _

           CommandBars(strConstNameSL).Controls(intActiveButtonCount)

    On Error GoTo 0

    

    If boolFuncTextInClipboardIstNeu(strText) = True Then

            

        If funcBoolExistiertDerButton(ctlLocalControl) = False Then

            Set ctlLocalControl = _

                   Application.CommandBars(strConstNameSL).Controls.Add

        End If

                

        SetzeWerteFuerCommandBarButton ctlLocalControl, strText

        CommandBars(strConstNameSL).Visible = True

        CommandBars(strConstNameSL).Enabled = True

        intActiveButtonCount = intActiveButtonCount + 1

        If intActiveButtonCount >= intConstMaxintActiveButtonCount Then

            intActiveButtonCount = 1

        End If

        

    End If

    

    Set MyData = Nothing

    

End Sub



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

' ******************   Hilfs-Routinen   *********************************



Function funcBoolExistiertDieSymbolleiste(strConstNameSL As String) _

                                               As Boolean

    

    Dim strDummy    As String

    

    

    strDummy = ""

    On Error Resume Next

    strDummy = CommandBars(strConstNameSL).Name

    On Error GoTo 0

    If strDummy = "" Then

        funcBoolExistiertDieSymbolleiste = False

    Else

        funcBoolExistiertDieSymbolleiste = True

    End If

    

End Function



Function funcBoolExistiertDerButton(ctlLocalControl As CommandBarButton) _

                                         As Boolean

    

    Dim strDummy     As String

    

    

    strDummy = ""

    On Error Resume Next

    strDummy = ctlLocalControl.Caption

    On Error GoTo 0

    If strDummy = "" Then

        funcBoolExistiertDerButton = False

    Else

        funcBoolExistiertDerButton = True

    End If

    

End Function



Sub MyPaste()



    ' die OnAction-Eigenschaft der Buttons

    

    On Error Resume Next

    Selection.TypeText CommandBars.ActionControl.Tag

    On Error GoTo 0

    

End Sub



Sub MyPaste1()



    ' die OnAction-Eigenschaft der Buttons

    

    On Error Resume Next

    Selection.TypeText CommandBars(strConstNameSL).Controls(1).Tag

    On Error GoTo 0

    

End Sub



Sub MyPaste2()



    ' die OnAction-Eigenschaft der Buttons

    

    On Error Resume Next

    Selection.TypeText CommandBars(strConstNameSL).Controls(2).Tag

    On Error GoTo 0

    

End Sub



Sub MyPaste3()



    ' die OnAction-Eigenschaft der Buttons

    

    On Error Resume Next

    Selection.TypeText CommandBars(strConstNameSL).Controls(3).Tag

    On Error GoTo 0

    

End Sub



Sub SetzeWerteFuerCommandBarButton(ctlControl As CommandBarButton, _

                                   strText As String)

    

    Dim strTextFuerCaption As String

    

    

    strTextFuerCaption = Left(strText, 20)

    strTextFuerCaption = replace(strTextFuerCaption, vbCr, "-")

    strTextFuerCaption = replace(strTextFuerCaption, vbLf, "")

    strTextFuerCaption = replace(strTextFuerCaption, vbTab, "-")

    

    With ctlControl

        .Caption = "&" & _

                   ctlControl.Index & _

                   " " & _

                   strTextFuerCaption

        .Enabled = True

        .DescriptionText = "Fügt ein: " & Left(strText, 60)

        .TooltipText = .DescriptionText

        .Visible = True

        .BeginGroup = True

        .Style = msoButtonCaption

        .Tag = Left(strText, 180)

        .OnAction = "ModulZwischenablage.MyPaste"

    End With

    

End Sub



Function boolFuncTextInClipboardIstNeu(strText) As Boolean



    ' Gibt es den Clipboard-Inhalt schon in

    ' der Symbolleiste?



    Dim ctlButtonSchleife As CommandBarButton

    

    

    boolFuncTextInClipboardIstNeu = True

    

    If Trim(strText) = "" Then

        boolFuncTextInClipboardIstNeu = False

        Exit Function

    End If

    

    For Each ctlButtonSchleife In CommandBars(strConstNameSL).Controls

        

        If ctlButtonSchleife.Tag = Left(strText, 180) Then

            boolFuncTextInClipboardIstNeu = False

            Exit Function

        End If

        

    Next ctlButtonSchleife



End Function



Sub KeyBindings_Definieren()

    

    ' Key-Zuordnung

    

    CustomizationContext = NormalTemplate

    

    KeyBindings.Add KeyCategory:=wdKeyCategoryMacro, _

                    Command:="ModulZwischenablage.MyPaste1", _

                    KeyCode:=BuildKeyCode(wdKeyAlt, wdKey1), _

                    CommandParameter:="1"



    KeyBindings.Add KeyCategory:=wdKeyCategoryMacro, _

                    Command:="ModulZwischenablage.MyPaste2", _

                    KeyCode:=BuildKeyCode(wdKeyAlt, wdKey2), _

                    CommandParameter:="2"

                    

    KeyBindings.Add KeyCategory:=wdKeyCategoryMacro, _

                    Command:="ModulZwischenablage.MyPaste3", _

                    KeyCode:=BuildKeyCode(wdKeyAlt, wdKey3), _

                    CommandParameter:="3"

                    

End Sub



Sub DeleteSymbolleiste()

    

    ' Zur Wartung

    

    If funcBoolExistiertDieSymbolleiste(strConstNameSL) Then



        CommandBars(strConstNameSL).Delete

        

    End If

    

End Sub



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

' Zum Timer



Sub StoppeTimer()



    ' Zur Wartung

    

    Application.OnTime When:=Now + TimeValue("00:00:00"), _

                       Name:="Normal.ModulZwischenablage.TueNichts"

                  

End Sub



Sub TueNichts()

    

    ' nichts

    MsgBox "Timer wurde gestoppt.", vbInformation, strConstTitel

    

End Sub



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







Code eingefügt mit Syntaxhighlighter 2.5





geschrieben von

Login

E-Mail:
  

Passwort:
  

Beitrag anfügen

Symbol:
 
 
 
 
 
 
 
 
 
 
 
 
 

Überschrift: