2

私は VBA を初めて使用し、電子メールの件名を検索するルールについてあなたの助けが必要です。特定の文字列「LSC_」が件名で見つかった場合 (例: LSC_IND_TATA で、デフォルトの命名規則が LSC_XXX_XXX または [LSC_XXX_XXX])、メッセージは次のとおりです。その名前のサブフォルダーまたは LSC の新しく作成されたサブフォルダーに移動します。

したがって、Outlook のフォルダー構造は次のようになります。

LSC

-LSC_IND_TATA

-LSC_IND_TATA_02

-LSC_xxx_xxx

Function CheckForFolder(strFolder As String) As Boolean

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

On Error Resume Next
Set FolderToCheck = olInbox.Folders(strFolder)
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
    CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)

Set CreateSubFolder = olInbox.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function SearchAndMove(lookFor As String)

Dim olApp As Outlook.Application
Dim olNS As Outlook.NameSpace
Dim olInbox As Outlook.MAPIFolder
Dim FolderToCheck As Outlook.MAPIFolder
Dim myItem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")
Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
 For Each myItem In olInbox.Items
 lookIn = myItem.Subject
 If InStr(lookIn, lookFor) Then
     location = InStr(lookIn, lookFor)
             newName = Mid(lookIn, location)
        If CheckForFolder(newName) = False Then
            Set MyFolder = CreateSubFolder(newName)
            myItem.Move MyFolder
                Else
            Set MyFolder = olInbox.Folders(newName)
            myItem.Move MyFolder
        End If
    End If
Next myItem
End Function

Sub myMacro()
Dim str As String
str = "LSC_"
SearchAndMove (str)
End Sub
4

1 に答える 1

0 
Function CheckForFolder(strFolder As String) As Boolean

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Dim FolderToCheck As Outlook.MAPIFolder

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

On Error Resume Next
Set FolderToCheck = olInbox_Target.Folders(strFolder) ' <---
On Error GoTo 0

If Not FolderToCheck Is Nothing Then
    CheckForFolder = True
End If

ExitProc:
Set FolderToCheck = Nothing
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function CreateSubFolder(strFolder As String) As Outlook.MAPIFolder

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

Set CreateSubFolder = olInbox_Target.Folders.Add(strFolder)

ExitProc:
Set olInbox = Nothing
Set olNS = Nothing
Set olApp = Nothing
End Function

Function SearchAndMove(lookFor As String, myitem As mailItem)

Dim olApp As Outlook.Application
Dim olNS As Outlook.Namespace
'Dim olInbox As Outlook.MAPIFolder

Dim olInbox_Target As Outlook.MAPIFolder ' <---

Dim FolderToCheck As Outlook.MAPIFolder
'Dim myitem As Object
Dim MyFolder As Outlook.MAPIFolder
Dim lookIn As String
Dim newName As String
Dim location As Integer

Set olApp = Outlook.Application
Set olNS = olApp.GetNamespace("MAPI")

'Set olInbox = olNS.GetDefaultFolder(olFolderInbox)
Set olInbox_Target = olNS.GetDefaultFolder(olFolderInbox).Folders("LSC") ' <---

'For Each myItem In olInbox.Items

    lookIn = myitem.Subject

    If InStr(lookIn, lookFor) Then

        location = InStr(lookIn, lookFor)
        newName = Mid(lookIn, location)

        If Right(newName, 1) = "]" Then
            newName = Left(newName, Len(newName) - 1)
        End If

        If CheckForFolder(newName) = False Then
            Set MyFolder = CreateSubFolder(newName)
            myitem.Move MyFolder
        Else
            Set MyFolder = olInbox_Target.Folders(newName)
            myitem.Move MyFolder
        End If

    End If

'Next myItem

End Function

' Choose this in Run a Script
Sub myMacro(itm As mailItem)
Dim str As String
str = "LSC_"
SearchAndMove str, itm
End Sub

' To test
' Manually select an email with an appropriate subject
Sub myMacroTest()
Dim itm As mailItem
Set itm = ActiveExplorer.Selection(1)
myMacro itm
End Sub
于 2013-10-30T01:59:12.990 に答える