Emailadresse aus Emailbody auslesen – Performance

Home-›Foren-›Outlook-›Outlook VBA-›Emailadresse aus Emailbody auslesen – Performance

1 Antwort anzeigen (von insgesamt 1)
  • Autor
    Beitrag
  • #44749
    thl1000
    Teilnehmer

      Hi,

      ich benutze rgxExtract in einem Outlook Macro (es wird die erste Email-Adresse aus dem Email-Body ausgelesen, wenn im Email-Subject ein oder mehrere Schlüsselworte vorkommen).

      Wenn ich nun diese Makro ausführe, nimmt sich Outlook 50% CPU-Leistung und reagiert eerst wieder nach Beendigung des Makros.

      Hier der Code:

      [code]
      Sub TEST()
      Dim objNameSpace As Outlook.NameSpace
      Dim objItem As Object
      Dim oMail As Outlook.MailItem
      Dim objInboxFolder As Outlook.Folder

      Dim strBody As String
      Dim strEmail As String
      Dim varKeywords As Variant
      Dim varKeyword As Variant

      varKeywords = Array(\”service\”, \”ticket\”)

      Set objNameSpace = Application.GetNamespace(\”MAPI\”)
      Set objInboxFolder = objNameSpace.GetDefaultFolder(olFolderInbox)

      For Each objItem In objInboxFolder.Items
      If TypeOf objItem Is MailItem Then
      Set oMail = objItem

      For Each varKeyword In varKeywords
      If InStr(1, LCase(oMail.Subject), varKeyword) Then
      strEmail = rgxExtract(strBody, \”([0-9a-zA-Z]([-.w]*[0-9a-zA-Z])*@([0-9a-zA-Z][-w]*[0-9a-zA-Z].)+[a-zA-Z]{2,9})\”, , False, True, True)

      If strEmail <> \”\” Then
      MsgBox strEmail
      End If
      End If

      strEmail = \”\”
      strBody = \”\”
      Next
      End If
      Next

      End Sub

      Set objInboxFolder = Nothing
      Set objItem = Nothing
      Set oMail = Nothing
      Set objNameSpace = Nothing

      Public Function rgxExtract(Optional ByVal Target As Variant, _
      Optional Pattern As String = \”\”, _
      Optional ByVal Item As Long = 0, _
      Optional CaseSensitive As Boolean = False, _
      Optional FailOnError As Boolean = True, _
      Optional Persist As Boolean = False) _
      As Variant

      \’Regular expression matching function suitable for use
      \’in VB/A generally and in Access queries.
      \’By John Nurick. Updated 14 Jan 06.

      \’Takes a search string (Target) and a regular expression
      \'(Pattern), and an optional Item argument.
      \’- If Item is omitted and a substring of Target matches Pattern,
      \’ returns that substring.
      \’- If Pattern includes grouping parentheses, a substring of Target
      \’ matches Pattern, and Item is an integer, returns the submatch
      \’ specified by Item (first submatch is item 0). If there aren\’t
      \’ enough submatches, returns Null. Negative values of Item start
      \’ counting with the last submatch.
      \’- If no match, returns Null.
      \’- Returns Null on error unless FailOnError is True.
      \’ Always matches against the entire Target (i.e. Global and
      \’ Multiline are True).

      \’CaseSensitive matches regardless of case.

      \’Persist controls whether the compiled RegExp object
      \’remains in memory ready for the next call to the
      \’function or whether it is disposed of immediately. This
      \’means the function can be used in queries without having
      \’to create, compile, use and destroy a new RegExp object for
      \’each row being processed. But it also means that the object
      \’remains in memory after the query has run. To destroy the
      \’object and release the memory, call this function one
      \’last time with no arguments.
      \’
      \’Calling the function with different arguments (e.g. a new
      \’Pattern) recompiles the RegExp object, so
      \’the function can be used in different queries. However there
      \’may be problems if two threads are calling the function at
      \’the same time.

      Const rgxPROC_NAME = \”rgxExtract\”
      Static oRE As Object \’VBScript_RegExp_55.RegExp
      \’Static declaration means we don\’t have to create
      \’and compile the RegExp object every single time
      \’the function is called.
      Dim oMatches As Object \’VBScript_RegExp_55.MatchCollection

      On Error GoTo ErrHandler
      rgxExtract = Null \’Default return value
      \’NB: if FailOnError is false, returns Null on error

      If IsMissing(Target) Then
      \’This is the signal to dispose of oRE
      Set oRE = Nothing
      Exit Function \’with default value
      End If

      \’Create the RegExp object if necessary
      If oRE Is Nothing Then
      Set oRE = CreateObject(\”VBScript.Regexp\”)
      End If

      With oRE
      \’Check whether the current arguments (other than Target)
      \’are different from those stored in oRE, and update them
      \'(thereby recompiling the regex) only if necessary.
      If CaseSensitive = .IgnoreCase Then
      .IgnoreCase = Not .IgnoreCase
      End If
      .Global = True
      .Multiline = True
      \’ If Multiline <> .Multiline Then
      \’ .Multiline = Multiline
      \’ End If
      If Pattern <> .Pattern Then
      .Pattern = Pattern
      End If

      \’Finally, execute the match
      If IsNull(Target) Then
      rgxExtract = Null
      Else
      Set oMatches = oRE.Execute(Target)
      If oMatches.Count > 0 Then
      If oMatches(0).SubMatches.Count = 0 Then
      \’No ( ) group in Pattern: return the match
      If Item < 0 Then \'we\'re counting from last item \'convert to count from the first item Item = oMatches.Count + Item End If Select Case Item Case Is < 0 \'Negative Item originally passed exceeded the \'number of matches rgxExtract = Null If FailOnError Then Err.Raise 9 End If Case Is >= oMatches.Count
      \’Positive Item exceeded the number of matches
      rgxExtract = Null
      If FailOnError Then
      Err.Raise 9
      End If
      Case Else
      rgxExtract = oMatches(Item)
      End Select

      Else \’There are one or more ( ) captured groups in Pattern
      \’return the one specified by Item
      With oMatches(0).SubMatches
      If Item < 0 Then \'we\'re counting from last item \'convert to count from the first item Item = .Count + Item End If Select Case Item Case Is < 0 \'Negative Item originally passed exceeded the \'number of submatches rgxExtract = Null If FailOnError Then Err.Raise 9 End If Case Is >= .Count
      \’Positive Item exceeded the number of submatches
      rgxExtract = Null
      If FailOnError Then
      Err.Raise 9
      End If
      Case Else \’valid Item number
      rgxExtract = .Item(Item)
      End Select
      End With
      End If
      Else
      rgxExtract = Null
      End If
      End If
      End With

      \’Tidy up and normal exit
      If Not Persist Then Set oRE = Nothing
      Exit Function

      ErrHandler:
      If FailOnError Then
      With Err
      Select Case .Number
      \’Replace the default \”object-defined error\” message
      Case 9: .Description = \”Subscript out of range (the Item number requested \” _
      & \”was greater than the number of matches found, or than the number of \” _
      & \”(…) grouping/capturing parentheses in the Pattern).\”
      Case 13: .Description = \”Type mismatch, probably because \” _
      & \”the \”\”Target\”\” argument could not be converted to a string\”
      Case 5017: .Description = \”Syntax error in regular expression\”
      Case 5018: .Description = \”Unexpected quantifier in regular expression\”
      Case 5019: .Description = \”Expected \’]\’ in regular expression\”
      Case 5020: .Description = \”Expected \’)\’ in regular expression\”
      Case Else
      If oRE Is Nothing Then \’Failed to create Regexp object
      .Description = \”Could not create VBScript.RegExp object. \” & Err.Description
      Else \’Unexpected error
      .Description = rgxPROC_NAME & \”: \” & .Description
      End If
      End Select
      Set oRE = Nothing
      .Raise Err.Number, rgxPROC_NAME, _
      rgxPROC_NAME & \”(): \” & .Description
      End With
      Else \’Fail silently
      Err.Clear
      Set oRE = Nothing
      End If
      End Function
      [/code]

      Hat irgendjemand eine Idee, warum das so ist und wie man das evtl. abstellen kann?

      [Editiert am 6/2/2008 von thl1000]

    1 Antwort anzeigen (von insgesamt 1)

    Hat Ihnen der Beitrag gefallen?

    1 Stern2 Sterne3 Sterne4 Sterne5 Sterne (Keine Bewertung vorhanden)
    Loading...