Last active
January 5, 2018 16:07
-
-
Save ship9599/6e802faa0ebf7488fbe2923937b86896 to your computer and use it in GitHub Desktop.
Outlook Function Snippets (VBA)
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ CleanFileName(strText As String) As String ********** | |
Function CleanFileName(strText As String) As String | |
Dim strStripChars As String | |
Dim intLen As Integer | |
Dim i As Integer | |
strStripChars = "/\[]:=," & Chr(34) | |
intLen = Len(strStripChars) | |
strText = Trim(strText) | |
For i = 1 To intLen | |
strText = Replace(strText, Mid(strStripChars, i, 1), "") | |
Next | |
CleanFileName = strText | |
End Function | |
'Ex: | |
' ### Get Email subject & set name to be saved as ### | |
'EmailSubject = CleanFileName(Item.Subject) | |
'SaveName = FileName '& ".mht" | |
'Set fso = CreateObject("Scripting.FileSystemObject") | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ GetBoiler() ********** | |
Function GetBoiler(ByVal sFile As String) As String | |
'Dick Kusleika | |
Dim fso As Object | |
Dim ts As Object | |
Set fso = CreateObject("Scripting.FileSystemObject") | |
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2) | |
GetBoiler = ts.readall | |
ts.Close | |
End Function | |
'Example: | |
'Change only Mysig.htm to the name of your signature | |
' sigstring = Environ("appdata") & _ | |
' "\Microsoft\Signatures\Work.htm" | |
' If Dir(sigstring) <> "" Then | |
' signature = GetBoiler(sigstring) | |
' Else | |
' signature = "" | |
' End If | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ GetCurrentItem() ********** | |
Function GetCurrentItem() As Object | |
Dim objApp As Outlook.Application | |
Set objApp = CreateObject("Outlook.Application") | |
On Error Resume Next | |
Select Case TypeName(objApp.ActiveWindow) | |
Case "Explorer" | |
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1) | |
Case "Inspector" | |
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem | |
Case Else | |
' anything else will result in an error, which is | |
' why we have the error handler above | |
End Select | |
Set objApp = Nothing | |
End Function | |
'Example | |
'Call by using: Set Item = GetCurrentItem() | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ GetFolder() ********** | |
Function GetFolder(ByVal FolderPath As String) As Outlook.Folder | |
Dim TestFolder As Outlook.Folder | |
Dim FoldersArray As Variant | |
Dim i As Integer | |
On Error GoTo GetFolder_Error | |
If Left(FolderPath, 2) = "\\" Then | |
FolderPath = Right(FolderPath, Len(FolderPath) - 2) | |
End If | |
'Convert folderpath to array | |
FoldersArray = Split(FolderPath, "\") | |
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0)) | |
If Not TestFolder Is Nothing Then | |
For i = 1 To UBound(FoldersArray, 1) | |
Dim SubFolders As Outlook.Folders | |
Set SubFolders = TestFolder.Folders | |
Set TestFolder = SubFolders.Item(FoldersArray(i)) | |
If TestFolder Is Nothing Then | |
Set GetFolder = Nothing | |
End If | |
Next | |
End If | |
'Return the TestFolder | |
Set GetFolder = TestFolder | |
Exit Function | |
GetFolder_Error: | |
Set GetFolder = Nothing | |
Exit Function | |
End Function | |
'Example: | |
' Sub TestGetFolder() | |
' Dim Folder As Outlook.Folder | |
' Set Folder = GetFolder("Research") 'NameSpace.Folders.Item("") | |
' If Not (Folder Is Nothing) Then | |
' Folder.Display | |
' End If | |
' Debug.Print Folder.Name | |
' End Sub | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ GetFolderPath() ********** | |
Function GetFolderPath(ByVal FolderPath As String) As Outlook.Folder | |
Dim oFolder As Outlook.Folder | |
Dim FoldersArray As Variant | |
Dim i As Integer | |
On Error GoTo GetFolderPath_Error | |
If Left(FolderPath, 2) = "\\" Then | |
FolderPath = Right(FolderPath, Len(FolderPath) - 2) | |
End If | |
'Convert folderpath to array | |
FoldersArray = Split(FolderPath, "\") | |
Set oFolder = Application.Session.Folders.Item(FoldersArray(0)) | |
If Not oFolder Is Nothing Then | |
For i = 1 To UBound(FoldersArray, 1) | |
Dim SubFolders As Outlook.Folders | |
Set SubFolders = oFolder.Folders | |
Set oFolder = SubFolders.Item(FoldersArray(i)) | |
If oFolder Is Nothing Then | |
Set GetFolderPath = Nothing | |
End If | |
Next | |
End If | |
'Return the oFolder | |
Set GetFolderPath = oFolder | |
Exit Function | |
GetFolderPath_Error: | |
Set GetFolderPath = Nothing | |
Exit Function | |
End Function |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ GetPublicFolder() ********** | |
Public Function GetPublicFolder(strFolderPath) | |
Dim colFolders | |
Dim objFolder | |
Dim arrFolders | |
Dim i | |
On Error Resume Next | |
strFolderPath = Replace(strFolderPath, "/", "\") | |
arrFolders = Split(strFolderPath, "\") | |
Set objFolder = Application.Session.GetDefaultFolder(18) | |
Set objFolder = objFolder.Folders.Item(arrFolders(0)) | |
If Not objFolder Is Nothing Then | |
For i = 1 To UBound(arrFolders) | |
Set colFolders = objFolder.Folders | |
Set objFolder = Nothing | |
Set objFolder = colFolders.Item(arrFolders(i)) | |
If objFolder Is Nothing Then | |
Exit For | |
End If | |
Next | |
End If | |
Set GetPublicFolder = objFolder | |
Set colFolders = Nothing | |
Set objApp = Nothing | |
Set objFolder = Nothing | |
End Function | |
' Ex: | |
' GetFolder - Gets a Public folder based on a string path - e.g. | |
'If Folder name in English is | |
'Public Folders\All Public Folders\Europeen Workflow | |
'The just pass in "Europeen Workflow' | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ RemoveFirstChar() ********** | |
Public Function RemoveFirstChar(RemFstChar As String) As String | |
Dim TempString As String | |
TempString = RemFstChar | |
If Left(RemFstChar, 9) = "[GFISPAM]" Then | |
If Len(RemFstChar) > 9 Then | |
TempString = Right(RemFstChar, Len(RemFstChar) - 9) | |
End If | |
End If | |
RemoveFirstChar = TempString | |
End Function | |
' Ex: | |
' tmpFileName = "Z:" | |
' sName = item.Subject | |
' RemoveFirstChar RemFstChar, "_" | |
' tmpFileName = tmpFileName & "\" & sName & ".mht" | |
' This function removes invalid and other characters from file names | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ Replace_Delimiter_Char() ********** | |
Function Replace_Delimiter_Char(SName As String, sChr As String) | |
' sName = Replace(sName, "/", sChr) | |
' sName = Replace(sName, "\", sChr) | |
SName = Replace(SName, ":", sChr) | |
SName = Replace(SName, "?", sChr) | |
SName = Replace(SName, Chr(34), sChr) | |
SName = Replace(SName, "<", sChr) | |
SName = Replace(SName, ">", sChr) | |
SName = Replace(SName, "|", sChr) | |
SName = Replace(SName, "&", sChr) | |
SName = Replace(SName, "%", sChr) | |
SName = Replace(SName, "*", sChr) | |
SName = Replace(SName, "{", sChr) | |
SName = Replace(SName, "[", sChr) | |
SName = Replace(SName, "]", sChr) | |
SName = Replace(SName, "}", sChr) | |
SName = Replace(SName, "!", sChr) | |
End Function | |
'Example: | |
' tmpFileName = "Z:" | |
' sName = item.Subject | |
' Replace_Delimiter_Char sName, "_" | |
' tmpFileName = tmpFileName & "\" & sName & ".mht" | |
' This function removes invalid and other characters from file names | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ Replace_FName_Char() ********** | |
Function Replace_FName_Char(SName As String, sChr As String) | |
SName = Replace(SName, "/", sChr) | |
SName = Replace(SName, "\", sChr) | |
SName = Replace(SName, ":", sChr) | |
SName = Replace(SName, "?", sChr) | |
SName = Replace(SName, Chr(34), sChr) | |
SName = Replace(SName, "<", sChr) | |
SName = Replace(SName, ">", sChr) | |
SName = Replace(SName, "|", sChr) | |
SName = Replace(SName, "&", sChr) | |
SName = Replace(SName, "%", sChr) | |
SName = Replace(SName, "*", sChr) | |
SName = Replace(SName, " ", sChr) | |
SName = Replace(SName, "{", sChr) | |
SName = Replace(SName, "[", sChr) | |
SName = Replace(SName, "]", sChr) | |
SName = Replace(SName, "}", sChr) | |
SName = Replace(SName, "!", sChr) | |
End Function | |
'Example: | |
' tmpFileName = "Z:" | |
' sName = item.Subject | |
' Replace_FName_Char sName, "_" | |
' tmpFileName = tmpFileName & "\" & sName & ".mht" | |
' This function removes invalid and other characters from file names | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ Replace_Fwd() ********** | |
Function Replace_Fwd(SName As String, sChr As String) | |
SName = Replace(SName, "FW:", sChr) | |
SName = Replace(SName, "RE:", sChr) | |
End Function | |
'Ex: | |
' tmpFileName = "Z:" | |
' sName = item.Subject | |
' Replace_Fwd sName, "_" | |
' tmpFileName = tmpFileName & "\" & sName & ".mht" | |
' This function removes invalid and other characters from file names | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
'************ Replace_FName_Char() ********** | |
Function Replace_Punctuation_Names(SName As String) | |
SName = Replace(SName, "'", "") | |
SName = Replace(SName, ". ", " ") | |
SName = Replace(SName, ".", "") | |
SName = Replace(SName, ", ", " ") | |
SName = Replace(SName, " ", "_") | |
SName = Replace(SName, "-", "_") | |
End Function | |
' tmpFileName = "Z:" | |
' sName = item.Subject | |
' Replace_Punctuation_Names sName, "_" | |
' tmpFileName = tmpFileName & "\" & sName & ".mht" | |
' This function removes invalid and other characters from file names | |
'************ Code End ********** | |
'---------------------------------------------------------------------- |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment