从电子邮件中提取URL字符串 摆脱所有其他文本

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