Right now I have code which opens e-mail if ID given in user-form(TextBox1INC) is found in Column1, but let's say I have two e-mails or whatever the number is and I want to open all of them and not only one. How Do I put loop inside this code to make this work ?
Private Sub CommandButton8showemail_Click()
Dim wsArch As Worksheet
Dim lastrow, a As Long
Dim strEmail, strEmailLoc As String
Dim OutMejlik As Outlook.Application
Dim msg As Outlook.MailItem
Set wsArch = ThisWorkbook.Sheets("Emails_arch")
lastrow = Sheets("Emails_arch").Range("A" & Rows.Count).End(xlUp).Row
With wsArch
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Set OutMejlik = CreateObject("Outlook.Application")
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
Exit Sub
End If
Next a
End With
End Sub
Currently in the loop you are exiting as soon as the first item is displayed to a user:
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Set OutMejlik = CreateObject("Outlook.Application")
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
Exit Sub
End If
Next a
End With
If you remove the Exit Sub part the code will continue running and opening items as you need. But also I'd recommend creating a new Outlook Application outside of the loop to avoid creation each time (even if Outlook is a singleton and only one instance can be created).
Set OutMejlik = CreateObject("Outlook.Application")
With wsArch
For a = lastrow To 2 Step -1
If .Cells(a, 1).Value = TextBox1INC.Text Then
strEmailLoc = .Cells(a, 2).Value
Dim msg As Outlook.MailItem
Set msg = OutMejlik.Session.OpenSharedItem(strEmailLoc)
msg.Display
End If
Next a
End With
Related
I have code that loops through all Outlook emails under a subfolder and extracts the body of the email based on the subject. Code takes a lot of time to loop through all emails as there are thousands of them.
How do I modify the code to append data, extracted from the latest emails, to the existing file instead of looping through all the emails and overwriting again & again?
Let's say I want to run the code every day to get the prior day's email data.
Option Explicit
Sub FinalMacro()
Application.DisplayAlerts = False
Dim iCounter As Integer
'iCounter = 1
Dim wkb As Workbook
Set wkb = ThisWorkbook
Sheets("Sheet1").Cells.Clear
' point to the desired email
Const strMail As String = "emailaddress#outlook.com"
Dim oApp As Outlook.Application
Dim oMapi As Outlook.MAPIFolder
'Dim oMail As Outlook.MailItem
Dim x As Long, y As Long
Dim destCell As Range
Dim i As Long
Dim oItem As Object
With ActiveSheet
Set destCell = .Cells(Rows.Count, "A").End(xlUp)
End With
On Error Resume Next
Set oApp = GetObject(, "OUTLOOK.APPLICATION")
If (oApp Is Nothing) Then Set oApp = CreateObject("OUTLOOK.APPLICATION")
On Error GoTo 0
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox").Folders("Other mails")
For Each oItem In oMapi.Items
If oItem.Subject = "Volume data" Then
' get html table from email object
Dim HTMLdoc As MSHTML.HTMLDocument
Dim tables As MSHTML.IHTMLElementCollection
Dim table As MSHTML.HTMLTable
Set HTMLdoc = New MSHTML.HTMLDocument
With HTMLdoc
.Body.innerHTML = oItem.HTMLBody
Set tables = .getElementsByTagName("table")
End With
Dim t As Long, r As Long, c As Long
Dim eRow As Long
For t = 0 To tables.Length - 1
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
For r = 0 To (tables(t).Rows.Length - 1)
For c = 0 To (tables(t).Rows(r).Cells.Length - 1)
Range("A" & eRow).Offset(r, c).Value = tables(t).Rows(r).Cells(c).innerText
Next c
Next r
eRow = Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Row
Next t
Cells(eRow, 1) = "Date & Time of Receipt:" & " " & oItem.ReceivedTime
Cells(eRow, 1).Interior.Color = vbRed
Cells(eRow, 1).Font.Color = vbWhite
Cells(eRow, 1).Columns.AutoFit
Set oApp = Nothing
Set oMapi = Nothing
Set HTMLdoc = Nothing
Set tables = Nothing
wkb.Save '"C:\Users\Desktop\Trial_1.xlsm"
End If
Next oItem
Application.DisplayAlerts = True
End Sub
To quickly select (filter) latest emails, you can use Items.Restrict.
To use your workbook for the accumulative storage of information, you just need not to erase the sheet, but to find the last filled line and add the content from the letters after it.
Smth like (not tested):
Set oMapi = oApp.GetNamespace("MAPI").Folders(strMail).Folders("inbox").Folders("Other mails")
Set wkb = ThisWorkbook
Set append_ws = wkb.Sheets("Sheet1") ' this worksheet is for appending
'Sheets("Sheet1").Cells.Clear ' - remove this statement
' set filter to: non-flagged mailitems received < 1 day ago
flt = "[FlagStatus] <> 1 And [MessageClass]='IPM.Note' And [ReceivedTime]>='" & _
Format(Now - 1, "ddddd 0:00") & "'"
Set Restricted = oMapi.Items.Restrict(flt)
For I = Restricted.Count To 1 Step -1
Set oItem = Restricted(I)
If oItem.Subject = "Volume data" Then
content_from_email = "smth from letter" ' get the content from the letter
lastrow = append_ws.Cells(append_ws.Rows.Count, 1).End(xlUp).row + 1
append_ws.Cells(lastrow, 1).Value = content_from_email
oItem.MarkAsTask olMarkComplete ' set flag to the processed items
oItem.Save
End If
Next I
I am trying to display all emails created with a loop, one at a time.
In the code below but I want to add an option to either send the emails automatically, or see them displayed and then send them manually.
While it opens the email item and displays it, when it loops it closes the previous one and opens a new one. I would like to open one and then another one as the loop goes.
Sub Test()
Dim i As Integer
Dim wB As Workbook: Set wB = ThisWorkbook
Dim wsD As Worksheet: Set wsD = wB.Worksheets("Data")
Dim wsE As Worksheet: Set wsE = wB.Worksheets("Email Format")
Dim LastRowsData As Integer
Dim LastRowEmail As Integer
Dim OA As Outlook.Application: Set OA = New Outlook.Application
Dim msg As Outlook.MailItem: Set msg = OA.CreateItem(olMailItem)
Dim Recipient As String
Recipient = Worksheets("Email Format").Range("A2")
LastRowsData = Worksheets("Data").Cells(Rows.Count, 1).End(xlUp).Row + 1
LastRowEmail = Worksheets("Email Format").Cells(Rows.Count, 1).End(xlUp).Row
For i = 2 To LastRowsData
If Not IsError(Application.Match(wsD.Range("H" & i).Value, _
wsD.Range("A1:A" & LastRowsData), 0)) Then
LastRowEmail = LastRowEmail + 1
wsE.Range("A" & LastRowEmail).Value = wsD.Range("G" & i).Value
End If
Next i
For i = 2 To LastRowEmail
With msg
.BodyFormat = olFormatHTML
.HTMLBody = wsE.Range("D" & i).Value
.To = wsE.Range("A" & i).Value
.Subject = wsE.Range("C" & i).Value
.Display
End With
Next i
End Sub
Bring Set msg = OA.CreateItem(olMailItem) into your second FOR loop. Then have a msgbox at the end to ask the user if they want to send the msg. If they do, send the msg. If they dont, display a second msg where the user has to click on continue before creating a new item – Zac yesterday
I am doing IE automation using VBA (Basically I open IE and goto the specific URL from the sheet and then login using credentials from the sheet and then extract data from the webpage to excel) This has to happen for 20 websites so I added for loop and it works fine.
What I want is, in case of any error occurs with in the loop then loop has to restart.
I also tried "on error got 0, on error got -1" but it did not work.
Below is my Code - Kindly pardon me for poor coding I am new to VBA.
Sub Get_Data()
Sheets("Sheet2").Select
Range("E2").Select
Range("H6:H120").ClearContents
Dim IE As Object
Set IE = CreateObject("InternetExplorer.application")
IE.Visible = True
Dim E As Long
Dim S As Long
E = Range("A" & Rows.Count).End(xlUp).Row
JumpToHere:
For j = S To E
S = Range("H" & Rows.Count).End(xlUp).Row
Sheets("Sheet2").Select
Range("E" & S).Select
ActiveCell.Offset(1, -2).Select
Dim X As Variant
X = ActiveCell.Value
IE.navigate X
Do
If IE.ReadyState = 4 Then
IE.Visible = True
Exit Do
Else
DoEvents
End If
Loop
ActiveCell.Offset(0, 1).Select
Dim Y As Variant
Y = ActiveCell.Value
IE.document.all("username").Value = Y
ActiveCell.Offset(0, 1).Select
Dim Z As Variant
Z = ActiveCell.Value
IE.document.all("password").Value = Z
IE.document.all("merchant_login_submit_button").Click
Application.Wait (Now + TimeValue("0:00:8"))
Set ElementCol = IE.document.getElementsByTagName("span")
For Each link In ElementCol
If link.innerHTML = "Authentication Failed" Then
ActiveCell.Offset(0, 3).Value = "Authentication Failed"
GoTo JumpToHere
End If
Next
Set tags = IE.document.getElementsByTagName("input")
For Each tagx In tags
If tagx.Value = "Continue to Control Panel" Then
tagx.Click
Application.Wait (Now + TimeValue("0:00:3"))
Exit For
End If
Next
Set ElementCol = IE.document.getElementsByTagName("a")
For Each link In ElementCol
If link.innerHTML = "Reports" Then
link.Click
End If
Next
Application.Wait (Now + TimeValue("0:00:06"))
Dim checkdate As Integer
checkdate = Format(Date, "dd") - 1
IE.document.getElementById("snapshot_group_by").Value = "payment_processor"
IE.document.getElementById("snapshot_end_date_day").Value = checkdate
IE.document.all("reports_submit_button").Click
Application.Wait (Now + TimeValue("0:00:3"))
Dim ws As Worksheet
Dim rng As Range
Dim tbl As Object
Dim rw As Object
Dim cl As Object
Dim tabno As Long
Dim nextrow As Long
Dim I As Long
Set ws = Worksheets.Add
For Each tbl In IE.document.getElementsByTagName("TABLE")
tabno = tabno + 1
nextrow = nextrow + 1
Set rng = ws.Range("B" & nextrow)
rng.Offset(, -1) = "Table " & tabno
For Each rw In tbl.Rows
For Each cl In rw.Cells
rng.Value = cl.outerText
Set rng = rng.Offset(, 1)
I = I + 1
Next cl
nextrow = 0
Set rng = rng.Offset(1, -I)
I = 0
Next rw
Next tbl
ws.Cells.ClearFormats
Sheets("Sheet2").Select
ActiveCell.Offset(0, 3).Value = ActiveSheet.Previous.Range("F4")
Application.DisplayAlerts = False
ActiveSheet.Previous.Delete
Application.DisplayAlerts = True
Set ElementCol = IE.document.getElementsByTagName("a")
For Each link In ElementCol
If link.innerHTML = "Logout" Then
link.Click
End If
Next
Next j
End Sub
Sounds like your real problem is that your code isn't properly waiting. Instead of Application.Wait, use a proper waiting loop any time you invoke the IE.Navigate or any element .Click or form .Submit event.
VBA HTML not running on all computers
Otherwise, you don't have any active error-trapping in your code. Wrap your loop with On Error statements, as below.
The first one, On Error GoTo MyErrorHandler instructs the program of what to do if an error is encountered within the loop. If there's an error, the code underneath the MyErrorHandler label will execute, and resume at the NextJ label. Once the loop finishes, On Error GoTo 0 returns normal (i.e., none) error-handling. Any errors occurring outside the loop still raise an exception during runtime.
Option Explicit
Sub Get_Data()
'// Dim your variables
'// Executable code starts here
JumpToHere:
For j = S To E
On Error GoTo MyErrorHandler
' Now ANY ERROR, ANYWHERE in the loop will go to the error handler
NextJ:
Next j
'// Code below this line won't be subject to the error handler
On Error GoTo 0
'// more code if you have it
' Exit gracefully if there was no error:
Exit Sub
'// Here is the error handler:
MyErrorHandler:
Err.Clear()
Resume NextJ
End Sub
If you truly want to re-start the loop, then instead of NextJ, do Resume JumpToHere.
I have a macro that reads the unread messages in my inbox and extracts the data from the message with a delimiter of ":" . In the loop I want to be able to load the new excel spreadsheet with the values from the message.
I am able to select the first cell and save the data but it is getting over written. each time in the loop I want the data to go to the next cell in the column that is empty instead of overwriting the same cell.
Here is my code so far...
Public Sub Application_NewMail()
Dim newbk As Workbook
Set newbk = Workbooks.Add
newbk.SaveAs "C:\Users\RickG\Desktop\test2.xlsx" 'other parameters can be set here if required
' perform operations on newbk
newbk.Close savechanges:=True
Dim ns As Outlook.NameSpace
Dim InBoxFolder As MAPIFolder
Dim InBoxItem As Object 'MailItem
Dim Contents As String, Delimiter As String
Dim Prop, Result
Dim i As Long, j As Long, k As Long
'Setup an array with all properties that can be found in the mail
Prop = Array("Name", "Email", "Phone", "Customer Type", _
"Message")
'The delimiter after the property
Delimiter = ":"
Set ns = Session.Application.GetNamespace("MAPI")
'Access the inbox folder
Set InBoxFolder = ns.GetDefaultFolder(olFolderInbox)
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim ws As Worksheet
Set xlApp = New Excel.Application
With xlApp
.Visible = False
Set xlWB = .Workbooks.Open("C:\Users\RickG\Desktop\test2.xlsx", , False)
Set ws = .Worksheets("Sheet1")
End With
Dim LR As Long
For Each InBoxItem In InBoxFolder.Items
'Only process mails
If Not TypeOf InBoxItem Is MailItem Then GoTo SkipItem
'Skip wrong subjects
If InStr(1, InBoxItem.Subject, "FW: New Lead - Consumer - Help with Medical Bills", vbTextCompare) = 0 Then GoTo SkipItem
'Already processed?
If Not InBoxItem.UnRead Then GoTo SkipItem
'Mark as read
InBoxItem.UnRead = False
'Get the body
Contents = InBoxItem.Body
'Create space for the result
ReDim Result(LBound(Prop) To UBound(Prop)) As String
'Search each property
i = 1
For k = LBound(Prop) To UBound(Prop)
'Find the property (after the last position)
i = InStr(i, Contents, Prop(k), vbTextCompare)
If i = 0 Then GoTo NextProp
'Find the delimiter after the property
i = InStr(i, Contents, Delimiter)
If i = 0 Then GoTo NextProp
'Find the end of this line
j = InStr(i, Contents, vbCr)
If j = 0 Then GoTo NextProp
'Store the related part
Result(k) = Trim$(Mid$(Contents, i + Len(Delimiter), j - i - Len(Delimiter)))
'for every row, find the first blank cell and select it
'MsgBox Result(k)
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A" & LR).Value = Result(k)
'Update the position
i = j
NextProp:
Next
xlApp.DisplayAlerts = False
xlWB.SaveAs ("C:\Users\RickG\Desktop\test2.xlsx")
xlWB.Close
xlApp.Quit
If MsgBox(Join(Result, vbCrLf), vbOKCancel, "Auto Check In") = vbCancel Then Exit Sub
SkipItem:
Next
End Sub
You're not tracking your loop correctly. If you change
Range("A" & LR).Value = Result(k)
to
Range("A" & LR + 1).Value = Result(k)
in your
For k = LBound(Prop) To UBound(Prop)
loop, that should correct your issue.
EDIT: Sorry, findwindow. I didn't see the comment thread below the question. I just saw that the question had no answer yet.
I need to create a macro that opens an Excel file, and saves some files inside the Workbook. The problem is that when I want to run macro more than once in a short time (which unfortunately I need to do), I receive error '462': The remote server machine does not exist or is unavialiable.
I've read about this and tried to fix it: I've created a special module at the beginning to kill Excel process:
Call KillExcel
Function KillExcel()
Dim oServ As Object
Dim cProc As Variant
Dim oProc As Object
Set oServ = GetObject("winmgmts:")
Set cProc = oServ.ExecQuery("Select * from Win32_Process")
For Each oProc In cProc
'Rename EXCEL.EXE in the line below with the process that you need to Terminate.
'NOTE: It is 'case sensitive
If oProc.Name = "EXCEL.EXE" Or oProc.Name = "EXCEL.EXE *32" Then
' MsgBox "KILL" ' used to display a message for testing pur
errReturnCode = oProc.Terminate()
End If
Next
End Function
But unfortunately even if I close this processes I still receive this error. The part of code where I use Excel looks like this:
Dim ark As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Set ark = Excel.Workbooks.Open(FileName:=scexcel)
Set xlSheet = ark.Worksheets("Sheet1")
a = Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row + 1
Cells(a, 2).Value = "ABC"
Cells(a, 3).Value = "DEF"
Cells(a, 4).Value = "GHI"
Cells(a, 5).Value = "JKL"
a = a + 1
Set xlSheet = Nothing
ark.Close SaveChanges:=True
Set ark = Nothing
If it helps, the macro fails every time I run it multiple times in a short time period at line:
Set ark = Excel.Workbooks.Open(FileName:=scexcel)
Note that scexcel is the path of Excel file.
Can you please help me with this problem?
This should work for you (make sure you kill any hidden Excel.exe instances left over from your previous code first):
Dim ark As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim a As Long
Set ark = GetObject(scexcel)
ark.Application.Visible = True
Set xlSheet = ark.Worksheets("Sheet1")
With xlSheet
a = .Range("B" & .Rows.Count).End(xlUp).Row + 1
.Cells(a, 2).Value = "ABC"
.Cells(a, 3).Value = "DEF"
.Cells(a, 4).Value = "GHI"
.Cells(a, 5).Value = "JKL"
End With
Set xlSheet = Nothing
ark.Close SaveChanges:=True
Set ark = Nothing