Neuerstellung

ThisOutlookSession.cls

@@ -0,0 +1,48 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "ThisOutlookSession"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = True
+Sub setCategories()
+
+    frmSetCategories.Show
+    
+End Sub
+
+Sub moveMessage()
+    Dim objNS As Outlook.NameSpace
+    Dim objDestFolder As Outlook.MAPIFolder
+    Dim objItem As Variant
+    Dim objCopy As Outlook.MailItem
+    Dim destFolder() As String
+        
+    Set objNS = Application.GetNamespace("MAPI")
+    
+    Set objItem = Application.ActiveExplorer.Selection.Item(1)
+   
+    ' Zielordner festlegen - aus Einstellungen
+    destFolder = Split(Replace(gfSettings.GetSettingValue("OnlineArchiv"), "'", ""), ",")
+    destFolder = Split(Right(destFolder(0), Len(destFolder(0)) - 1), "\")
+    Set objDestFolder = objNS.Folders(destFolder(0)).Folders(destFolder(1))
+   
+   ' vor dem Verschieben pr<EFBFBD>fen ob eine Kategorie vorhanden ist
+    If Len(objItem.categories) = 0 Then
+        MsgBox "Bitte Kategorie zuweisen"
+        Exit Sub
+    End If
+    
+    ' Objekt als gelesen markieren
+    objItem.UnRead = False
+    
+    ' copy and move first
+    objItem.Move objDestFolder
+
+    Set objDestFolder = Nothing
+    Set objNS = Nothing
+
+End Sub
+

frmSetCategories.frm

@@ -0,0 +1,225 @@
+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
+
+
+
+

frmSettings.frm

@@ -0,0 +1,37 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmSettings 
+   Caption         =   "Einstellungen"
+   ClientHeight    =   1815
+   ClientLeft      =   120
+   ClientTop       =   465
+   ClientWidth     =   8895
+   OleObjectBlob   =   "frmSettings.frx":0000
+   StartUpPosition =   1  'Fenstermitte
+End
+Attribute VB_Name = "frmSettings"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+
+Private Sub btnCancel_Click()
+
+     Unload Me
+     
+End Sub
+
+Private Sub btnOk_Click()
+
+    Call gfSettings.SetSettingValue("OnlineArchiv", tbOnlinearchiv.Text)
+    Unload Me
+    
+End Sub
+
+Private Sub UserForm_Activate()
+    
+    ' Fenster-Titel zuweisen
+    Me.Caption = "Einstellungen"
+    
+    tbOnlinearchiv.Text = gfSettings.GetSettingValue("OnlineArchiv")
+        
+End Sub

general.bas

@@ -0,0 +1,264 @@
+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<74>ge in einen String speichern
+  For i = 0 To Liste.ListCount - 1
+    TMP = TMP & Liste.List(i) & "<22><>"
+  Next i
+  If Len(TMP) > 0 Then TMP = Left$(TMP, Len(TMP) - 2)
+ 
+  ' String splitten
+  ARR() = Split(TMP, "<22><>")
+ 
+  With Liste
+    ' Liste l<>schen
+    .Clear
+ 
+    ' macht das Ganze noch etwas schneller
+    .Visible = False
+ 
+    ' alle Eintr<74>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
+    
+    ' <20>berpr<70>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<75>gen
+        AddCategory categoryName
+    Loop
+    
+    ' txt-Datei schlie<69>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
+
+
+
+
+
+

gfSettings.bas

@@ -0,0 +1,23 @@
+Attribute VB_Name = "gfSettings"
+Public Function GetSettingValue(varName As String) As String
+
+  GetSettingValue = GetSetting("GfSettings", "Otlk", varName, "0")
+  
+End Function
+Public Function SetSettingValue(varName As String, varValue As String)
+
+  Call SaveSetting("GfSettings", "Otlk", varName, varValue)
+  
+End Function
+'
+Public Sub test()
+
+
+'Call DeleteSetting("GfSettings", "Otlk")
+'    'SaveMyVariable (56)
+'
+End Sub
+
+
+
+

iniSettings.bas

@@ -0,0 +1,347 @@
+Attribute VB_Name = "iniSettings"
+Private bSectionExists         As Boolean
+Private bKeyExists             As Boolean
+ 
+'---------------------------------------------------------------------------------------
+' Procedure : Ini_ReadKeyVal
+' Author    : Daniel Pineault, CARDA Consultants Inc.
+' Website   : http://www.cardaconsultants.com
+' Purpose   : Read an Ini file's Key
+' Copyright : The following may be altered and reused as you wish so long as the
+'             copyright notice is left unchanged (including Author, Website and
+'             Copyright).  It may not be sold/resold or reposted on other sites (links
+'             back to this site are allowed).
+' Req'd Refs: Uses Late Binding, so none required
+'             No APIs either! 100% VBA
+'
+' Input Variables:
+' ~~~~~~~~~~~~~~~~
+' sIniFile  : Full path and filename of the ini file to read
+' sSection  : Ini Section to search for the Key to read the Key from
+' sKey      : Name of the Key to read the value of
+'
+' Usage:
+' ~~~~~~
+' ? Ini_Read(Application.CurrentProject.Path & "\MyIniFile.ini", "LINKED TABLES", "Path")
+'
+' Revision History:
+' Rev       Date(yyyy/mm/dd)        Description
+' **************************************************************************************
+' 1         2012-08-09              Initial Release
+'---------------------------------------------------------------------------------------
+Function Ini_ReadKeyVal(ByVal sIniFile As String, _
+                        ByVal sSection As String, _
+                        ByVal sKey As String) As String
+    On Error GoTo Error_Handler
+    Dim sIniFileContent       As String
+    Dim aIniLines()           As String
+    Dim sLine                 As String
+    Dim i                     As Long
+ 
+    sIniFileContent = ""
+    bSectionExists = False
+    bKeyExists = False
+ 
+    'Validate that the file actually exists
+    If FileExist(sIniFile) = False Then
+        MsgBox "The specified ini file: " & vbCrLf & vbCrLf & _
+               sIniFile & vbCrLf & vbCrLf & _
+               "could not be found.", vbCritical + vbOKOnly, "File not found"
+        GoTo Error_Handler_Exit
+    End If
+ 
+    sIniFileContent = ReadFile(sIniFile)    'Read the file into memory
+    aIniLines = Split(sIniFileContent, vbCrLf)
+    For i = 0 To UBound(aIniLines)
+        sLine = Trim(aIniLines(i))
+        If bSectionExists = True And Left(sLine, 1) = "[" And Right(sLine, 1) = "]" Then
+            Exit For    'Start of a new section
+        End If
+        If sLine = "[" & sSection & "]" Then
+            bSectionExists = True
+        End If
+        If bSectionExists = True Then
+            If Len(sLine) > Len(sKey) Then
+                If Left(sLine, Len(sKey) + 1) = sKey & "=" Then
+                    bKeyExists = True
+                    Ini_ReadKeyVal = Mid(sLine, InStr(sLine, "=") + 1)
+                End If
+            End If
+        End If
+    Next i
+ 
+Error_Handler_Exit:
+    On Error Resume Next
+    Exit Function
+ 
+Error_Handler:
+    'Err.Number = 75 'File does not exist, Permission issues to write is denied,
+    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
+           "Error Number: " & Err.Number & vbCrLf & _
+           "Error Source: Ini_ReadKeyVal" & vbCrLf & _
+           "Error Description: " & Err.Description & _
+           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
+           , vbOKOnly + vbCritical, "An Error has Occured!"
+    Resume Error_Handler_Exit
+End Function
+ 
+'---------------------------------------------------------------------------------------
+' Procedure : Ini_WriteKeyVal
+' Author    : Daniel Pineault, CARDA Consultants Inc.
+' Website   : http://www.cardaconsultants.com
+' Purpose   : Writes a Key value to the specified Ini file's Section
+'               If the file does not exist, it will be created
+'               If the Section does not exist, it will be appended to the existing content
+'               If the Key does not exist, it will be appended to the existing Section content
+' Copyright : The following may be altered and reused as you wish so long as the
+'             copyright notice is left unchanged (including Author, Website and
+'             Copyright).  It may not be sold/resold or reposted on other sites (links
+'             back to this site are allowed).
+' Req'd Refs: Uses Late Binding, so none required
+'             No APIs either! 100% VBA
+'
+' Input Variables:
+' ~~~~~~~~~~~~~~~~
+' sIniFile  : Full path and filename of the ini file to edit
+' sSection  : Ini Section to search for the Key to edit
+' sKey      : Name of the Key to edit
+' sValue    : Value to associate to the Key
+'
+' Usage:
+' ~~~~~~
+' Call Ini_WriteKeyVal(Application.CurrentProject.Path & "\MyIniFile.ini", "LINKED TABLES", "Paths", "D:\")
+'
+' Revision History:
+' Rev       Date(yyyy/mm/dd)        Description
+' **************************************************************************************
+' 1         2012-08-09              Initial Release
+'---------------------------------------------------------------------------------------
+Function Ini_WriteKeyVal(ByVal sIniFile As String, _
+                         ByVal sSection As String, _
+                         ByVal sKey As String, _
+                         ByVal sValue As String) As Boolean
+    On Error GoTo Error_Handler
+    Dim sIniFileContent       As String
+    Dim aIniLines()           As String
+    Dim sLine                 As String
+    Dim sNewLine              As String
+    Dim i                     As Long
+    Dim bFileExist            As Boolean
+    Dim bInSection            As Boolean
+    Dim bKeyAdded             As Boolean
+ 
+    sIniFileContent = ""
+    bSectionExists = False
+    bKeyExists = False
+ 
+    'Validate that the file actually exists
+    If FileExist(sIniFile) = False Then
+        GoTo SectionDoesNotExist
+    End If
+    bFileExist = True
+ 
+    sIniFileContent = ReadFile(sIniFile)    'Read the file into memory
+    aIniLines = Split(sIniFileContent, vbCrLf)    'Break the content into individual lines
+    sIniFileContent = ""    'Reset it
+    For i = 0 To UBound(aIniLines)    'Loop through each line
+        sNewLine = ""
+        sLine = Trim(aIniLines(i))
+        If sLine = "[" & sSection & "]" Then
+            bSectionExists = True
+            bInSection = True
+        End If
+        If bInSection = True Then
+            If sLine <> "[" & sSection & "]" _
+               And Left(sLine, 1) = "[" And Right(sLine, 1) = "]" Then
+                'Our section exists, but the key wasn't found, so append it
+                bInSection = False    ' we're switching section
+            End If
+            If Len(sLine) > Len(sKey) Then
+                If Left(sLine, Len(sKey) + 1) = sKey & "=" Then
+                    sNewLine = sKey & "=" & sValue
+                    bKeyExists = True
+                    bKeyAdded = True
+                End If
+            End If
+        End If
+        If Len(sIniFileContent) > 0 Then sIniFileContent = sIniFileContent & vbCrLf
+        If sNewLine = "" Then
+            sIniFileContent = sIniFileContent & sLine
+        Else
+            sIniFileContent = sIniFileContent & sNewLine
+        End If
+    Next i
+ 
+SectionDoesNotExist:
+    'if not found, add it to the end
+    If bSectionExists = False Then
+        If Len(sIniFileContent) > 0 Then sIniFileContent = sIniFileContent & vbCrLf
+        sIniFileContent = sIniFileContent & "[" & sSection & "]"
+    End If
+    If bKeyAdded = False Then
+        sIniFileContent = sIniFileContent & vbCrLf & sKey & "=" & sValue
+    End If
+ 
+    'Write to the ini file the new content
+    Call OverwriteTxt(sIniFile, sIniFileContent)
+    Ini_WriteKeyVal = True
+ 
+Error_Handler_Exit:
+    On Error Resume Next
+    Exit Function
+ 
+Error_Handler:
+    MsgBox "The following error has occured" & vbCrLf & vbCrLf & _
+           "Error Number: " & Err.Number & vbCrLf & _
+           "Error Source: Ini_WriteKeyVal" & vbCrLf & _
+           "Error Description: " & Err.Description & _
+           Switch(Erl = 0, "", Erl <> 0, vbCrLf & "Line No: " & Erl) _
+           , vbOKOnly + vbCritical, "An Error has Occured!"
+    Resume Error_Handler_Exit
+End Function
+
+'---------------------------------------------------------------------------------------
+' Procedure : FileExist
+' DateTime  : 2007-Mar-06 13:51
+' Author    : CARDA Consultants Inc.
+' Website   : http://www.cardaconsultants.com
+' Purpose   : Test for the existance of a file; Returns True/False
+'
+' Input Variables:
+' ~~~~~~~~~~~~~~~~
+' strFile - name of the file to be tested for including full path
+'---------------------------------------------------------------------------------------
+Function FileExist(strFile As String) As Boolean
+    On Error GoTo Err_Handler
+ 
+    FileExist = False
+    If Len(Dir(strFile)) > 0 Then
+        FileExist = True
+    End If
+ 
+Exit_Err_Handler:
+    Exit Function
+ 
+Err_Handler:
+    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
+            "Error Number: " & Err.Number & vbCrLf & _
+            "Error Source: FileExist" & vbCrLf & _
+            "Error Description: " & Err.Description, _
+            vbCritical, "An Error has Occured!"
+    GoTo Exit_Err_Handler
+End Function
+ 
+'---------------------------------------------------------------------------------------
+' Procedure : OverwriteTxt
+' Author    : Daniel Pineault, CARDA Consultants Inc.
+' Website   : http://www.cardaconsultants.com
+' Purpose   : Output Data to an external file (*.txt or other format)
+'             ***Do not forget about access' DoCmd.OutputTo Method for
+'             exporting objects (queries, report,...)***
+'             Will overwirte any data if the file already exists
+' Copyright : The following may be altered and reused as you wish so long as the
+'             copyright notice is left unchanged (including Author, Website and
+'             Copyright).  It may not be sold/resold or reposted on other sites (links
+'             back to this site are allowed).
+'
+' Input Variables:
+' ~~~~~~~~~~~~~~~~
+' sFile - name of the file that the text is to be output to including the full path
+' sText - text to be output to the file
+'
+' Usage:
+' ~~~~~~
+' Call OverwriteTxt("C:\Users\Vance\Documents\EmailExp2.txt", "Text2Export")
+'
+' Revision History:
+' Rev       Date(yyyy/mm/dd)        Description
+' **************************************************************************************
+' 1         2012-Jul-06                 Initial Release
+'---------------------------------------------------------------------------------------
+Function OverwriteTxt(sFile As String, sText As String)
+On Error GoTo Err_Handler
+    Dim FileNumber As Integer
+ 
+    FileNumber = FreeFile                   ' Get unused file number
+    Open sFile For Output As #FileNumber    ' Connect to the file
+    Print #FileNumber, sText;                ' Append our string
+    Close #FileNumber                       ' Close the file
+ 
+Exit_Err_Handler:
+    Exit Function
+ 
+Err_Handler:
+    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
+            "Error Number: " & Err.Number & vbCrLf & _
+            "Error Source: OverwriteTxt" & vbCrLf & _
+            "Error Description: " & Err.Description, _
+            vbCritical, "An Error has Occured!"
+    GoTo Exit_Err_Handler
+End Function
+ 
+'---------------------------------------------------------------------------------------
+' Procedure : ReadFile
+' Author    : CARDA Consultants Inc.
+' Website   : http://www.cardaconsultants.com
+' Purpose   : Faster way to read text file all in RAM rather than line by line
+' Copyright : The following may be altered and reused as you wish so long as the
+'             copyright notice is left unchanged (including Author, Website and
+'             Copyright).  It may not be sold/resold or reposted on other sites (links
+'             back to this site are allowed).
+' Input Variables:
+' ~~~~~~~~~~~~~~~~
+' strFile - name of the file that is to be read
+'
+' Usage Example:
+' ~~~~~~~~~~~~~~~~
+' MyTxt = ReadText("c:\tmp\test.txt")
+' MyTxt = ReadText("c:\tmp\test.sql")
+' MyTxt = ReadText("c:\tmp\test.csv")
+'---------------------------------------------------------------------------------------
+Function ReadFile(ByVal strFile As String) As String
+On Error GoTo Error_Handler
+    Dim FileNumber  As Integer
+    Dim sFile       As String 'Variable contain file content
+ 
+    FileNumber = FreeFile
+    Open strFile For Binary Access Read As FileNumber
+    sFile = Space(LOF(FileNumber))
+    Get #FileNumber, , sFile
+    Close FileNumber
+ 
+    ReadFile = sFile
+ 
+Error_Handler_Exit:
+    On Error Resume Next
+    Exit Function
+ 
+Error_Handler:
+    MsgBox "The following error has occured." & vbCrLf & vbCrLf & _
+            "Error Number: " & Err.Number & vbCrLf & _
+            "Error Source: ReadFile" & vbCrLf & _
+            "Error Description: " & Err.Description, _
+            vbCritical, "An Error has Occured!"
+    Resume Error_Handler_Exit
+End Function
+
+Sub TestWriteKey()
+test = Environ("APPDATA")
+    If Ini_WriteKeyVal(Environ("APPDATA") & "\GfSettings.ini", "Otlk", "OnlineArchiv", "\Onlinearchiv - stephan.maier@georgfischer.com\E-Mail Archiv") = True Then
+        MsgBox "The key was written"
+    Else
+        MsgBox "An error occured!"
+    End If
+End Sub
+
+Sub TestReadKey()
+    MsgBox "INI File: " & Application.CurrentProject.Path & "\MyIniFile.ini" & vbCrLf & _
+           "Section: SETTINGS" & vbCrLf & _
+           "Section Exist: " & bSectionExists & vbCrLf & _
+           "Key: License" & vbCrLf & _
+           "Key Exist: " & bKeyExists & vbCrLf & _
+           "Key Value: " & Ini_ReadKeyVal(Application.CurrentProject.Path & "\MyIniFile.ini", "SETTINGS", "License")
+    'You can validate the value by checking the bSectionExists and bKeyExists variable to ensure they were actually found in the ini file
+End Sub
+ 
+
+