Question

我有一个提取电子邮件文本的vba脚本。我可以选择特定的电子邮件没有问题，并调试打印到文件。我无法弄清楚如何在同一个脚本中提取或修剪我需要的确切行：

Public Function GetEmailString()
Dim olApp As Outlook.Application
Dim olNamespace As Outlook.Namespace
Dim olFolder  As Outlook.MAPIFolder
Dim olItem As Outlook.Items
Dim olMail As Variant
Dim i As Long
Dim s As String
Dim n As Integer

n = FreeFile()

Set olApp = New Outlook.Application
Set olNamespace = olApp.GetNamespace("MAPI")
Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox).Folders("Test")
Set olItem = olFolder.Items

olItem.Sort “Subject”

i = 1

For Each olMail In olItem
    If InStr(olMail.Subject, "UPS Report Available") > 0 Then
    Open "D:\test.txt" For Output As #n
        s = olMail.body
        Debug.Print s ' write to immediate
        Print #n, s ' write to file
        Close #n
        i = i + 1
    End If
Next olMail
End Function

The contents of the email are this:

At the request of whoever of Test Company, this notification provides access to reports regarding shipper shipment information. The reports are available for download by accessing the link provided below.

Do not reply to this e-mail. Shipper Company and Whoever of Test Company will not receive your reply.

Message from Whoever of Test Company:
Daily Quantum View Report for 1V0650

Reports Available for Download:
https://www.ups.com/email-qvm/downloadCVRpt?id=Ym)Wm4K1t4EyTVWj3Bcm3BZNlhj2Io(86B3YZ0rzJQ6dxEL4O6S(BTNtF08IcdWvoPiJ9JGgw7(SrxzFI6(4yItUToowZLPI)rkb2o7HRxtHUFPz6GMiNnjsI6G)j(iKEWkTDKnH7YnwNeBEDUAPw__&loc=en_US

This e-mail was automatically generated by Shipper Company e-mail services at the request of Whoever of Test Company. Shipping Company and Whoever of Test Company will not receive any reply to this email. Please contact Whoever of Test Company directly if you have questions regarding the referenced shipment or wish to discontinue this notification service.

我能够将它打印到文本文件中，我需要将其剪裁成的内容是：

https://www.ups.com/email-qvm/downloadCVRpt?id=Ym)Wm4K1t4EyTVWj3Bcm3BZNlhj2Io(86B3YZ0rzJQ6dxEL4O6S(BTNtF08IcdWvoPiJ9JGgw7(SrxzFI6(4yItUToowZLPI)rkb2o7HRxtHUFPz6GMiNnjsI6G)j(iKEWkTDKnH7YnwNeBEDUAPw__&loc=en_US

有没有人有任何想法？我最终尝试在文本文件中获取该字符串，以便稍后读取它并使用xttp将此链接自动生成的csv文件下载到访问数据库表中。

Answer 1

我想出了一个简单的方法来返回我需要的东西。然后我将把它写入另一个文件，并将其读取到数据库中读取：

Public Function ReadFiles()
Dim fso As New Scripting.FileSystemObject
Dim fsoFolder As Scripting.Folder
Dim fsoFile As File
Dim FileText As TextStream
Dim TextLine As String
Dim key As String ' Part before ":"

Dim strPath As String
Dim strFile As String
Dim strPandF As String
Dim strLine As String

strPath = "D:\"
strFile = "Test.txt"
strPandF = "D:\Test.txt"

Set fso = CreateObject("Scripting.FileSystemObject") 'New FileSystemObject
Set fsoFolder = fso.GetFolder(strPath)
Set fsoFile = fso.GetFile(strPandF)
Set FileText = fsoFile.OpenAsTextStream(ForReading)
Do While Not FileText.AtEndOfStream
TextLine = FileText.ReadLine 'read line
key = "https://www.ups.com/email-qvm"
If Left(TextLine, 29) = key Then

MsgBox TextLine
End If
Loop

FileText.Close

End Function

从电子邮件中提取URL字符串以消除所有其他文本

1 个答案: