Copy a URL from a specific subject mail email body into excel worksheet
I want to copy the URL/Hyperlink from an outlook email which is received daily and consists of a 2 URL/hyperlinks and I want the second URL that starts with certain text like: http://mytkportal.si/sff/kp/sfsd=21133, the part highlighted in bold is same everyday but the last number keeps changing, So I want the macro to pull that link and paste into excel worksheet cell. I have got the below code which gets the entire email body but i need only the URL/hyperlink as mentioned above.
Code:
Sub CopyEmailtoExcel()
Dim olApp As Outlook.Application
Dim olNs As Namespace
Dim Fldr As MAPIFolder
Dim olMi As Variant
Dim i As Integer
Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set Fldr = olNs.GetDefaultFolder(olFolderInbox).Folders("Test")
Set Fldr = Fldr.Folders("MyFolder")
Set inboxItems = Fldr.Items
pnldate = Format((Date - 1), "mm/dd/yyyy")
Set inboxItems = Fldr.Items
inboxItems.Sort "[ReceivedTime]", True
For i = 1 To Fldr.Items.Count Step 1
Set olMi = Fldr.Items(i)
If Format(olMi.ReceivedTime, "mm/dd/yyyy") = pnldate Then
Debug.Print olMi.ReceivedTime
Debug.Print olMi.Subject
If InStr(1, olMi.Subject, "Breakdown") > 0 Then
Sheets("Sheet1").Range("A1") = olMi.Body
GoTo AllDone
End If
End If
Next i
AllDone:
End Sub
Re: Copy a URL from a specific subject mail email body into excel worksheet
try like
Code:
mylink = "http://mytkportal.si/sff/kp/sfsd="
pos = instr(olMi.Body, mylink)
if pos > 0 then
Sheets("Sheet1").Range("A1") = mid(olMi.body, pos, len(mylink)+5)
end if
if the length of the numeric can change from 5 digits you would have to find the end position, using instr again to find the end of the link
Re: Copy a URL from a specific subject mail email body into excel worksheet
ok. It seems to be working but I get the outlook warning message .i.e. "A program is trying to access email information stored in outlook. If this is unexpected, click deny and verify your antivirus software is uptodate. for more information about e-mail safety and how you might be able to avoid getting this warning, click help. " It shows a dropdown below the msg .i.e. Allow access for : the dropdown consists of values like 1 minute, 2 minutes, 5 minutes, 10 minutes. and then 3 buttons .i.e. Allow, Deny and Help. I have done some google search and found that I have to check few box .i.e. "Never warn me about suspicious activity (not recommended)" under programmatic access in Trust Center Settings in outlook but that is all disabled by my company IT and I know that they won't allow any exception for macros. So what's the work around, I checked the send keys as well but since the outlook warning message box appears 3 to 4 times, even that is not the option. is there any other way we can do it. Also I am not sure why this warning msg appears only for the above code and not for the below email attachment download code which i use since even in the below i am trying to download the attachments from outlook.
Code:
Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Dim iRow as Integer
Dim mydate As Date
mydate = ThisWorkbook.Sheets("Email Download").Range("E2").Value
Dim nxtday As Date
nxtday = mydate + 1
Set olApp = OutlookApp("outlook.application")
Set olNS = olApp.GetNameSpace("MAPI")
'
Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(ThisWorkbook.Sheets("Email Download").Range("E2").Value)
Set xlSheet = ActiveWorkbook.Sheets("Email Download")
strPath = "C:\HP" & xlSheet.Range("C1").value & ""
If olShareInbox.Items.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'").Count = 0 Then
MsgBox ("No mails for")
Else
CreateFolders strPath 'ensure the save path is present
lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
For Each olItem In olShareInbox.Items.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'")
For iRow = 1 To lRow 'declare the variable iRow as integer
If InStr(1, olItem.Subject, xlSheet.Range("B" & iRow).value & "*") > 0 Then
If olItem.attachments.Count > 0 Then
For Each olAttach In olItem.attachments
strName = olAttach.FileName
olAttach.SaveAsFile strPath & strName
olItem.UnRead = False
Next olAttach
End If
Exit For 'subject found so stop looking
End If
Next iRow
Next olItem
End If
End Sub
Re: Copy a URL from a specific subject mail email body into excel worksheet
ok. It seems to be working but I get the outlook warning message .i.e. "A program is trying to access email information stored in outlook. If this is unexpected, click deny and verify your antivirus software is uptodate. for more information about e-mail safety and how you might be able to avoid getting this warning, click help. " It shows a dropdown below the msg .i.e. Allow access for : the dropdown consists of values like 1 minute, 2 minutes, 5 minutes, 10 minutes. and then 3 buttons .i.e. Allow, Deny and Help. I have done some google search and found that I have to check few box .i.e. "Never warn me about suspicious activity (not recommended)" under programmatic access in Trust Center Settings in outlook but that is all disabled by my company IT and I know that they won't allow any exception for macros. So what's the work around, I checked the send keys as well but since the outlook warning message box appears 3 to 4 times, even that is not the option. is there any other way we can do it. Also I am not sure why this warning msg appears only for the above code and not for the below email attachment download code which i use since even in the below i am trying to download the attachments from outlook.
Code:
Sub Downloademailattachementsfromexcellist()
Dim olApp As Object
Dim olNS As Object
Dim olItem As Object
Dim olRecip As Object
Dim olShareInbox As Object
Dim lRow As Integer
Dim olAttach As Object
Dim strPath As String
Dim strName As String
Dim xlSheet As Worksheet
Dim iRow as Integer
Dim mydate As Date
mydate = ThisWorkbook.Sheets("Email Download").Range("E2").Value
Dim nxtday As Date
nxtday = mydate + 1
Set olApp = OutlookApp("outlook.application")
Set olNS = olApp.GetNameSpace("MAPI")
'
Set olShareInbox = olNS.GetDefaultFolder(olFolderInbox).Folders(ThisWorkbook.Sheets("Email Download").Range("E2").Value)
Set xlSheet = ActiveWorkbook.Sheets("Email Download")
strPath = "C:\HP" & xlSheet.Range("C1").value & ""
If olShareInbox.Items.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'").Count = 0 Then
MsgBox ("No mails for")
Else
CreateFolders strPath 'ensure the save path is present
lRow = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
For Each olItem In olShareInbox.Items.Restrict("[receivedtime] > '" & mydate & "' and [receivedtime] < '" & nxtday & "'")
For iRow = 1 To lRow 'declare the variable iRow as integer
If InStr(1, olItem.Subject, xlSheet.Range("B" & iRow).value & "*") > 0 Then
If olItem.attachments.Count > 0 Then
For Each olAttach In olItem.attachments
strName = olAttach.FileName
olAttach.SaveAsFile strPath & strName
olItem.UnRead = False
Next olAttach
End If
Exit For 'subject found so stop looking
End If
Next iRow
Next olItem
End If
End Sub
Re: Copy a URL from a specific subject mail email body into excel worksheet
it would appear your company does not want you to do this and it would be wrong for anyone here to help you by-pass their security
as you are getting paid to do it the slow way why should you care?
anyway this response seems to have more relevance to you other thread
Re: Copy a URL from a specific subject mail email body into excel worksheet
Quote:
Originally Posted by
westconn1
it would appear your company does not want you to do this and it would be wrong for anyone here to help you by-pass their security
as you are getting paid to do it the slow way why should you care?
anyway this response seems to have more relevance to you other thread
I partially agree with your comment since company don't want us to send some data through emails automatically since there could be a scenario where incorrect info gets delivered to someone and hence they apply such restriction but in my case I am simply fetching a link from an email which we receive daily...I am not sending any info through automated mail to anyone...even if I am automating something I know the company policy and how to remain compliant to it. So would ask you to advise on how to fix the issue.
Re: Copy a URL from a specific subject mail email body into excel worksheet
my rule here is never click any link in any email from anyone
Re: Copy a URL from a specific subject mail email body into excel worksheet
Quote:
Originally Posted by
westconn1
my rule here is never click any link in any email from anyone
Ok. But it's an internal email and I get it daily for some reporting...and manually downloading it takes some time...so I am trying to automate...please help me...
Re: Copy a URL from a specific subject mail email body into excel worksheet
you could try running the code from within outlook vba, see if the same problem occurs, just automate excel instead
