commit 54d2c756bbb6c9c714eeb639677dca136e4876b6 Author: Stephan Maier Date: Tue Aug 29 13:22:23 2023 +0200 Neuerstellung 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 0000000..d50386c Binary files /dev/null and b/frmSetCategories.frx differ diff --git a/frmSettings.frm b/frmSettings.frm new file mode 100644 index 0000000..6d654ef --- /dev/null +++ b/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 diff --git a/frmSettings.frx b/frmSettings.frx new file mode 100644 index 0000000..91fc883 Binary files /dev/null and b/frmSettings.frx differ diff --git a/general.bas b/general.bas new file mode 100644 index 0000000..36b1b23 --- /dev/null +++ b/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ä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 + + + + + + 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 + + +