Question

Module SR_Html
    Dim isAttachment As Boolean
    Dim mailBox As Object
    Dim olFolder As Object
    Dim destFolder As Object
    Dim olFolder1 As Object
    Dim fsSaveFolder, sSavePathFS, ssender As String
    Dim objNamespace As Object
    'Dim Msg As Object
    Dim sysDate As Date
    Dim colItems As Object
    Dim colFilteredItems As Object
    Dim intMsgCount As Integer
    Dim objMsg1 As Object
    Dim Msg1 As Object
    Dim intSize As Object

Private Property objOutlook As Object

    Sub Main()

        fsSaveFolder = "C:\Users\naveen.chavali\temp\"

        isAttachment = False

        objOutlook = CreateObject("Outlook.Application")
        objNamespace = objOutlook.GetNamespace("MAPI")
        mailBox = objNamespace.Folders("naveen.chavali@deutschfamily.com")
        olFolder = mailBox.Folders("Inbox")

        destFolder = olFolder.Folders("SRT2 Reports")

        colItems = olFolder.Items
        colFilteredItems = colItems.Restrict("[Unread] =  True")

        If olFolder Is Nothing Then Exit Sub

        sysDate = Date.Today()

        For Each msg In colItems
            If (msg.Subject = "SRT2 Reports HTML" Or msg.Subject = "SRT2 Reports TXT") And msg.Unread = True And (DatePart("yyyy", msg.ReceivedTime) = DatePart("yyyy", sysDate) And DatePart("m", msg.ReceivedTime) = DatePart("m", sysDate) And DatePart("d", msg.ReceivedTime) = DatePart("d", sysDate)) Then
                intSize = intSize + 1
            End If
        Next

        For Each Msg In colItems
            If (Msg.Subject = "SRT2 Reports HTML" Or Msg.Subject = "SRT2 Reports TXT") And Msg.Unread = True And (DatePart("yyyy", Msg.ReceivedTime) = DatePart("yyyy", sysDate) And DatePart("m", Msg.ReceivedTime) = DatePart("m", sysDate) And DatePart("d", Msg.ReceivedTime) = DatePart("d", sysDate)) Then
                intMsgCount = Msg.Attachments.Count
                If intMsgCount > 0 Then
                    For mt As Integer = 1 To intMsgCount
                        'MsgBox("move attachment")
                        sSavePathFS = fsSaveFolder & Msg.Attachments(mt).FileName
                        Msg.Attachments(mt).SaveAsFile(sSavePathFS)
                    Next mt
                    Msg.Unread = False
                End If
            End If
        Next

        For Each msg In colItems
            If (msg.Subject = "SRT2 Reports HTML" Or msg.Subject = "SRT2 Reports TXT") And (DatePart("yyyy", msg.ReceivedTime) = DatePart("yyyy", sysDate) And DatePart("m", msg.ReceivedTime) = DatePart("m", sysDate) And DatePart("d", msg.ReceivedTime) = DatePart("d", sysDate)) Then
                msg.move(destFolder)
                ' msg.Unread = True
            End If
        Next

    End Sub

End Module

fsSaveFolder = "C:\Users\naveen.chavali\temp\"是此时保存附件的位置。我希望用户输入此路径，脚本应该执行并将附件保存到用户指定的文件夹。

Answer 1

您可以使用InputBox或BrowseForFolder功能。

  Dim oShell As Object
  Set oShell = CreateObject("Shell.Application")
  Dim save_to_folder  As Object
  Set save_to_folder  = _
  oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
  If save_to_folder  Is Nothing Then Exit Sub
 ' Note:  BrowseForFolder doesn't add a trailing slash

允许用户在执行VB脚本时输入保存文件夹路径。该脚本将outlook的附件保存到特定的文件夹路径

1 个答案: