1

私は最近、送信済みフォルダーに追加された各メールアイテムの件名をスキャンし、件名のプロジェクト番号を探す Outlook vba スクリプトを完成させました。検出されると、スクリプトはプロジェクト番号を抽出し、メールアイテムのコピーを作成してから、そのコピーをプロジェクト番号に基づいて共有メールボックス フォルダーに移動します (最初にフォルダー チェックを実行します)。現在、最初にメール アイテムのコピーを作成してから、そのコピーを新しいフォルダーの宛先に移動するようにセットアップしています。これは、元の送信済みメールアイテムが送信済みフォルダーにそのまま残され、削除されないようにするためです。

私が遭遇した問題は、スクリプトが送信済みフォルダー内にメールアイテムのコピーを作成するときに、スクリプトの新しいインスタンスをトリガーし (新しいアイテムが送信済みフォルダーに追加されたときに実行されるため)、これを繰り返すことです。 Outlook が強制的に閉じられるまで、無期限に処理し、コピーを作成して移動します。項目が追加されるたびにスクリプトがゼロから開始されるため、ループ カウント チェックを追加しても効果がないようです。

以下は完全なコードですが、現在行っているよりもこれにアプローチするより良い方法はありますか? どんな洞察や指示も大歓迎です！

編集: 追加するのを忘れていました。VB 開発者タブ (VbaProject.OTM ファイル) の Outlook の ThisOutlookSession にこのコードを貼り付けました。

Private WithEvents Items As Outlook.Items

Private Sub Application_Startup()
  Dim olApp As Outlook.Application

  Set olApp = Outlook.Application
  Set Items = GetNS(olApp).GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub Items_ItemAdd(ByVal item As Object)

  On Error Resume Next

  MsgBox "Mail Added to Sent Folder, Checking for T-#"

  Dim EmailSub As String
  Dim EmailSubArr As Variant
  Dim ProjectNum As String
  Dim FullProjectNum As String
  Dim ProjNumLen As Long
  Dim ParentFolderName As String
  Dim SubFolderName As String

    If TypeName(item) = "MailItem" Then
        'Checks Email Subject for Project Number Tag
        If InStr(item.Subject, "T-") > 0 Then

            MsgBox "T-# Detected"

            'Splits out Project Number into an Array for Extraction
            EmailSub = item.Subject
            EmailSubArr = Split(EmailSub, Chr(32))

              For i = LBound(EmailSubArr) To UBound(EmailSubArr)
                  If InStr(EmailSubArr(i), "T-") > 0 Then

                      FullProjectNum = EmailSubArr(i)
                      MsgBox "T-# Extracted"
                      ProjNumLen = Len(FullProjectNum)

                      MsgBox ("T-# is " & ProjNumLen & " Characters Long")

                      'Project Number Length Check and Formatting

                      If ProjNumLen >= 11 Then
                        Exit Sub
                      End If

                      If ProjNumLen <= 6 Then
                        Exit Sub
                      End If

                      If ProjNumLen = 10 Then
                      'Really Extended T-# Format 1(ie T-38322X12)
                      ProjectNum = Right(FullProjectNum, 8)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 8)
                      End If

                      If ProjNumLen = 9 Then
                      'Extended T-# Format 1(ie T-38322X1)
                      ProjectNum = Right(FullProjectNum, 7)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 7)
                      End If

                      If ProjNumLen = 8 Then
                      'Uncommon T-# Format (ie T-38322A)
                      ProjectNum = Right(FullProjectNum, 6)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 6)
                      End If

                      If ProjNumLen = 7 Then
                      'Standard T-# Format (ie T-38322)
                      ProjectNum = Right(FullProjectNum, 5)
                      ParentFolderName = Left(ProjectNum, 2)
                      SubFolderName = Left(ProjectNum, 5)
                      End If

                      Exit For

                  End If
              Next i

            MsgBox ("Confirm Extraction (1 of 3) - Project Number is T-" & ProjectNum)
            MsgBox ("Confirm Extraction (2 of 3) - Parent Folder Will Be " & ParentFolderName)
            MsgBox ("Confirm Extraction (3 of 3) - Sub Folder Will Be " & SubFolderName)
            MsgBox ("Will Now Perform Folder Checks")

            'Perform Folder Checks, Creates Folders When Needed

            Dim fldrparent As Outlook.MAPIFolder
            Dim fldrsub As Outlook.MAPIFolder

            Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName)
            Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)

            If fldrparent Is Nothing Then
                MsgBox "Parent Folder Does Not Exist, Creating Folder"
                Set fldrparent = Outlook.Session.Folders("Projects").Folders("Project Root").Folders.Add(ParentFolderName)
            Else
                MsgBox "Parent Folder Already Exists, Do Nothing"
            End If

            If fldrsub Is Nothing Then
                MsgBox "Sub Folder Does Not Exist, Creating Folder"
                Set fldrsub = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders.Add(SubFolderName)
            Else
                MsgBox "Sub Folder Already Exists, Do Nothing"
            End If

            'Moves Copy of Email to Folder

            MsgBox "Copying Sent Email to Project Folder"

            Dim FolderDest As Outlook.MAPIFolder
            Dim myItem As Outlook.MailItem
            Dim myCopiedItem As Outlook.MailItem


            Set FolderDest = Outlook.Session.Folders("Projects").Folders("Project Root").Folders(ParentFolderName).Folders(SubFolderName)
            'Set myCopiedItem = item.Copy

            item.Move FolderDest

        Else
        MsgBox "Did not detect T-##### project number"
        End If

    End If

ProgramExit:
  Exit Sub

End Sub

Function GetNS(ByRef app As Outlook.Application) As Outlook.NameSpace
  Set GetNS = app.GetNamespace("MAPI")
End Function
4

3 に答える 3

0

ItemAdd の代わりに Application_ItemSend を試してください。

http://msdn.microsoft.com/en-us/library/office/ff865076(v=office.14).aspx

見た目よりも簡単です。ThisOutlookSessionモジュール内。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
'  your code here
End Sub

リンクで提供されている例でテストできます。

Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean) 

    Dim prompt As String 

    prompt = "Are you sure you want to send " & Item.Subject & "?" 

    If MsgBox(prompt, vbYesNo + vbQuestion, "Sample") = vbNo Then 

        Cancel = True 

    End If 

End Sub
于 2013-05-09T23:54:20.283 に答える