vbscript Outlook功能代码段（VBA）

Posted 2021-05-21

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------

'************ 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 **********
'----------------------------------------------------------------------