Mit Regex mit positivem Lookbehind in VBA
Dies ist kein Code, den ich vollständig geschrieben habe. Einige habe ich aus ein oder zwei Sites zusammengesetzt, andere habe ich festgelegt. Was ich versuche zu tun ist, verwenden Sie eine Regex-Funktion in @ definie regex.Pattern, um den Betreff der Nachricht anzuzeigen und einen Wert zu extrahieren. Folgendes werde ich im Betreff der E-Mail sehen:
New Linux Server: prod-servername-a001
Soweit kann ich den vollständigen Betreff der Nachricht in die Excel-Datei übernehmen, aber wenn ich versucht habe, den Regex-Teil zu implementieren, erhalte ich den Fehlercode 5017 (Fehler im Ausdruck von dem, was ich finden kann) und der Regex funktioniert nicht . Ich erwarte, dass das Skript den Betreff der Nachricht abruft, den Wert mit der Regex extrahiert und in die Zelle platziert. Ich benutze RegEx Builder (RegEx-Testprogramm), um den Ausdruck zu testen, und es funktioniert dort, aber nicht hier. Ich bin sehr neu in VB, daher weiß ich nicht, ob das Problem darin besteht, dass VB diesen Ausdruck nicht verwenden kann oder ob das Skript an einer anderen Stelle fehlschlägt und der Fehler ein Rest eines anderen Problems ist. Oder gibt es einen besseren Weg, dies zu schreiben?
Sub ExportToExcel()
On Error GoTo ErrHandler
'Declarations
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 filePath 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
'RegEx Declarations
Dim result As String
Dim allMatches As Object
Dim regex As Object
Set regex = CreateObject("vbscript.regexp")
regex.Pattern = "(?<=Server: ).*"
regex.Global = True
regex.IgnoreCase = True
' Set the filename and path for output, requires creating the path to work
strSheet = "outlook.xlsx"
strPath = "D:\temp\"
filePath = strPath & strSheet
'Debug
Debug.Print filePath
'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 (filePath)
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
If itm.UnRead = True Then
intRowCounter = intRowCounter + 1
wks.Cells(1, 1).value = "Subject" 'Row 1 Column 1 (A)
wks.Cells(1, 2).value = "Unread" 'Row 1 Column 2 (B)
wks.Cells(1, 3).value = "Server" 'Row 1 Column 3 (C)
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
If InStr(msg.Subject, "Server:") Then
Set allMatches = regex.Execute(msg.Subject)
rng.value = allMatches
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
Else
rng.value = msg.Subject
intColumnCounter = intColumnCounter + 1
msg.UnRead = False
End If
Set rng = wks.Cells(intRowCounter + 1, intColumnCounter)
rng.value = msg.UnRead
intColumnCounter = intColumnCounter + 1
End If
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 = 1004 Then
MsgBox filePath & " doesn't exist", vbOKOnly, "Error"
ElseIf Err.Number = 13 Then
MsgBox Err.Number & ": Type Mismatch", vbOKOnly, "Error"
ElseIf Err.Number = 438 Then
MsgBox Err.Number & ": Object doesn't support this property or method", vbOKOnly, "Error"
ElseIf Err.Number = 5017 Then
MsgBox Err.Number & ": Error in expression", vbOKOnly, "Error"
Else
MsgBox Err.Number & ": Description: ", 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