Extraire une chaîne d'URL à partir d'un courrier électronique Se débarrasser de tout autre texte

Question

J'ai un script vba qui extrait le texte d'un courriel. Je suis en mesure de sélectionner l'e-mail spécifique sans problème et de déboguer l'imprimer dans un fichier. Je ne peux pas comprendre comment extraire ou réduire la voilure dans le même script exactement la ligne que j'ai besoin:

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. 

Je suis en mesure d'imprimer un texte qui à déposer le contenu que j'ai besoin coupé vers le bas pour se ceci:

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

Quelqu'un a-t-il des idées? J'essaie finalement d'obtenir cette chaîne dans un fichier texte afin que je puisse la lire plus tard et utiliser l'xttp pour télécharger le fichier csv que ce lien génère automatiquement dans une table de base de données d'accès.

Answer 1

J'ai trouvé une méthode simple pour retourner ce dont j'ai besoin. Je vais ensuite écrire ceci dans un autre fichier et ramasser cela pour être lu par une base de données:

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