I am using a code that works great - the purpose is to send info from Outlook to Excel so I can filter it and automatize the work.
The problem is: the VBA code is executing for all e-mails received and I only want to execute it onto e-mails with subject starting with "EK".
I already tried using InStr function as below, but it doesn't work:
If InStr(xMailItem.Subject, "EK") = 0 Then
Exit Sub
End If
Where should I put this line of code?
Private Sub GMailItems_ItemAdd(ByVal Item As Object)
Dim xMailItem As Outlook.MailItem
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xNextEmptyRow As Integer
Dim linhas As Variant, i As Integer
Dim linhaInicial As Long
Dim numeroCaracteresAssunto As Integer
Dim assuntoEmail As String
Dim k As Integer
On Error Resume Next
If (Item.Class <> olMail) Then Exit Sub
Set xMailItem = Item
xExcelFile = "EXCELFILEPATH.xlsx"
If IsWorkBookOpen(xExcelFile) = True Then
Set xExcelApp = GetObject(, "Excel.Application")
Set xWb = GetObject(xExcelFile)
If Not xWb Is Nothing Then xWb.Close True
Else
Set xExcelApp = New Excel.Application
End If
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = Sheets.Add
numeroCaracteresAssunto = Len(xMailItem.Subject)
assuntoEmail = Right(xMailItem.Subject, numeroCaracteresAssunto - 16)
xWs.Name = UCase(assuntoEmail)
xNextEmptyRow = xWs.Range("B" & xWs.Rows.Count).End(xlUp).Row + 1
linhaInicial = 1
With xWs
linhas = Split(xMailItem.Body, vbNewLine)
For i = 0 To UBound(linhas)
Cells(linhaInicial + i, 1).Value = linhas(i)
linhaInicial = linhaInicial + 1
Next
For k = 1 To i
xWs.Range("B" & k).FormulaLocal = "=SEERRO(ÍNDICE($A$1:$A$999;MENOR(SE(ÉNÚM(LOCALIZAR(""PC"";$A$1:$A$999));CORRESP(LIN($A$1:$A$999);LIN($A$1:$A$999)));" & k & "));"""")"
xWs.Range("B" & k).FormulaArray = xWs.Range("B" & k).Formula
Next k
End With
End Sub
Instr is not case sensitive.
If InStr(UCase(xMailItem.Subject), UCase("EK")) = 0 Then
Either UCase or LCase.
On both parts, or you may run into an "eK" typo.
Related
I am new to VBA as I have just started learning it.
Right now I'm facing a problem in exporting the message body from outlook to excel. The funny thing is when i run the first time, it works. But when when i run the second time, the error message as stated in my title appears.
I clicked on the debug and it highlighted this code: "offsetRow = Cells(Rows.Count, 1).End(xlUp).Row"
I have tried various way like selecting the worksheet that I wanted to paste the data into it but to no avail. Therefore, I hope the experts here can assist me in debugging the code. Also feel free to feedback on my coding if I have done any redundancy that will slow my computer.
FYI, this is for my work so that I can export out the email contents into excel. Thanks in advance.
Sub ExportToExcel()
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
Dim masterData() As String
Dim subData() As String
Dim i As Integer
Dim offsetRow As Long
strSheet = "For fun.xlsx"
strPath = "C:\Users\XXXXX\Desktop\New folder\"
strSheet = strPath & strSheet
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "Thank you for using this service.", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "Please select the correct folder.", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets("Sheet1")
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
Set msg = itm
masterData = Split(msg.Body, vbCrLf) 'Seperate according to lines
For i = 0 To UBound(masterData)
If masterData(i) = "" Then
'Do nothing
Else
'do the split here
subData = Split(masterData(i), vbTab)
wks.Activate
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row 'This is where the error appears
If i = 0 Then
intRowCounter = i + offsetRow + 1
Else
intRowCounter = i + offsetRow
End If
For intColumnCounter = 0 To UBound(subData)
Set rng = wks.Cells(intRowCounter, intColumnCounter + 1)
rng.Value = subData(intColumnCounter)
Next intColumnCounter
End If
Next i
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
Your problem is because you don't qualify the Excel range references
Change
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row 'This is where the error appears
To
offsetRow = wks.Cells(wks.Rows.Count, 1).End(-4162).Row
BTW there are a lot of optimisations that can be done to this code
I changed the:
offsetRow = Cells(Rows.Count, 1).End(xlUp).Row
into
With wks
offsetRow = .Cells(.Rows.Count, 1).End(xlUp).Row
End With
and it works now.
I am working on a sort of "BOT" for Outlook (using Outlook VBA), in which I receive info by mail, split the mail body, paste it on Excel and execute Excel macros.
After adding the part where I call the Excel macro, I get
'1004 - application-defined or object-defined error'
if I'm running this for the second + time.
xlApp.Application.Run "AINT.Cali_B_Click"
Even though I'm setting my Excel variables to nothing and using .close and .quit, Excel is still running.
How can I end the application reference that is keeping Excel open?
Here's my full code:
Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
Dim splitter() As String
Dim splitter2() As String
Dim loopH As String
Dim str As Variant
Dim LoopCali As Integer
Dim i, j As Integer
Dim xlApp As Object
Dim sourceWB As Object
Dim Header, QuoteSTG, AINT, Treinamento As Object
Dim strFile, file_name As String
Dim shellcom As String
i = 1
If TypeName(Item) = "MailItem" Then
If InStr(Item.Subject, "BOT") > 0 Then
splitter = Split(Item.Body, vbCrLf)
Set xlApp = CreateObject("Excel.Application")
strFile = "C:\Users\e1257539\Desktop\SMOBOT\SMO_TOOL_BOT.xlsm"
With xlApp
.Visible = False
.EnableEvents = False
.DisplayAlerts = False
End With
Set sourceWB = Workbooks.Open(strFile)
sourceWB.Activate
Set Header = sourceWB.Sheets(4)
Set QuoteSTG = sourceWB.Sheets(13)
Set AINT = sourceWB.Sheets(7)
Set Treinamento = sourceWB.Sheets(10)
file_name = QuoteSTG.Range("A" + CStr(QuoteSTG.Range("B1").Value2)).Value2
QuoteSTG.Range("A" + CStr(QuoteSTG.Range("B1").Value2)).Value2 = ""
If splitter(2) = "Calibração" Then
loopH = splitter(26)
LoopCali = CInt(loopH)
sourceWB.Save
Header.Range("D6").Value2 = splitter(22)
Header.Range("D8").Value2 = splitter(12)
Header.Range("F4").Value2 = "AINT"
Header.Range("F3").Value2 = "EXW"
Header.Range("C2").Value2 = file_name
Header.Range("C4").Value2 = "Calibração"
Header.Range("L2").Value2 = "30"
Header.Range("K12").Value2 = Item.Subject '< criar string?
j = 40
For i = 1 To LoopCali
splitter2 = Split(splitter(j), "-")
AINT.Range("N7").Value2 = splitter2(0)
AINT.Range("N13").Value2 = splitter2(1)
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N14").Value2 = splitter(j)
End If
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N16").Value2 = splitter(j)
End If
j = j + 2
If splitter(j) <> "" Then
If splitter2(0) <> "RMT" Then
AINT.Range("N15").Value2 = splitter(j)
End If
End If
j = j + 2
If splitter(j) <> "" Then
AINT.Range("N17").Value2 = splitter(j)
End If
j = j + 2
xlApp.Application.Run "AINT.Cali_B_Click" '< calling the excel sub
Next i
End If
End If
End If
'Closing excel
MkDir "C:\Users\e1257539\Desktop\SMOBOT\" + file_name
sourceWB.SaveAs FileName:="C:\Users\e1257539\Desktop\SMOBOT\" + file_name + "\" + file_name
sourceWB.Close (False)
xlApp.Quit
Set xlApp = Nothing
Set sourceWB = Nothing
Set AINT = Nothing
Set QuoteSTG = Nothing
Set Header = Nothing
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
If Not sourceWB Is Nothing Then
sourceWB.Close (False)
End If
If Not xlApp Is Nothing Then
xlApp.Quit
End If
Set xlApp = Nothing
Set sourceWB = Nothing
Set AINT = Nothing
Set QuoteSTG = Nothing
Set Header = Nothing
End Sub
Turns out using xlApp.Application.Run "AINT.Cali_B_Click" or xlApp.Application.Run sourceWB.Name & "AINT.Cali_B_Click" left open references on the VBA code.
The way to call the code without lefting any open is using CallByName,
As in Call CallByName(AINT, "Cali_B_Click", VbMethod)
This way the VBA code can call the function and run as many times as needed without the current error.
Hi I have written some vba code to loop through all emails in a folder , but I am struggling to find a way to look for a hyperlink. copy the hyperlink to the next empty row in column A. copy the text beneath the hyperlink to Column B. Then look for next hyperlink and repeat process. At present my code copies everything from the email and the hyperlinks are showing actual link not the visible wording.
Code
Option Explicit
Sub Get_Google_Alerts_From_Emails()
Sheet1.Select
ActiveSheet.Cells.NumberFormat = "#"
Application.DisplayAlerts = False
Dim oHTML As MSHTML.HTMLDocument: Set oHTML = New MSHTML.HTMLDocument
Dim ObjOutlook As Object
Dim MyNamespace As Object
Dim i As Integer
Dim j As Long
Dim abody() As String
Dim strSubject As String
Dim k
Dim x
Dim google_text As String
Dim strPattern As String
Dim strReplace As String
Dim strInput As String
Dim objRegex As Object
Set objRegex = CreateObject("vbscript.regexp")
Dim regEx As New RegExp
strPattern = "\s+"
strReplace = " "
x = Sheet1.Cells(Rows.Count, 1).End(xlUp).Row
Set ObjOutlook = GetObject(, "Outlook.Application")
Set MyNamespace = ObjOutlook.GetNamespace("MAPI")
k = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items.Count
For i = k To 1 Step -1
On Error GoTo vend
strSubject = MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Subject
If strSubject Like "*Google*" Then GoTo google:
GoTo notfound
google:
abody = Split(MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Body, vbCrLf)
For j = 0 To UBound(abody)
On Error GoTo error_google
If Len(abody(j)) > 1 Then
With regEx
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = False
.IgnoreCase = True
End With
If regEx.Test(abody(j)) Then
google_text = regEx.Replace(abody(j), strReplace)
End If
With objRegex
.Pattern = "[A-Z]+"
.Global = True
.IgnoreCase = False
If .Test(abody(j)) Then
x = x + 1
Sheet1.Range("A" & x) = google_text
Sheet1.Range("C" & x) = strSubject
Else
End If
End With
End If
error_google:
Next j
MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts").Items(i).Move MyNamespace.GetDefaultFolder(6).Folders("_Google_Alerts_Complete")
GoTo comp
notfound:
comp:
Next i
vend:
Set ObjOutlook = Nothing
Set MyNamespace = Nothing
Application.DisplayAlerts = True
End Sub
At present my code copies everything from the email and the hyperlinks are showing actual link not the visible wording.
Here is a very basic example to achieve what you want. I am using Debug.Print to show the data. Feel free to amend it to move it to Excel. I am running this code from Excel.
Option Explicit
Const olMail As Integer = 43
Sub Sample()
Dim OutApp As Object
Dim MyNamespace As Object
Dim objFolder As Object
Dim olkMsg As Object
Dim objWordDocument As Object
Dim objWordApp As Object
Dim objHyperlinks As Object
Dim objHyperlink As Object
Set OutApp = CreateObject("Outlook.Application")
Set MyNamespace = OutApp.GetNamespace("MAPI")
'~~> Let the user select the folder
Set objFolder = MyNamespace.PickFolder
'~~> Loop through the emails in that folder
For Each olkMsg In objFolder.Items
'~~> Check if it is an email
If olkMsg.Class = olMail Then
'~~> Get the word inspector
Set objWordDocument = olkMsg.GetInspector.WordEditor
Set objWordApp = objWordDocument.Application
Set objHyperlinks = objWordDocument.Hyperlinks
If objHyperlinks.Count > 0 Then
For Each objHyperlink In objHyperlinks
Debug.Print objHyperlink.Address '<~~ Address
Debug.Print objHyperlink.TextToDisplay '<~~ Display text
Next
End If
End If
Next
End Sub
I have code in Outlook to export data, from emails in a selected folder, to an Excel Workbook.
In that workbook I have VBA code to parse the data (the subject line for now, eventually the body).
When I export from Outlook to a ".xlsx" file everything looks great.
When I export to my ".xlsm" file it adds columns with information that does not align with the correct imported information.
Ex: Column A & B are correct, A is the CreationTime, B is the full SubjectLine
Column C, D, E, etc. will be random parsed bits of subject lines.
Are the macros in the Excel workbook running when the export to Excel is happening?
If so, how can I prevent that?
My Outlook code:
Sub ExportToExcel()
On Error GoTo ErrHandler
Dim appExcel As Excel.Application
Dim wkb As Excel.Workbook
Dim wks As Excel.Worksheet
Dim rng As Excel.Range
Dim strSheet As String
Dim strPath As String
Dim intRowCounter As Integer
Dim intColumnCounter As Integer
Dim msg As Outlook.MailItem
Dim nms As Outlook.NameSpace
Dim fld As Outlook.MAPIFolder
Dim itm As Object
'Opens the Workbook and Sheet to paste in
strSheet = "Tester.xlsx"
strPath = "G:\Jason\"
strSheet = strPath & strSheet
Debug.Print strSheet
'Select export folder
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.PickFolder
'Handle potential errors with Select Folder dialog box.
If fld Is Nothing Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.DefaultItemType <> olMailItem Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
ElseIf fld.Items.Count = 0 Then
MsgBox "There are no mail messages to export", vbOKOnly, "Error"
Exit Sub
End If
'Open and activate Excel workbook.
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (strSheet)
Set wkb = appExcel.ActiveWorkbook
Set wks = wkb.Sheets(1)
wks.Activate
appExcel.Application.Visible = True
'Copy field items in mail folder.
For Each itm In fld.Items
intColumnCounter = 1
Set msg = itm
intRowCounter = intRowCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.CreationTime
intColumnCounter = intColumnCounter + 1
Set rng = wks.Cells(intRowCounter, intColumnCounter)
rng.Value = msg.Subject
Next itm
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
Exit Sub
ErrHandler:
If Err.Number <> 0 Then
MsgBox strSheet & " doesn't exist", vbOKOnly, "Error"
End If
Set appExcel = Nothing
Set wkb = Nothing
Set wks = Nothing
Set rng = Nothing
Set msg = Nothing
Set nms = Nothing
Set fld = Nothing
Set itm = Nothing
End Sub
Parsing code in Excel:
Sub SplitSubjectLine()
Dim text As String
Dim i As Integer
Dim y As Integer
Dim LastRow As Long
Dim name As Variant
ReDim name(3)
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
For y = 1 To LastRow
Cells(y, 2).Select
text = ActiveCell.Value
name = Split(text, ",")
For i = 0 To UBound(name)
Cells(y, i + 2).Value = name(i)
Next i
Next
End Sub
You need to wrap your actions in Excel with :
appExcel.EnableEvents = False (before your actions in Excel) and
appExcel.EnableEvents = True when you are done in Excel
Pseudo code :
''Start of your sub
Set appExcel = CreateObject("Excel.Application")
appExcel.EnableEvents = False
''Your actions in Excel
appExcel.EnableEvents = True
''End of your sub
I've written this script to search an Outlook folder containing a series of emails with a certain string of information in the email body to copy into an Excel file.
When I first created and ran the script there weren't any problems, this is the second time I'm running it and it's excruciatingly slow and froze up my computer. I noticed it seems to be opening a new instance of Excel for each email.
I'm confused because it ran without error the first time, no changes to the script and second time running it, well I couldn't let it finish because the computer froze. Is there any way to not open a new instance for every email?
I'm not interested in revamping the entire code, but if we can make it more efficient in a simple way, count me in.
To be clear, this is run from Outlook as a rule and is run once a week.
Sub CopyToExcel(olItem As Outlook.MailItem)
Dim xlApp As Object
Set xlApp = CreateObject("Excel.Application")
Dim xlWB As Object
Dim xlSheet As Object
Dim xlOpenWB As Object
Dim vText As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim xlUp As Long
Dim FileName As String
xlUp = -4162
FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"
enviro = (Environ("USERPROFILE"))
'the path of the workbook VB function, don't change
strPath = enviro & FileName
'Add the workbook to input the data
Set xlWB = xlApp.Workbooks.Add()
xlWB.SaveAs (strPath)
Set xlOpenWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlOpenWB.Sheets("newhires")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'sText is content of the email
sText = olItem.Body
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.pattern = "(Employee Number\s*[:]\s*(\d*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("A" & rCount) = vText
vText.RemoveDuplicates Columns:=Array(1)
xlOpenWB.Close 1
xlApp.Quit
Set Reg1 = Nothing
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlOpenWB = Nothing
End Sub
Ok, so you are running this as a rule with a script as the action. Use GetObject to get the current instance and if an error occurs create one. May also want to remove the quit call as that is exiting out of Excel.
Sub CopyToExcel(olItem As Outlook.MailItem)
On Error Resume Next
Dim xlApp as Object
Dim xlWB As Object
Dim xlSheet As Object
Dim xlOpenWB As Object
Dim vText As Variant
Dim sText As String
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim xlUp As Long
Dim FileName As String
xlUp = -4162
'try and get the current running object
Set xlApp = GetObject(, "Excel.Application")
If Err.Number <> 0 Then 'no object was found so create one
Set xlApp = CreateObject("Excel.Application")
Err.Clear
End If
FileName = "\Desktop\newhires" & Format(Date, "yyyyMMDD") & ".xlsx"
enviro = (Environ("USERPROFILE"))
'the path of the workbook VB function, don't change
strPath = enviro & FileName
'Add the workbook to input the data
Set xlWB = xlApp.Workbooks.Add()
xlWB.SaveAs (strPath)
Set xlOpenWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlOpenWB.Sheets("newhires")
'Find the next empty line of the worksheet
rCount = xlSheet.Range("A" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1
'sText is content of the email
sText = olItem.Body
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
With Reg1
.Pattern = "(Employee Number\s*[:]\s*(\d*))"
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
vText = Trim(M.SubMatches(1))
Next
End If
xlSheet.Range("A" & rCount) = vText
vText.RemoveDuplicates Columns:=Array(1)
xlOpenWB.Close 1
'removed xlApp.Quit
xlApp = Nothing
Set Reg1 = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set xlOpenWB = Nothing
End Sub