From 54d2c756bbb6c9c714eeb639677dca136e4876b6 Mon Sep 17 00:00:00 2001 From: Stephan Maier Date: Tue, 29 Aug 2023 13:22:23 +0200 Subject: [PATCH] Neuerstellung --- ThisOutlookSession.cls | 48 ++++++ frmSetCategories.frm | 225 ++++++++++++++++++++++++++ frmSetCategories.frx | Bin 0 -> 3608 bytes frmSettings.frm | 37 +++++ frmSettings.frx | Bin 0 -> 3096 bytes general.bas | 264 +++++++++++++++++++++++++++++++ gfSettings.bas | 23 +++ iniSettings.bas | 347 +++++++++++++++++++++++++++++++++++++++++ 8 files changed, 944 insertions(+) create mode 100644 ThisOutlookSession.cls create mode 100644 frmSetCategories.frm create mode 100644 frmSetCategories.frx create mode 100644 frmSettings.frm create mode 100644 frmSettings.frx create mode 100644 general.bas create mode 100644 gfSettings.bas create mode 100644 iniSettings.bas diff --git a/ThisOutlookSession.cls b/ThisOutlookSession.cls new file mode 100644 index 0000000..c782500 --- /dev/null +++ b/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ü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 + diff --git a/frmSetCategories.frm b/frmSetCategories.frm new file mode 100644 index 0000000..8dbad24 --- /dev/null +++ b/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 + + + + diff --git a/frmSetCategories.frx b/frmSetCategories.frx new file mode 100644 index 0000000000000000000000000000000000000000..d50386c6882118d36dde5fc74312181be5e73bbb GIT binary patch literal 3608 zcmeHJO-vI}5dO9;2!aX(0WmQ(0VPNpFnBN;LilNnN{AHV#e@BM(8YFFwp)MVPxhuK zf5L@}Mq|8q)00O}9y}ly4<;TogsXZmCLW}Iv)dwSss&F?I?cS9eQ(~(yqS6PdUB`+ z*p4;0)e2k;0ZXqN-#>iX{$Xt)&kVqi)m$yA*DYw|1zl(Wd}QQ%HJ8hIlK|NYlu-n} z(^tu#V1P-i%IC9;j!<#+KO!&zlRq0ljKUzbaJg`mOQJ2Tn1Xrf2cPxsm+x8@8}BdR z2~Hm$U$3OM{Y~A?nzx#tlY>%hglUg#dJM1&73>QwRndIDk(s4#C?ZGuny8X9m1s4C%~n0?h2G=1Q6&zO?^YX8PZTa8BLn$s8=$BGJivcF07ESd>kqFej?Bc`;r~jQ?|0)Zy9{e;01Do-F?jI zc}2TdWQVT}he%k9&SP2RoM-4$6uzSfYcC$iG;7&uB1-Mjp2OO7hRIj6sH5D|OMW<- zQNf5ZGP!z@;zo>5UWr`yGWJGr#x;m!}eJ-mG4E$YZ2g3n0bAKcoPnuT3 zP*zY`8C#`N%9v;HujbF3rQFXm`}1cOzk;p~-altlH{6|BV@An6Zex@SF)O~m8E3V< z4#na3L6bOlOVW$RS=RpC^XSMw_HcQ_(Bsw$+leD-JVOki9r5Hj$=q7v){eQZw&d^1 zB+>85d)eT(fEyBcx}{8{m5mUq(1@6AL{!v@C&Okcp{xOszdk6VSGSCeBhitm>Vmv& z>&8q53wwT*Wm|NlRZ5Nf(1ujTj;NH1+q&s?*>6K!Sm(2}R*}^_*%4(&^^}MZzDfW# z0vbE8pS3RC=l8dF7Zr`^am&n@({?ayTIo#iV5rySAkBL;9aD*fN(9Gav-H<(?ygu! T#!w%=9DX*p5pOE8*Q2mZVLxHBChkaRm># zhOnl#9=r%1BE_2rK|R{|&F(g)LhBMwl}va$v-4)&%$xVV$&L@T z0AW<=>3-lsE3ot~QhxM&->2$?FPw&kl}am`YbF%RGF)m0R0{IGQmIrtB|x!3o2UXm znX8z~ep&W>JqN$2`=?7mkhu(hdT#P)thbK5c zYSb>W^yWlcspW&BQMn+-q$!Wp{S2`S)s`UWLS23%vx7RUW5@W4EG2uAJk~K=qn53g zeT{-))<1_?7%(xt#xBUq&N}wbw$HQnNOG4RFZm1pn>eHwY$4}AhAVINd2O8=^8Zl* zgt{>jZV$_OhX&*h18tOX4H!KI+^G3x&?c9+-MzgSd9X}ukG(o8cjt~08&c4GE|Io# z3GWKM6!)77k=2dQwBdDggzy zx*KPQ#K~tfc}pKGB-5EoRw)`IKyFD9HuC56M$`|)1!p+m){5|R1cpaA6t7msO!>0< z?BJ?hk83CC2yDep#cmW$FS&%9TPeCg%)aNGoWT#KC|i>wW;hIRXxN4EglT1|5W6vV z8)59F{O!7eio6FQg&jg;FhRqgy 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 + + + + + + diff --git a/gfSettings.bas b/gfSettings.bas new file mode 100644 index 0000000..74083f8 --- /dev/null +++ b/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 + + + + diff --git a/iniSettings.bas b/iniSettings.bas new file mode 100644 index 0000000..628b5ff --- /dev/null +++ b/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 + + +