仅将 VBA 代码应用于主题中包含 "string" 的电子邮件
Only apply VBA code to e-mails containing "string" in the subject
我使用的代码效果很好 - 目的是将信息从 Outlook 发送到 Excel,这样我就可以过滤它并使工作自动化。
问题是:VBA 代码正在对所有收到的电子邮件执行,我只想对主题以“EK”开头的电子邮件执行它。
我已经尝试如下使用 InStr 函数,但它不起作用:
If InStr(xMailItem.Subject, "EK") = 0 Then
Exit Sub
End If
我应该把这行代码放在哪里?
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:$A9;MENOR(SE(ÉNÚM(LOCALIZAR(""PC"";$A:$A9));CORRESP(LIN($A:$A9);LIN($A:$A9)));" & k & "));"""")"
xWs.Range("B" & k).FormulaArray = xWs.Range("B" & k).Formula
Next k
End With
End Sub
Instr
不区分大小写。
If InStr(UCase(xMailItem.Subject), UCase("EK")) = 0 Then
UCase
或 LCase
。
在两个部分,或者您可能 运行 打错了“eK”。
我使用的代码效果很好 - 目的是将信息从 Outlook 发送到 Excel,这样我就可以过滤它并使工作自动化。
问题是:VBA 代码正在对所有收到的电子邮件执行,我只想对主题以“EK”开头的电子邮件执行它。
我已经尝试如下使用 InStr 函数,但它不起作用:
If InStr(xMailItem.Subject, "EK") = 0 Then
Exit Sub
End If
我应该把这行代码放在哪里?
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:$A9;MENOR(SE(ÉNÚM(LOCALIZAR(""PC"";$A:$A9));CORRESP(LIN($A:$A9);LIN($A:$A9)));" & k & "));"""")"
xWs.Range("B" & k).FormulaArray = xWs.Range("B" & k).Formula
Next k
End With
End Sub
Instr
不区分大小写。
If InStr(UCase(xMailItem.Subject), UCase("EK")) = 0 Then
UCase
或 LCase
。
在两个部分,或者您可能 运行 打错了“eK”。