Otlk.Macros/frmSetCategories.frm

VERSION 5.00
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSetCategories 
   Caption         =   "UserForm1"
   ClientHeight    =   11310
   ClientLeft      =   120
   ClientTop       =   465
   ClientWidth     =   5790
   OleObjectBlob   =   "frmSetCategories.frx":0000
   StartUpPosition =   1  'Fenstermitte
End
Attribute VB_Name = "frmSetCategories"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Option Explicit


Private Sub btnSearchFolder_Click()
    
    Dim lItem As Variant
    
    Const PR_SENDER_EMAIL_ADDRESS_W As String = "(" & """urn:schemas-microsoft-com:office:office#Keywords""" & " = " & "'BT.IT'" & ")"
    
    Dim Filter As String
    
    For lItem = 0 To Me.lstDetail.ListCount - 1
        If Me.lstDetail.Selected(lItem) Then
            Filter = "(" & """urn:schemas-microsoft-com:office:office#Keywords""" & " = " & "'" & Me.lstDetail.List(lItem) & "'" & ")"
            
             Call CreateSearchFolder(gfSettings.GetSettingValue("OnlineArchiv"), Filter, Me.lstDetail.List(lItem))
        End If
    Next lItem
    
End Sub

Private Sub btnSettings_Click()

    frmSettings.Show
    
End Sub

Private Sub lstSelection_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    
    Dim lItem As Long
    Dim sCategories As String
    
    If KeyCode = 13 Then ' Enter-Key
        If Me.lstSelection.ListCount > 0 Then
            For lItem = 0 To Me.lstSelection.ListCount - 1
                sCategories = sCategories + Me.lstSelection.List(lItem) + "; "
            Next lItem
            Call SetCat(sCategories, True)
        Else
            For lItem = 0 To Me.lstDetail.ListCount - 1
                If Me.lstDetail.Selected(lItem) Then
                    sCategories = sCategories + Me.lstDetail.List(lItem) + "; "
                End If
            Next lItem
            Call SetCat(sCategories, False)
        End If
        
        Unload Me
    ElseIf KeyCode = 109 Then ' --Key
        For lItem = Me.lstSelection.ListCount - 1 To 0 Step -1
            If Me.lstSelection.Selected(lItem) Then
                Me.lstSelection.RemoveItem (lItem)
            End If
        Next lItem
    End If
End Sub

Private Sub UserForm_Activate()
       
    ' Fenster-Titel zuweisen
    Me.Caption = "Kategorie zuweisen"
    
    ResetFilter
    
    ' Importieren der Projekt-Kategorien aus dem Netzwerk
    'general.ImportCategories
   
    ' Liste sortieren
    Call general.SortBox(lstDetail)
    
End Sub

Private Sub txtFilter_Change()
    
    ' reset Filter/neu filtern
    ResetFilter
    
    ' Liste sortieren
    Call general.SortBox(lstDetail)
    
End Sub

Private Sub chkCaseSensitive_Click()
   
    ' reset Filter/neu filtern
    ResetFilter
    
    ' Liste sortieren
    Call general.SortBox(lstDetail)
    
End Sub

Private Sub chkUnique_Click()
    
     ' reset Filter/neu filtern
    ResetFilter
    
    ' Liste sortieren
    Call general.SortBox(lstDetail)
    
End Sub

Private Sub lstDetail_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
    Dim lItem As Long
    Dim sCategories As String
    
    If KeyCode = 13 Then ' Enter-Key
        If Me.lstSelection.ListCount > 0 Then
            For lItem = 0 To Me.lstSelection.ListCount - 1
                sCategories = sCategories + Me.lstSelection.List(lItem) + "; "
            Next lItem
            Call SetCat(sCategories, True)
        Else
            For lItem = 0 To Me.lstDetail.ListCount - 1
                If Me.lstDetail.Selected(lItem) Then
                    sCategories = sCategories + Me.lstDetail.List(lItem) + "; "
                End If
            Next lItem
            Call SetCat(sCategories, False)
        End If
        
        Unload Me
    ElseIf KeyCode = 107 Then ' +-Key
        For lItem = 0 To Me.lstDetail.ListCount - 1
            If Me.lstDetail.Selected(lItem) Then
                 lstSelection.AddItem Me.lstDetail.List(lItem)
            End If
        Next lItem
    End If
    
End Sub

Sub ResetFilter()

    Dim varTableCol As Variant
    Dim RowCount As Long
    Dim collUnique As Collection
    Dim FilteredRows As Collection
    Dim filteredRow As Variant
    Dim i As Long
    Dim ArrCount As Long
    Dim FilterPattern As String
    Dim UniqueValuesOnly As Boolean
    Dim UniqueConstraint As Boolean
    Dim CaseSensitive As Boolean
    
    'the asterisks make it match anywhere within the string
    If Not general.ValidLikePattern(Me.txtFilter.Text) Then
        Exit Sub
    End If
    FilterPattern = "*" & Me.txtFilter.Text & "*"
    
    UniqueValuesOnly = Me.chkUnique.Value
    CaseSensitive = Me.chkCaseSensitive
    Me.lstDetail.Clear
    'used only if UniqueValuesOnly is true
    Set collUnique = New Collection
    Set FilteredRows = New Collection
    'note that Transpose won't work with > 65536 rows
    Set varTableCol = general.GetCategories()
    RowCount = varTableCol.Count
    'ReDim FilteredRows(1 To RowCount)
    For i = 1 To RowCount
        If UniqueValuesOnly Then
            On Error Resume Next
            'reset for this loop iteration
            UniqueConstraint = False
            'Add fails if key isn't UniqueValuesOnly
            collUnique.Add Item:="test", Key:=CStr(varTableCol(i))
            If Err.Number <> 0 Then
                UniqueConstraint = True
            End If
            On Error GoTo 0
        End If
        'True if UniqueValuesOnly is false or if
        'UniqueValuesOnly is True and this is the
        'first occurrence of the item
        If Not UniqueConstraint Then
            'Like operator is case sensitive,
            'so need to use LCase if not CaseSensitive
            If (Not CaseSensitive And LCase(varTableCol(i)) Like LCase(FilterPattern)) Or (CaseSensitive And varTableCol(i) Like FilterPattern) Then
                'add to array if ListBox item matches filter
                ArrCount = ArrCount + 1
                'there's a hidden ListBox column that stores the record num
                FilteredRows.Add varTableCol(i)
            End If
        End If
    Next i
   
    If ArrCount > 1 Then
        For Each filteredRow In FilteredRows
            Me.lstDetail.AddItem filteredRow
        Next
    Else
        Me.lstDetail.Clear
        'have to add separately if just one match
        'or we get two rows, not two columns, in ListBox
        If ArrCount = 1 Then
            For Each filteredRow In FilteredRows
                Me.lstDetail.AddItem filteredRow
            Next
        End If
    End If

End Sub