Question

我使用outlook来接收我的电子邮件（不能改变这个......），我想在Windows中找到一种方法来自动处理我的一种有下载链接的电子邮件。

我想找到一种方法，用关键词有选择地从电子邮件中下载文件。

我能想到实现这个目标的程序是：

使用关键词搜索我的电子邮件
使用关键字
下载文件并将其保存在文件夹中。

我目前的代码是：

Sub Search_Inbox()

Dim olFolder As Outlook.Folder
Dim myitems As Outlook.Items

Dim bodyString As String
Dim bodyStringLines
Dim splitLine

Dim hyperlink As String
Dim i As Integer
Dim found As Integer  

Set olFolder = Application.GetNamespace("MAPI").Folders("lll@163.com").Folders("Inbox").Folders("abc")
Set myitems = olFolder.Items

i = 0
found = 0

'find the hyperlink in the emails"
For Each myitem In myitems
    If InStr(1, myitem.Body, "passed", vbTextCompare) > 0 Then            
        If InStr(1, myitem.Body, "tested", vbTextCompare) > 0 Then
        'inside the target email, search for the key word
        bodyString = myitem.Body
        bodyStringLines = Split(bodyString, vbCrLf)
        For Each splitLine In bodyStringLines
            i = i + 1
            keyStart = InStr(splitLine, "keyword")
            keyEnd = keyStart + Len("keyword") - 1
            If found = 0 Then
                If keyStart > 0 Then
                    If keyEnd = Len(splitLine) Then
                        found = 1
                    End If
                End If
            Else
                hyperlink = splitLine
                found = 0
                Exit For
            End If
        Next
        Debug.Print "hyperlink is"
        Debug.Print hyperlink           
        'DownloadFile1 (hyperlink)
        'DownloadFile2 (hyperlink)
        End If

    Else
        Found = False
    End If
Next

Set olFolder = Nothing
Set myitems = Nothing

End Sub

但我在下载部分遇到问题。访问超链接需要填写登录信息。我尝试了以下两种方法，但都失败了......

Sub DownloadFile1(myURL As String)

    Dim saveDirectoryPath As String

    '*******************************
    ' Intitial setup
    '*******************************
    saveDirectoryPath = "C:\testfile.pdf" 'where your files will be stored
    '*******************************

    Dim fileNameArray() As String
    Dim fileName As String
    Dim arrayLength As Integer
    Dim DateString As String
    DateString = Format(Now, "yyyy-mm-dd hh-mm-ss")

    fileNameArray = Split(myURL, "/")
    arrayLength = UBound(fileNameArray)
    fileName = fileNameArray(arrayLength)

    'Add date to the file incase there are duplicates comment out these lines if you do not want the date added
    fileName = Replace(fileName, ".pdf", "_" & DateString & ".pdf")
    fileName = Replace(fileName, ".PDF", "_" & DateString & ".PDF")

    Dim WinHttpReq As Object
    Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
    WinHttpReq.Open "GET", myURL, False, "username", "password"
    WinHttpReq.Send

    myURL = WinHttpReq.responseBody
    If WinHttpReq.Status = 200 Then
        Set oStream = CreateObject("ADODB.Stream")
        oStream.Open
        oStream.Type = 1
        oStream.Write WinHttpReq.responseBody
        oStream.SaveToFile saveDirectoryPath & fileName, 2 ' 1 = no overwrite, 2 = overwrite
        oStream.Close
    End If

End Sub

我失败了（访问被拒绝）：

 WinHttpReq.Send

我也尝试了以下代码。

Sub DownloadFile2(myURL As String)

Dim strCookie As String, strResponse As String, _
  strUrl As String
  Dim xobj As Object
  Dim WinHttpReq As Object
  Set xobj = New WinHttp.WinHttpRequest

  UN = "username"
  PW = "password"

  strUrl = "https://www.jedec.org/user/login"
  xobj.Open "POST", strUrl, False
  xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
  xobj.SetRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  xobj.Send "username=" & UN & "&password=" & PW & "&login=login"
  strResponse = xobj.ResponseText

  strUrl = myURL 
  xobj.Open "GET", strUrl, False

  xobj.SetRequestHeader "Connection", "keep-alive"
  xobj.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 6.1; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/33.0.1750.154 Safari/537.36"
  xobj.Send

  strCookie = xobj.GetResponseHeader("Set-Cookie")
  strResponse = xobj.ResponseBody

 If xobj.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write xobj.ResponseBody
    oStream.SaveToFile "C:\testfile.pdf", 1
    oStream.Close
End If
End Sub

2018/03/01问题（已解决）：用户定义的类型未定义，在行：

Set xobj = New WinHttp.WinHttpRequest

解决：这是一个技巧，你应该包括Microsoft WinHTTP服务的参考。

2018/03/02问题（未解决）：URL未使用已识别的协议，在以下位置： xobj.Open＆＃34; GET＆＃34;，strUrl，False

任何人对如何解决这个问题都有任何想法？

从电子邮件正文中提取信息的参考：

https://www.datanumen.com/blogs/extract-show-hyperlink-addresses-email-via-outlook-vba/

http://www.vbaexpress.com/forum/showthread.php?49021-Download-File-from-Hyperlink-in-Body-of-Emailhttp://www.vbaexpress.com/forum/showthread.php?49021-Download-File-from-Hyperlink-in-Body-of-Email

从超链接下载文件的参考，需要登录信息。：

How to download a PDF that is in a hyperlink using VB in Outlook 2016

Vba download file from internet WinHttpReq with login not working

如何通过VBA

任何人对如何解决这个问题都有任何想法？

0 个答案: