将附件分类到不同的文件夹中

时间：2014-06-11 14:32:45

标签： vba outlook

我更新了我从朋友处收到的（工作）宏（此宏将附件分类到不同的文件夹中）更新与SaveAttachment Procedure中的select-case块相关。我想将附件保存到两个不同的路径 - PATH和PATH2，具体取决于文件夹。对于TargetFolderItemsAA和TargetFolderItemsAB，将有PATH2，其余为PATH。有谁知道，代码有什么问题（发生错误）？感谢您的帮助。

Option Explicit

 '###############################################################################
 '### Module level Declarations
 'expose the items in the target folder to events

 'MASTS
Dim WithEvents TargetFolderItemsG As Items
Dim WithEvents TargetFolderItemsK As Items
Dim WithEvents TargetFolderItemsL As Items
Dim WithEvents TargetFolderItemsM As Items
Dim WithEvents TargetFolderItemsN As Items
Dim WithEvents TargetFolderItemsO As Items
Dim WithEvents TargetFolderItemsP As Items
Dim WithEvents TargetFolderItemsQ As Items
Dim WithEvents TargetFolderItemsR As Items
Dim WithEvents TargetFolderItemsT As Items
Dim WithEvents TargetFolderItemsU As Items
Dim WithEvents TargetFolderItemsV As Items
Dim WithEvents TargetFolderItemsW As Items

 'ENERGY SALE
Dim WithEvents TargetFolderItemsAA As Items
Dim WithEvents TargetFolderItemsAB As Items


Const FILE_PATH As String = "Z:\Wind_datas\"
Const FILE_PATH2 As String = "Z:\Projects\"




 '###############################################################################
 '### this is the Application_Startup event code in the ThisOutlookSession module



Private Sub Application_Startup()
     'some startup code to set our "event-sensitive" items collection
    Dim ns As Outlook.NameSpace
     '
    Set ns = Application.GetNamespace("MAPI")

     'MASTS
    Set TargetFolderItemsG = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Grajewo").Items
    Set TargetFolderItemsK = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Czyzew").Items
    Set TargetFolderItemsL = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Annopol").Items
    Set TargetFolderItemsM = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Wloszczowa").Items
    Set TargetFolderItemsN = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Grajewo_100m").Items
    Set TargetFolderItemsO = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Bialogard").Items
    Set TargetFolderItemsP = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Krasnik").Items
    Set TargetFolderItemsQ = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Suraz").Items
    Set TargetFolderItemsR = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Bejsce").Items
    Set TargetFolderItemsT = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Malogoszcz").Items
    Set TargetFolderItemsU = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Odolanow").Items
    Set TargetFolderItemsV = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Frampol").Items
    Set TargetFolderItemsW = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Zaklikow").Items

     'ENERGY SALE
    Set TargetFolderItemsAA = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("Sprzedaz energii Bialogard").Folders("Alpiq - grafiki dla Energa").Items
    Set TargetFolderItemsAB = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("Sprzedaz energii Bialogard").Folders("WH prognoza n-1").Items

End Sub



'MASTS & ENERGY SALE

Sub SaveAttachment(ByVal Prefix As String, ByVal Item As Object)
     'when a new item is added to our "watched folder" we can process it
    Dim olAtt As Attachment
    Dim i As Integer

    Select Case Item
        Case TargetFolderItemsAA, TargetFolderItemsAB
                If Item.Attachments.Count > 0 Then
                    For i = 1 To Item.Attachments.Count
                        Set olAtt = Item.Attachments(i)
                         'save the attachment
                        olAtt.SaveAsFile FILE_PATH2 & Prefix & "\daily_files\" & olAtt.FileName
                    Next
                End If
        Case Else
                If Item.Attachments.Count > 0 Then
                    For i = 1 To Item.Attachments.Count
                        Set olAtt = Item.Attachments(i)
                         'save the attachment
                        olAtt.SaveAsFile FILE_PATH & Prefix & "\daily_files\" & olAtt.FileName
                    Next
                End If
    End Select

    Set olAtt = Nothing
End Sub

 '###############################################################################
 '### this is the ItemAdd event code

 'MASTS
Sub TargetFolderItemsG_ItemAdd(ByVal Item As Object)
    SaveAttachment "Grajewo", Item
End Sub

Sub TargetFolderItemsK_ItemAdd(ByVal Item As Object)
    SaveAttachment "Czyzew", Item
End Sub

Sub TargetFolderItemsL_ItemAdd(ByVal Item As Object)
    SaveAttachment "Annopol", Item
End Sub

Sub TargetFolderItemsM_ItemAdd(ByVal Item As Object)
    SaveAttachment "Wloszczowa", Item
End Sub

Sub TargetFolderItemsN_ItemAdd(ByVal Item As Object)
    SaveAttachment "grajewo_100m", Item
End Sub

Sub TargetFolderItemsO_ItemAdd(ByVal Item As Object)
    SaveAttachment "Bialogard", Item
End Sub

Sub TargetFolderItemsP_ItemAdd(ByVal Item As Object)
    SaveAttachment "Krasnik", Item
End Sub

Sub TargetFolderItemsQ_ItemAdd(ByVal Item As Object)
    SaveAttachment "Suraz", Item
End Sub

Sub TargetFolderItemsR_ItemAdd(ByVal Item As Object)
    SaveAttachment "Bejsce", Item
End Sub

Sub TargetFolderItemsT_ItemAdd(ByVal Item As Object)
    SaveAttachment "Malogoszcz", Item
End Sub

Sub TargetFolderItemsU_ItemAdd(ByVal Item As Object)
    SaveAttachment "Odolanow", Item
End Sub

Sub TargetFolderItemsV_ItemAdd(ByVal Item As Object)
    SaveAttachment "Frampol", Item
End Sub

Sub TargetFolderItemsW_ItemAdd(ByVal Item As Object)
    SaveAttachment "Zaklikow", Item
End Sub

'ENERGY SALE
Sub TargetFolderItemsAA_ItemAdd(ByVal Item As Object)
    SaveAttachment "01_PKD_do_Energa", Item
End Sub

Sub TargetFolderItemsAB_ItemAdd(ByVal Item As Object)
    SaveAttachment "03_Prognozy_WH_n-1", Item
End Sub

 '###############################################################################
 '### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()

    Dim ns As Outlook.NameSpace
    Set TargetFolderItemsG = Nothing
    Set TargetFolderItemsK = Nothing
    Set TargetFolderItemsL = Nothing
    Set TargetFolderItemsM = Nothing
    Set TargetFolderItemsN = Nothing
    Set TargetFolderItemsO = Nothing
    Set TargetFolderItemsP = Nothing
    Set TargetFolderItemsQ = Nothing
    Set TargetFolderItemsR = Nothing
    Set TargetFolderItemsT = Nothing
    Set TargetFolderItemsU = Nothing
    Set TargetFolderItemsV = Nothing
    Set TargetFolderItemsW = Nothing
    Set TargetFolderItemsAA = Nothing
    Set TargetFolderItemsAB = Nothing

    Set ns = Nothing

End Sub

1 个答案:

答案 0 :(得分：0)

您不能在对象上使用select子句。它应该是文件夹路径上的选择吗？您需要将它作为另一个参数传递给SaveAttachment。

Option Explicit

 '###############################################################################
 '### Module level Declarations
 'expose the items in the target folder to events

 'MASTS
Dim WithEvents TargetFolderItemsG As Items
Dim WithEvents TargetFolderItemsK As Items
Dim WithEvents TargetFolderItemsL As Items
Dim WithEvents TargetFolderItemsM As Items
Dim WithEvents TargetFolderItemsN As Items
Dim WithEvents TargetFolderItemsO As Items
Dim WithEvents TargetFolderItemsP As Items
Dim WithEvents TargetFolderItemsQ As Items
Dim WithEvents TargetFolderItemsR As Items
Dim WithEvents TargetFolderItemsT As Items
Dim WithEvents TargetFolderItemsU As Items
Dim WithEvents TargetFolderItemsV As Items
Dim WithEvents TargetFolderItemsW As Items

 'ENERGY SALE
Dim WithEvents TargetFolderItemsAA As Items
Dim WithEvents TargetFolderItemsAB As Items


Const FILE_PATH As String = "Z:\Wind_datas\"
Const FILE_PATH2 As String = "Z:\Projects\"




 '###############################################################################
 '### this is the Application_Startup event code in the ThisOutlookSession module



Private Sub Application_Startup()
     'some startup code to set our "event-sensitive" items collection
    Dim ns As Outlook.NameSpace
     '
    Set ns = Application.GetNamespace("MAPI")

     'MASTS
    Set TargetFolderItemsG = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Grajewo").Items
    Set TargetFolderItemsK = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Czyzew").Items
    Set TargetFolderItemsL = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Annopol").Items
    Set TargetFolderItemsM = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Wloszczowa").Items
    Set TargetFolderItemsN = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Grajewo_100m").Items
    Set TargetFolderItemsO = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Bialogard").Items
    Set TargetFolderItemsP = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Krasnik").Items
    Set TargetFolderItemsQ = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Suraz").Items
    Set TargetFolderItemsR = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Bejsce").Items
    Set TargetFolderItemsT = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Malogoszcz").Items
    Set TargetFolderItemsU = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Odolanow").Items
    Set TargetFolderItemsV = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Frampol").Items
    Set TargetFolderItemsW = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("maszty").Folders("datas_Zaklikow").Items

     'ENERGY SALE
    Set TargetFolderItemsAA = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("Sprzedaz energii Bialogard").Folders("Alpiq - grafiki dla Energa").Items
    Set TargetFolderItemsAB = ns.Folders.Item("Zimbra - TB").Folders.Item("Inbox").Folders("Sprzedaz energii Bialogard").Folders("WH prognoza n-1").Items

End Sub



'MASTS & ENERGY SALE

Sub SaveAttachment(ByVal Path As String, ByVal Prefix As String, ByVal Item As Object)
     'when a new item is added to our "watched folder" we can process it
    Dim olAtt As Attachment
    Dim i As Integer
    If Item.Attachments.Count > 0 Then
      For i = 1 To Item.Attachments.Count
        Set olAtt = Item.Attachments(i)
        'save the attachment
        olAtt.SaveAsFile Path & Prefix & "\daily_files\" & olAtt.FileName
      Next
    End If  
End Sub

 '###############################################################################
 '### this is the ItemAdd event code

 'MASTS
Sub TargetFolderItemsG_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Grajewo", Item
End Sub

Sub TargetFolderItemsK_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Czyzew", Item
End Sub

Sub TargetFolderItemsL_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Annopol", Item
End Sub

Sub TargetFolderItemsM_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Wloszczowa", Item
End Sub

Sub TargetFolderItemsN_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "grajewo_100m", Item
End Sub

Sub TargetFolderItemsO_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Bialogard", Item
End Sub

Sub TargetFolderItemsP_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Krasnik", Item
End Sub

Sub TargetFolderItemsQ_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Suraz", Item
End Sub

Sub TargetFolderItemsR_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Bejsce", Item
End Sub

Sub TargetFolderItemsT_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Malogoszcz", Item
End Sub

Sub TargetFolderItemsU_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Odolanow", Item
End Sub

Sub TargetFolderItemsV_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Frampol", Item
End Sub

Sub TargetFolderItemsW_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH, "Zaklikow", Item
End Sub

'ENERGY SALE
Sub TargetFolderItemsAA_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH2, "01_PKD_do_Energa", Item
End Sub

Sub TargetFolderItemsAB_ItemAdd(ByVal Item As Object)
    SaveAttachment FILE_PATH2, "03_Prognozy_WH_n-1", Item
End Sub

 '###############################################################################
 '### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()

    Dim ns As Outlook.NameSpace
    Set TargetFolderItemsG = Nothing
    Set TargetFolderItemsK = Nothing
    Set TargetFolderItemsL = Nothing
    Set TargetFolderItemsM = Nothing
    Set TargetFolderItemsN = Nothing
    Set TargetFolderItemsO = Nothing
    Set TargetFolderItemsP = Nothing
    Set TargetFolderItemsQ = Nothing
    Set TargetFolderItemsR = Nothing
    Set TargetFolderItemsT = Nothing
    Set TargetFolderItemsU = Nothing
    Set TargetFolderItemsV = Nothing
    Set TargetFolderItemsW = Nothing
    Set TargetFolderItemsAA = Nothing
    Set TargetFolderItemsAB = Nothing

    Set ns = Nothing

End Sub
相关问题
最新问题