Otlk.Macros/general.bas

Attribute VB_Name = "general"
Option Explicit


Public Function SortBox(Liste As ListBox) '(cltBox As Control, intSpalten As Integer, intSpalte As Integer, Optional bytWie As Byte = 1)

  Dim i As Long
  Dim x As Long
  Dim TMP As String
  Dim ARR() As String
  Dim bAdd As Boolean
  Dim nCount As Long
 
  ' alle Einträge in einen String speichern
  For i = 0 To Liste.ListCount - 1
    TMP = TMP & Liste.List(i) & "¦¦"
  Next i
  If Len(TMP) > 0 Then TMP = Left$(TMP, Len(TMP) - 2)
 
  ' String splitten
  ARR() = Split(TMP, "¦¦")
 
  With Liste
    ' Liste löschen
    .Clear
 
    ' macht das Ganze noch etwas schneller
    .Visible = False
 
    ' alle Einträge des Arrays durchlaufen und
    ' sortiert in die ListBox schreiben
    nCount = UBound(ARR)
    For i = 0 To nCount
      bAdd = True
      For x = 0 To .ListCount - 1
        If .List(x) > ARR(i) Then
          .AddItem ARR(i), x
          bAdd = False: Exit For
        End If
      Next x
      If bAdd Then .AddItem ARR(i)
    Next i
 
    ' Listendarstellung wieder einschalten
    .Visible = True
    If .ListCount > 0 Then
        .ListIndex = 0
    End If
  End With
 
End Function

Public Function ValidLikePattern(LikePattern As String) As Boolean

    Dim temp As Boolean
    
    On Error Resume Next
    temp = ("A" Like "*" & LikePattern & "*")
    If Err.Number = 0 Then
        ValidLikePattern = True
    End If
    On Error GoTo 0
    
End Function

'Public Function TransposeArray(myarray As Variant) As Variant
'    Dim x As Long
'    Dim Y As Long
'    Dim Xupper As Long
'    Dim Yupper As Long
'    Dim tempArray As Variant
'
'    Xupper = UBound(myarray, 2)
'    Yupper = UBound(myarray, 1)
'    ReDim tempArray(Xupper, Yupper)
'    For x = 0 To Xupper
'        For Y = 0 To Yupper
'            tempArray(x, Y) = myarray(Y, x)
'        Next Y
'    Next x
'    TransposeArray = tempArray
'End Function
 
 Sub SetCat(Text As String, overwrite As Boolean)
    Dim objOutlook As Outlook.Application
    Dim objExplorer As Outlook.Explorer
    Dim objInspector As Outlook.Inspector
    
    Dim strDateTime As String
    Dim x, i As Long
    Dim strCats As String
    Dim nextFor As Boolean
    
    ' Instantiate an Outlook Application object.
    Set objOutlook = CreateObject("Outlook.Application")

    ' The ActiveInspector is the currently open item.
    Set objExplorer = objOutlook.ActiveExplorer

    ' Check and see if anything is open.
    If Not objExplorer Is Nothing Then
        ' Get the current item.
        Dim arySelection As Object
        Set arySelection = objExplorer.Selection
        
        For x = 1 To arySelection.Count
            strCats = arySelection.Item(x).categories
            If Not strCats = "" Then
                For i = 1 To Len(strCats)
                    If Mid(strCats, i, Len(Text)) = Text Then
                        nextFor = True
                        Exit For
                    End If
                Next i
                strCats = strCats & "; "
            End If
            If nextFor = True Then
                nextFor = False
                GoTo NextX
            End If
            
            If overwrite = True Then
                strCats = Text
            Else
                strCats = strCats & Text
            End If
            arySelection.Item(x).categories = strCats
            arySelection.Item(x).Save
NextX:
        Next x
        
    Else
        ' Show error message with only the OK button.
        MsgBox "No explorer is open", vbOKOnly
    End If

    ' Set all objects equal to Nothing to destroy them and
    ' release the memory and resources they take.
    Set objOutlook = Nothing
    Set objExplorer = Nothing

End Sub

Sub CreateSearchFolder(folderPath As String, _
                       Filter As String, _
                       folderToCreate As String)

        Dim objSearch As Search
        Set objSearch = Application.AdvancedSearch(folderPath, _
                                                   Filter, _
                                                   True, _
                                                   "SearchFolder")
        objSearch.Save(folderToCreate).ShowItemCount = olShowTotalItemCount

End Sub

Function SearchFolderExists(storeName As String, Foldername As String) As Boolean
    
    Dim store As Variant
    
    SearchFolderExists = False
    
    For Each store In Application.Session.Stores.Item(storeName).GetSearchFolders()
        
        If store.Name = Foldername Then
            SearchFolderExists = True
        End If
        
    Next
End Function

Function GetEmailAddressOfCurrentUser() As String

    Dim OL, olAllUsers, oExchUser, oentry, myitem As Object
    Dim User As String

    Set OL = CreateObject("outlook.application")
    Set olAllUsers = OL.Session.AddressLists.Item("All Users").AddressEntries

    User = OL.Session.CurrentUser.Name

    Set oentry = olAllUsers.Item(User)

    Set oExchUser = oentry.GetExchangeUser()

    GetEmailAddressOfCurrentUser = oExchUser.PrimarySmtpAddress
End Function

Public Function GetCategories() As Collection
    
    Dim objNS As NameSpace
    Dim objCat As category
        
    Set GetCategories = New Collection
    Set objNS = Application.GetNamespace("MAPI")

    If objNS.categories.Count > 0 Then
        For Each objCat In objNS.categories
            GetCategories.Add objCat.Name
        Next
    End If
        
End Function

Sub ImportCategories()

    Dim txtFileName As String
    Dim txtFileNumber As Integer
    Dim lastDataRow  As Long
    
    Dim categoryName As String
    
    ' Namen und Verzeichnis für die txt-Datei
    txtFileName = "\\fondium.org\DESI$\AUG_Abteilung\Betriebstechnik\50_I&R\01_I&R Giesserei\100_Sicherung\E\01_Prj\ProjectCategories.gf"

    ' Freie Datei-Nummer erhalten
    txtFileNumber = FreeFile
    
    ' txt-Dateien vorbereiten zum Auslesen
    If Len(Dir(txtFileName)) <> 0 Then
        Open txtFileName For Input As #txtFileNumber
    Else
        Exit Sub
    End If
    
    ' Überprüfen ob txt-Datei gefunden wurde
    If Err.Number <> 0 Then
        MsgBox "Datei mit GF-Kategorien wurde nicht gefunden!", vbCritical, "Fehler!"
        Exit Sub
    End If
    
    On Error GoTo 0
    
    ' alle Zeilen der txt-Datei durchlaufen
    Do While Not EOF(txtFileNumber)
    
        ' Daten aus txt-Datei auslesen
        Input #txtFileNumber, categoryName
        
        ' Kategorie zu Outlook hinzufügen
        AddCategory categoryName
    Loop
    
    ' txt-Datei schließen
    Close #txtFileNumber
    
End Sub

Private Sub AddCategory(categoryName As String)
    
    Dim objNS As NameSpace
 
    Set objNS = Application.GetNamespace("MAPI")
       On Error Resume Next
    objNS.categories.Add categoryName
    Set objNS = Nothing
    
End Sub