Forum: PC-Programmierung Outlook Skript alle Anhänge herunterladen


Announcement: there is an English version of this forum on EmbDev.net. Posts you create there will be displayed on Mikrocontroller.net and EmbDev.net.
von Lucy in the Sky (Gast)


Lesenswert?

Hallo


Folgendes Skript läd die Anhänge aller Emails herunter in einem 
bestimmten Verzeichnis. Ich möchte das Skripts so abändern, dass bei 
bereits vorhandenem Dateinamen die neue zu speichernde Datei mit einer 
fortlaufenden Nummer ergänzt wird. Kann mir vielelicht jemand helfen?
1
'---------------------------------------------------------------------------------
2
' The sample scripts are not supported under any Microsoft standard support
3
' program or service. The sample scripts are provided AS IS without warranty
4
' of any kind. Microsoft further disclaims all implied warranties including,
5
' without limitation, any implied warranties of merchantability or of fitness for
6
' a particular purpose. The entire risk arising out of the use or performance of
7
' the sample scripts and documentation remains with you. In no event shall
8
' Microsoft, its authors, or anyone else involved in the creation, production, or
9
' delivery of the scripts be liable for any damages whatsoever (including,
10
' without limitation, damages for loss of business profits, business interruption,
11
' loss of business information, or other pecuniary loss) arising out of the use
12
' of or inability to use the sample scripts or documentation, even if Microsoft
13
' has been advised of the possibility of such damages.
14
'---------------------------------------------------------------------------------
15
16
Option Explicit
17
18
' *****************
19
' For Outlook 2010.
20
' *****************
21
#If VBA7 Then
22
    ' The window handle of Outlook.
23
    Private lHwnd As LongPtr
24
    
25
    ' /* API declarations. */
26
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
27
        ByVal lpWindowName As String) As LongPtr
28
    
29
' *****************************************
30
' For the previous version of Outlook 2010.
31
' *****************************************
32
#Else
33
    ' The window handle of Outlook.
34
    Private lHwnd As Long
35
    
36
    ' /* API declarations. */
37
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
38
        ByVal lpWindowName As String) As Long
39
#End If
40
41
' The class name of Outlook window.
42
Private Const olAppCLSN As String = "rctrl_renwnd32"
43
' Windows desktop - the virtual folder that is the root of the namespace.
44
Private Const CSIDL_DESKTOP = &H0
45
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.
46
Private Const BIF_RETURNONLYFSDIRS = &H1
47
' Do not include network folders below the domain level in the dialog box's tree view control.
48
Private Const BIF_DONTGOBELOWDOMAIN = &H2
49
' The maximum length for a path is 260 characters.
50
Private Const MAX_PATH = 260
51
52
' ######################################################
53
'  Returns the number of attachements in the selection.
54
' ######################################################
55
Public Function SaveAttachmentsFromSelection() As Long
56
    Dim objFSO              As Object       ' Computer's file system object.
57
    Dim objShell            As Object       ' Windows Shell application object.
58
    Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.
59
    Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.
60
    Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.
61
    Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.
62
    Dim strAtmtPath         As String       ' The full saving path of the attachment.
63
    Dim strAtmtFullName     As String       ' The full name of an attachment.
64
    Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
65
    Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.
66
    Dim intDotPosition      As Integer      ' The dot position in an attachment name.
67
    Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.
68
    Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.
69
    Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.
70
    Dim strFolderPath       As String       ' The selected folder path.
71
    Dim blnIsEnd            As Boolean      ' End all code execution.
72
    Dim blnIsSave           As Boolean      ' Consider if it is need to save.
73
    
74
    blnIsEnd = False
75
    blnIsSave = False
76
    lCountAllItems = 0
77
    
78
    On Error Resume Next
79
    
80
    Set selItems = ActiveExplorer.Selection
81
    
82
    If Err.Number = 0 Then
83
        
84
        ' Get the handle of Outlook window.
85
        lHwnd = FindWindow(olAppCLSN, vbNullString)
86
        
87
        If lHwnd <> 0 Then
88
            
89
            ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
90
            Set objShell = CreateObject("Shell.Application")
91
            Set objFSO = CreateObject("Scripting.FileSystemObject")
92
            Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
93
                                                     BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
94
            
95
            ' /* Failed to create the Shell application. */
96
            If Err.Number <> 0 Then
97
                MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
98
                       Err.Description & ".", vbCritical, "Error from Attachment Saver"
99
                blnIsEnd = True
100
                GoTo PROC_EXIT
101
            End If
102
            
103
            If objFolder Is Nothing Then
104
                strFolderPath = ""
105
                blnIsEnd = True
106
                GoTo PROC_EXIT
107
            Else
108
                strFolderPath = CGPath(objFolder.Self.Path)
109
                
110
                ' /* Go through each item in the selection. */
111
                For Each objItem In selItems
112
                    lCountEachItem = objItem.Attachments.Count
113
                    
114
                    ' /* If the current item contains attachments. */
115
                    If lCountEachItem > 0 Then
116
                        Set atmts = objItem.Attachments
117
                        
118
                        ' /* Go through each attachment in the current item. */
119
                        For Each atmt In atmts
120
                            
121
                            ' Get the full name of the current attachment.
122
                            strAtmtFullName = atmt.FileName
123
                            
124
                            ' Find the dot postion in atmtFullName.
125
                            intDotPosition = InStrRev(strAtmtFullName, ".")
126
                            
127
                            ' Get the name.
128
                            strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
129
                            ' Get the file extension.
130
                            strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
131
                            ' Get the full saving path of the current attachment.
132
                            strAtmtPath = strFolderPath & atmt.FileName
133
                            
134
                            ' /* If the length of the saving path is not larger than 260 characters.*/
135
                            If Len(strAtmtPath) <= MAX_PATH Then
136
                                ' True: This attachment can be saved.
137
                                blnIsSave = True
138
                                
139
                                ' /* Loop until getting the file name which does not exist in the folder. */
140
                                Do While objFSO.FileExists(strAtmtPath)
141
                                    strAtmtNameTemp = strAtmtName(0) & _
142
                                                      Format(Now, "_mmddhhmmss") & _
143
                                                      Format(Timer * 1000 Mod 1000, "000")
144
                                    strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
145
                                        
146
                                    ' /* If the length of the saving path is over 260 characters.*/
147
                                    If Len(strAtmtPath) > MAX_PATH Then
148
                                        lCountEachItem = lCountEachItem - 1
149
                                        ' False: This attachment cannot be saved.
150
                                        blnIsSave = False
151
                                        Exit Do
152
                                    End If
153
                                Loop
154
                                
155
                                ' /* Save the current attachment if it is a valid file name. */
156
                                If blnIsSave Then atmt.SaveAsFile strAtmtPath
157
                            Else
158
                                lCountEachItem = lCountEachItem - 1
159
                            End If
160
                        Next
161
                    End If
162
                    
163
                    ' Count the number of attachments in all Outlook items.
164
                    lCountAllItems = lCountAllItems + lCountEachItem
165
                Next
166
            End If
167
        Else
168
            MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
169
            blnIsEnd = True
170
            GoTo PROC_EXIT
171
        End If
172
        
173
    ' /* For run-time error:
174
    '    The Explorer has been closed and cannot be used for further operations.
175
    '    Review your code and restart Outlook. */
176
    Else
177
        MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
178
        blnIsEnd = True
179
    End If
180
    
181
PROC_EXIT:
182
    SaveAttachmentsFromSelection = lCountAllItems
183
    
184
    ' /* Release memory. */
185
    If Not (objFSO Is Nothing) Then Set objFSO = Nothing
186
    If Not (objItem Is Nothing) Then Set objItem = Nothing
187
    If Not (selItems Is Nothing) Then Set selItems = Nothing
188
    If Not (atmt Is Nothing) Then Set atmt = Nothing
189
    If Not (atmts Is Nothing) Then Set atmts = Nothing
190
    
191
    ' /* End all code execution if the value of blnIsEnd is True. */
192
    If blnIsEnd Then End
193
End Function
194
195
' #####################
196
' Convert general path.
197
' #####################
198
Public Function CGPath(ByVal Path As String) As String
199
    If Right(Path, 1) <> "\" Then Path = Path & "\"
200
    CGPath = Path
201
End Function
202
203
' ######################################
204
' Run this macro for saving attachments.
205
' ######################################
206
Public Sub ExecuteSaving()
207
    Dim lNum As Long
208
    
209
    lNum = SaveAttachmentsFromSelection
210
    
211
    If lNum > 0 Then
212
        MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
213
    Else
214
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
215
    End If
216
End Sub

Antwort schreiben

Die Angabe einer E-Mail-Adresse ist freiwillig. Wenn Sie automatisch per E-Mail über Antworten auf Ihren Beitrag informiert werden möchten, melden Sie sich bitte an.

Wichtige Regeln - erst lesen, dann posten!

  • Groß- und Kleinschreibung verwenden
  • Längeren Sourcecode nicht im Text einfügen, sondern als Dateianhang

Formatierung (mehr Informationen...)

  • [c]C-Code[/c]
  • [code]Code in anderen Sprachen, ASCII-Zeichnungen[/code]
  • [math]Formel in LaTeX-Syntax[/math]
  • [[Titel]] - Link zu Artikel
  • Verweis auf anderen Beitrag einfügen: Rechtsklick auf Beitragstitel,
    "Adresse kopieren", und in den Text einfügen




Bild automatisch verkleinern, falls nötig
Bitte das JPG-Format nur für Fotos und Scans verwenden!
Zeichnungen und Screenshots im PNG- oder
GIF-Format hochladen. Siehe Bildformate.
Hinweis: der ursprüngliche Beitrag ist mehr als 6 Monate alt.
Bitte hier nur auf die ursprüngliche Frage antworten,
für neue Fragen einen neuen Beitrag erstellen.

Mit dem Abschicken bestätigst du, die Nutzungsbedingungen anzuerkennen.