Suchfeld in Symbolleiste

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Public Sub anlegen() Dim myBar As CommandBar, myCtrl As CommandBarControl Set myBar = CommandBars.Add("suchen", msoBarFloating, False, True) Set myCtrl = myBar.Controls.Add(Type:=msoControlEdit) myCtrl.OnAction = "suchen" myBar.Visible = True End Sub Private Sub suchen() 'Hier kommt deine Suchroutine rein End Sub

Hallo

Bei Unklarheiten melden.

'
'   05/10/2003
'©  Ing.Friedrich Grath
'@  grath.fritz@aon.at
'

'***********************************************************************
'In ein MODUL (Name: Modul1)

Option Explicit
Option Base 1
Option Compare Text

Dim n%, x%, c
Dim Adresse()                    As String
Dim indexAnzeige                 As Integer
Dim Meldung                      As Byte

'------------------------------------------------------------------------

' Neue Symbolleiste erstellen und mit Schaltbutton versehen
Sub Neue_Symbolleiste()
' Falls Symbollsite schon existiert löschen und neu anlegen
On Error Resume Next
CommandBars("Suchen").Delete
CommandBars.Add Name:="Suchen"

' Symbolleiste oben links anzeigen und mit Schaltflächen versehen
With CommandBars("Suchen")
    .Position = msoBarTop
    .Visible = True
    .Controls.Add Type:=msoControlEdit      'Textbox f. Suchtext
    .Controls.Add Type:=msoControlButton    'Button für Weitersuchen
End With

With CommandBars("Suchen").Controls(1)
    .Width = 100
    .TooltipText = "Suchbegriff eingeben und mit ENTER bestättigen"
    .Text = ""
    .OnAction = "Suche_starten"
End With

With CommandBars("Suchen").Controls(2)
    .Caption = " Suche fortsetzen    "
    .FaceId = 345
    .Style = msoButtonIconAndCaption
    .OnAction = "Anzeige_fortsetzen"
    .Enabled = False
End With
End Sub
'------------------------------------------------------------------------
Sub Symbolleiste_löschen()
    On Error Resume Next
    CommandBars("Suchen").Delete
End Sub
'------------------------------------------------------------------------
Sub Suche_starten()
Dim objList As CommandBarControl

Dim ersteAdresse                 As String
Dim Text                         As String
Dim Suchen                       As String

'Suchbegriff aus Textbox
Set objList = CommandBars.ActionControl
Suchen = objList.Text

If Suchen = "" Then Exit Sub

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

x = 1: indexAnzeige = 0
With ActiveSheet.UsedRange
    Set c = .Find(Suchen, After:=Cells(.Rows.Count, .Columns.Count), LookIn:=xlValues)
    If Not c Is Nothing Then
        ersteAdresse = c.Address
        Do
            ReDim Preserve Adresse(x)
            Adresse(x) = c.Address(RowAbsolute:=False, ColumnAbsolute:=False)
            Set c = .FindNext(c)
            x = x + 1
        Loop While Not c Is Nothing And c.Address <> ersteAdresse
    End If
End With

'Anzeige der ersten gefundenen Übereinstimmung
Select Case x
Case 1
    CommandBars("Suchen").Controls(2).Enabled = False
    Meldung = MsgBox("Es wurde kein übereinstimmender Wert gefunden", _
    vbOKOnly, "G E F U N D E N E   W E R T E")
    Exit Sub
Case 2
    CommandBars("Suchen").Controls(2).Enabled = False
Case Else
    CommandBars("Suchen").Controls(2).Enabled = True
End Select

    ActiveSheet.Range(Adresse(1)).Select

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
'------------------------------------------------------------------------
Sub Anzeige_fortsetzen()

    indexAnzeige = indexAnzeige + 1

    If indexAnzeige = x - 1 Then
        CommandBars("Suchen").Controls(2).Enabled = False
        Meldung = MsgBox("Es wurde der letzte übereinstimmender Wert angezeigt", _
        vbOKOnly, "G E F U N D E N E   W E R T E")
        Exit Sub
    Else
        ActiveSheet.Range(Adresse(indexAnzeige + 1)).Select
    End If

End Sub
'***********************************************************************

'***********************************************************************
'In DieseArbeitsmappe
Option Explicit

Private Sub Workbook_BeforeClose(Cancel As Boolean)
    Call Modul1.Symbolleiste_löschen
End Sub

Private Sub Workbook_Open()
    Call Modul1.Neue_Symbolleiste
End Sub
'***********************************************************************

Code eingefügt mit Syntaxhighlighter 2.4

mfg, GraFri

Beliebteste Forumthreads (12 Monate)

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread