I've created a Rule , which every time an email arrives with a certain text in subject runs a scrip and store certain data in an Excel sheet.
Code:
Option Explicit
Sub CopyToExcelMacro()
Dim olItem As Outlook.MailItem
Dim xlApp As Excel.Application
Dim xlWB As Object
Dim xlSheet As Object
Dim vText, vText2, vText3, vText4, vText5, vText6, vText7, vText8, vText9 As Variant
Dim sText As String
Dim texto As String
Dim rCount As Long
Dim rValue As Integer
Dim bXStarted As Boolean
Dim enviro As String
Dim strPath As String
enviro = CStr(Environ("USERPROFILE"))
'the path of the workbook
strPath = enviro & "\Documents\Fieldanalysis.xlsx"
Dim Ret
Do
Ret = IsWorkBookOpen(strPath)
If Ret = True Then
MsgBox "File is open Deve fechar os ficheiro excel"
Else
MsgBox "File is Closed"
End If
Loop While Ret = True
On Error Resume Next
Set xlApp = New Excel.Application
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Fieldanalysis")
' Process the message record
Set olItem = Application.ActiveExplorer().Selection(1)
'Find the next empty line of the worksheet
rCount = xlSheet.Range("D" & xlSheet.Rows.Count).End(-4162).Row
'rValue = xlSheet.Range("A" & rCount - 1).Value
'rValue = rValue + 1
rCount = rCount + 1
sText = olItem.Body
Dim Reg1 As RegExp
Dim M1 As MatchCollection
Dim M As Match
Dim strSubject As String
Dim testSubject As String
Dim i As Integer
Set Reg1 = New RegExp
' \s* = invisible spaces
' \d* = match digits
' \w* = match alphanumeric
For i = 1 To 9
With Reg1
Select Case i
Case 1
.Pattern = "(Complain. Cust.:+\s*\n*(\w*)\s*)"
.Global = False
Case 2
.Pattern = "(Part number:+\s*\n*(\w*)\s*)"
.Global = False
Case 3
.Pattern = "(QC-Number:+\s*\n*(\w*\d*)\s*)"
.Global = False
Case 4
.Pattern = "(Manufact. date:+\s*\n*(\w*/\w*/\w*)\s*)"
.Global = False
Case 5
.Pattern = "(Analysis Result+\s*\n*([\w*\s*]*)\s*)"
.Global = False
Case 6
.Pattern = "(Cause text:+\s*\n*(\w*\s*\w*)\s*)"
.Global = False
Case 7
.Pattern = "(Supplier name:+\s*\n*(\w*)\s*)"
.Global = False
Case 8
.Pattern = "(Part number:+\s*\n*([\d]{4}\.[\d]{3}\.[\d]{3})\s*)"
.Global = False
Case 9
.Pattern = "(Mileage \(Km\):+\s*\n*(\w*)\s*)"
.Global = False
End Select
End With
If Reg1.test(sText) Then
Set M1 = Reg1.Execute(sText)
For Each M In M1
Debug.Print M.SubMatches(1)
strSubject = M.SubMatches(1)
Select Case i
Case 1
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText = strSubject
Case 2
'vText2 = Trim(M.SubMatches(1))
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText2 = strSubject
Case 3
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText3 = strSubject
'vText3 = Trim(M.SubMatches(1))
Case 4
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText4 = strSubject
'vText4 = Trim(M.SubMatches(1))
Case 5
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText5 = strSubject
'vText5 = Trim(M.SubMatches(1))
Case 6
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText6 = strSubject
Case 7
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText7 = strSubject
Case 8
'vText2 = Trim(M.SubMatches(1))
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText8 = strSubject
Case 9
strSubject = M.SubMatches(1)
strSubject = Replace(strSubject, Chr(13), "")
'vText = Trim(M.SubMatches(1))
vText9 = strSubject
'vText3 = Trim(M.SubMatches(1))
End Select
Next M
End If
'strSubject = Replace(strSubject, Chr(13), "")
'testSubject = testSubject & "; " & Trim(strSubject)
'Debug.Print i & testSubject
'Next
Next i
'xlSheet.Range("A" & rCount) = rValue
xlSheet.Range("D" & rCount) = vText
xlSheet.Range("E" & rCount) = vText2
xlSheet.Range("F" & rCount) = vText3
xlSheet.Range("G" & rCount) = vText4
xlSheet.Range("H" & rCount) = vText5
xlSheet.Range("I" & rCount) = vText6
xlSheet.Range("J" & rCount) = vText7
xlSheet.Range("K" & rCount) = vText8
xlSheet.Range("L" & rCount) = vText9
Call MsgBox("Foi guardado no ficheiro excel: " & vbLf & "Complain. Cust: " & vText & vbLf & " Part number: " & vText2 & vbLf & " QC-Number: " & vText3 & vbLf & " Manufact. date: " & vText4 & vbLf & " Analysis Result: " & vText5 & vbLf & " Cause text: " & vText6 & vbLf & " Supplier name: " & vText7 & vbLf & " Part number: " & vText8 & vbLf & " Mileage (Km): " & vText9)
xlWB.Close 1
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
End Sub
Function IsWorkBookOpen(FileName As String)
Dim ff As Long, ErrNo As Long
On Error Resume Next
ff = FreeFile()
Open FileName For Input Lock Read As #ff
Close ff
ErrNo = Err
On Error GoTo 0
Select Case ErrNo
Case 0: IsWorkBookOpen = False
Case 70: IsWorkBookOpen = True
Case Else: Error ErrNo
End Select
End Function
Problem:
Sometimes scrip works but can not get data, But if I resend the email myself, it already works.
Can anyone identify a problem? I think it should be in the declaration of some variable or at the end of the program when I have to close the variables (this is my opinion) Why:
-
The rule is always executed when email arrives (but sometimes it does not pick up the data I want)
-> It can not be a problem for email to arrive with a different subject
-
Can not be
REGEXproblems because if the email I received did not it worked if I resend it works for me
As I've never programmed in VBA I'm not sure if I start / close the variables correctly, so I think the problem comes from there.