Thema Datum  Von Nutzer Rating
Antwort
23.07.2024 09:34:32 Coraline
NotSolved
Blau Makro zur Outlook E-Mail Ablage von 32-Bit in 64-Bit
23.07.2024 10:56:14 volti
NotSolved
23.07.2024 18:57:27 volti
*****
Solved
24.07.2024 06:52:01 Gast95667
NotSolved

Ansicht des Beitrags:
Von:
volti
Datum:
23.07.2024 10:56:14
Views:
140
Rating: Antwort:
  Ja
Thema:
Makro zur Outlook E-Mail Ablage von 32-Bit in 64-Bit

Hallo Caroline,

ja, es stimmt, dass für 64-Bit das Schlüsselwort PtrSafe zu verwenden ist. Zusätzlich müssen jedoch auch alle Handles und Zeiger auf LongLong (64 Bit) oder besser auf LongPtr (32 & 64 Bit VBA 7) umgestellt werden.

 

Hierzu verwendet man am besten einen API-Viewer. Da kannst Du gerne meinen nehmen:

API-Viewer KHV

Aber als Laie wirst Du da wahrscheinlich nicht weiterkommen.

Deshalb habe ich Dir mal in einer ersten Durchsicht und Hauruckversion alles umgestellt, was mir aufgefallen ist, aber noch nicht getestet. Kannst Du ja mal machen.

Falls es nicht funktioniert, helfe ich Dir gern weiter, aber es ist ein Haufen Zeugs und ich kann erst irgendwann später mich damit geschäftigen.

Möglicherweise sind noch Kleinigkeiten drin.

Code:
 
001
002
003
004
005
006
007
008
009
010
011
012
013
014
015
016
017
018
019
020
021
022
023
024
025
026
027
028
029
030
031
032
033
034
035
036
037
038
039
040
041
042
043
044
045
046
047
048
049
050
051
052
053
054
055
056
057
058
059
060
061
062
063
064
065
066
067
068
069
070
071
072
073
074
075
076
077
078
079
080
081
082
083
084
085
086
087
088
089
090
091
092
093
094
095
096
097
098
099
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
 
Option Explicit

' -------------------------------------------------------------
' OPTIONS
' -------------------------------------------------------------
'Email format:
' MSG = Outlook msg format (incl. attachments, embedded objects etc.)., TXT = plain text
Private Const EXM_OPT_MAILFORMAT As String = "MSG"
' Date format of filename
Private Const EXM_OPT_FILENAME_DATEFORMAT As String = "yymmdd_hhnn"
' Build filename; placeholders: <DATE> for date, <SENDER> for sender's name, <RECEIVER> for receiver, <SUBJECT> for subject
Private Const EXM_OPT_FILENAME_BUILD As String = "<DATE>_<SENDER>_<RECEIVER>_<SUBJECT>"
' Maximum number of emails to be selected & exported. Please don't use a huge number as this will cause
' performance and maybe other issues. Recommended is a value between 5 and 20.
Private Const EXM_OPT_MAX_NO As Integer = 10
' Email subject prefixes (such us "RE:", "FW:" etc.) to be removed. Please note that this is a
' RegEx expression, google for "regex" for further information. For instance "\s" means blank " ".
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
' -------------------------------------------------------------


' -------------------------------------------------------------
' TRANSLATIONS
' -------------------------------------------------------------
' -- English
' Const EXM_007 = "Script terminated"
' Const EXM_013 = "Selected Outlook item is not an e-mail"
' Const EXM_014 = "File already exists"
' -- German
Private Const EXM_001 As String = "Die E-Mail wurde erfolgreich abgelegt."
Private Const EXM_002 As String = "Die E-Mail konnte nicht abgelegt werden, Grund:"
Private Const EXM_003 As String = "Ausgewählter Pfad:"
Private Const EXM_004 As String = "E-Mail(s) ausgewählt und erfolgreich abgelegt."
Private Const EXM_005 As String = "<FREE>"
Private Const EXM_006 As String = "<FREE>"
Private Const EXM_007 As String = "Script abgebrochen"
Private Const EXM_008 As String = "Fehler aufgetreten: Sie haben mehr als [LIMIT_SELECTED_ITEMS] E-Mails ausgewählt. Die Aktion wurde beendet."
Private Const EXM_009 As String = "Es wurde keine E-Mail ausgewählt."
Private Const EXM_010 As String = "Es ist ein Fehler aufgetreten: es war keine Email im Fokus, so dass die Ablage nicht erfolgen konnte."
Private Const EXM_011 As String = "Es ist ein Fehler aufgetreten:"
Private Const EXM_012 As String = "Die Aktion wurde beendet."
Private Const EXM_013 As String = "Ausgewähltes Outlook-Dokument ist keine E-Mail"
Private Const EXM_014 As String = "Datei existiert bereits"
Private Const EXM_015 As String = "<FREE>"
Private Const EXM_016 As String = "Bitte wählen Sie den Ordner zum Exportieren:"
Private Const EXM_017 As String = "Fehler beim Exportieren aufgetreten"
Private Const EXM_018 As String = "Export erfolgreich"
Private Const EXM_019 As String = "Bei [NO_OF_FAILURES] E-Mail(s) ist ein Fehler aufgetreten:"
Private Const EXM_020 As String = "[NO_OF_SELECTED_ITEMS] E-Mail(s) wurden ausgewählt und [NO_OF_SUCCESS_ITEMS] E-Mail(s) erfolgreich abgelegt."
Private Const EXM_021 As String = "Speichern der eMail wurde abgebrochen."
' -------------------------------------------------------------

Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dllAlias "GetSaveFileNameA" ( _
        pOpenfilename As OPENFILENAMEAs Long

Type OPENFILENAME
     lStructSize       As Long
     hwndOwner         As LongPtr
     hInstance         As LongPtr
     lpstrFilter       As String
     lpstrCustomFilter As String
     nMaxCustFilter    As Long
     nFilterIndex      As Long
     lpstrFile         As String
     nMaxFile          As Long
     lpstrFileTitle    As String
     nMaxFileTitle     As Long
     lpstrInitialDir   As String
     lpstrTitle        As String
     flags             As Long
     nFileOffset       As Integer
     nFileExtension    As Integer
     lpstrDefExt       As String
     lCustData         As LongPtr
     lpfnHook          As LongPtr
     lpTemplateName    As String
     pvReserved        As LongPtr
     dwReserved        As Long
     FlagsEx           As Long
End Type


Public Const OFN_ALLOWMULTISELECT As Long = &H200&
Public Const OFN_CREATEPROMPT As Long = &H2000&
Public Const OFN_ENABLEHOOK As Long = &H20&
Public Const OFN_ENABLETEMPLATE As Long = &H40&
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80&
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400&
Public Const OFN_FILEMUSTEXIST As Long = &H1000&
Public Const OFN_HIDEREADONLY As Long = &H4&
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8&
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000&
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100&
Public Const OFN_OVERWRITEPROMPT As Long = &H2&
Public Const OFN_PATHMUSTEXIST As Long = &H800&
Public Const OFN_READONLY As Long = &H1&
Public Const OFN_SHAREAWARE As Long = &H4000&
Public Const OFN_SHAREFALLTHROUGH As Long = 2&
Public Const OFN_SHARENOWARN As Long = 1&
Public Const OFN_SHAREWARN As Long = 0&
Public Const OFN_SHOWHELP As Long = &H10&

' -------------------------------------
' For browse folder
' -------------------------------------
Private Declare PtrSafe Function lstrcat Lib "kernel32Alias "lstrcatA" ( _
        ByVal lpString1 As StringByVal lpString2 As StringAs LongPtr
Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32.dllAlias "SHGetPathFromIDListA" ( _
        ByVal pidl As LongPtrByVal pszPath As StringAs Long
Private Declare PtrSafe Function FindWindow Lib "user32Alias "FindWindowA" ( _
        ByVal lpClassName As StringByVal lpWindowName As StringAs LongPtr
Private Declare PtrSafe Function CoTaskMemFree Lib "ole32" ( _
        ByVal hMem As LongPtrAs Long
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 260
Private Declare PtrSafe Function SHBrowseForFolder Lib "Shell32.dllAlias "SHBrowseForFolderA" ( _
        lpBrowseInfo As BROWSEINFOAs LongPtr

Type BROWSEINFO
     hwndOwner      As LongPtr
     pidlRoot       As LongPtr
     pszDisplayName As String
     lpszTitle      As String
     ulFlags        As Long
     lpfn           As LongPtr
     lParam         As LongPtr
     iImage         As Long
End Type


Public Sub ExportEmailToDrive()

  Const PROCNAME As String = "ExportEmailToDrive"

  On Error GoTo ErrorHandler

  Dim myExplorer As Outlook.Explorer
  Dim myfolder As Outlook.MAPIFolder
  Dim myItem As Object
  Dim olSelection As Selection
  Dim strBackupPath As String
  Dim intCountAll As Integer
  Dim intCountFailures As Integer
  Dim strStatusMsg As String
  Dim vSuccess As Variant
  Dim strTemp1 As String
  Dim strTemp2 As String
  Dim strErrorMsg As String

  ' -------------------------------------
  ' Process according to what is in the focus: an opened e-mail or a folder with selected e-mails.
  ' Case 2 would also work for opened e-mail, however it does not always work (for instance if
  ' an e-mail is saved on the file system and being opened from there).
  ' -------------------------------------

  Set myExplorer = Application.ActiveExplorer
  Set myfolder = myExplorer.CurrentFolder
  If myfolder Is Nothing Then Error 5001
  If Not myfolder.DefaultItemType = olMailItem Then GoTo ExitScript

  ' Stop if more than x emails selected
  If myExplorer.Selection.Count > EXM_OPT_MAX_NO Then Error 5002

  ' No email selected at all?
  If myExplorer.Selection.Count = 0 Then Error 5003

  Set olSelection = myExplorer.Selection
  intCountAll = 0
  intCountFailures = 0
  For Each myItem In olSelection
      intCountAll = intCountAll + 1
      vSuccess = ProcessEmail(myItem, strBackupPath)
      If (Not vSuccess = TrueThen
         Select Case intCountFailures
         Case 0: strStatusMsg = vSuccess
         Case 1: strStatusMsg = "1x " & strStatusMsg & Chr(10) & "1x " & vSuccess
         Case Else: strStatusMsg = strStatusMsg & Chr(10) & "1x " & vSuccess
         End Select
         intCountFailures = intCountFailures + 1
      End If
  Next
  If intCountFailures = 0 Then
     strStatusMsg = intCountAll & " " & EXM_004
  End If


  ' Final Message
  If (intCountFailures = 0Then     ' No failure occurred
     MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64EXM_018
  ElseIf (intCountAll = 1Then      ' Only one email was selected and a failure occurred
     MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48EXM_017
  Else       ' More than one email was selected and at least one failure occurred
     strTemp1 = Replace(EXM_020, "[NO_OF_SELECTED_ITEMS]", intCountAll)
     strTemp1 = Replace(strTemp1, "[NO_OF_SUCCESS_ITEMS]", intCountAll - intCountFailures)
     strTemp2 = Replace(EXM_019, "[NO_OF_FAILURES]", intCountFailures)
     MsgBox strTemp1 & Chr(10) & Chr(10) & strTemp2 & Chr(10) & Chr(10) & strStatusMsg _
     & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48EXM_017
  End If


ExitScript:
  Exit Sub
ErrorHandler:
  Select Case Err.Number
  Case 5001:     ' Not an email
      MsgBox EXM_01064EXM_007
  Case 5002:
      MsgBox Replace(EXM_008, "[LIMIT_SELECTED_ITEMS]", EXM_OPT_MAX_NO), 64EXM_007
  Case 5003:
      MsgBox EXM_00964EXM_007
  Case 5004:
      MsgBox EXM_011 & Chr(10) & Chr(10) & strErrorMsg, 48EXM_007
  Case Else:
      MsgBox EXM_011 & Chr(10) & Chr(10) _
      & Err & " - " & Error$ & Chr(10) & Chr(10) & EXM_01248EXM_007
  End Select
  Resume ExitScript
End Sub

Private Function ProcessEmail(myItem As Object, strBackupPath As StringAs Variant
  ' Saves the e-mail on the drive by using the provided path.
  ' Returns TRUE if successful, and FALSE otherwise.

  Const PROCNAME As String = "ProcessEmail"

  On Error GoTo ErrorHandler

  Dim myMailItem As MailItem
  Dim strDate As String
  Dim strSender As String
  Dim strReceiver As String
  Dim strSubject As String
  Dim strFinalFileName As String
  Dim strFullPath As String
  Dim vExtConst As Variant
  Dim vTemp As String
  Dim strErrorMsg As String

  If TypeOf myItem Is MailItem Then
     Set myMailItem = myItem
  Else
     Error 1001
  End If

  ' Set filename
  strDate = Format(myMailItem.ReceivedTime, EXM_OPT_FILENAME_DATEFORMAT)
  strSender = myMailItem.SenderName
  strReceiver = myMailItem.To    ' All receiver, semikolon separated string
  If InStr(strReceiver, ";") > 0 Then strReceiver = Left(strReceiver, InStr(strReceiver, ";") - 1)
  strSubject = myMailItem.Subject
  strFinalFileName = EXM_OPT_FILENAME_BUILD
  strFinalFileName = Replace(strFinalFileName, "<DATE>", strDate)
  strFinalFileName = Replace(strFinalFileName, "<SENDER>", strSender)
  strFinalFileName = Replace(strFinalFileName, "<RECEIVER>", strReceiver)
  strFinalFileName = Replace(strFinalFileName, "<SUBJECT>", strSubject)
  strFinalFileName = CleanString(strFinalFileName)
  If Left(strFinalFileName, 15) = "ERROR_OCCURRED:Then
     strErrorMsg = Mid(strFinalFileName, 169999)
     Error 1003
  End If
  strFinalFileName = IIf(Len(strFinalFileName) > 251Left(strFinalFileName, 251), strFinalFileName)

  ' Show Save-As Dialog here
  Dim Filter As StringFileName As String
  Dim flags As Long

  flags = OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY Or _
  OFN_PATHMUSTEXIST

  Filter$ = "Outlook-Mails (*.msg)" & Chr$(0) & "*.msg" & Chr$(0) & Chr$(0)
  Dim hWnd As LongPtr

  hWnd = FindWindow("rctrl_renwnd32", Application.ActiveExplorer.Caption)

  strFullPath = ShowSave(Filter, flags, hWnd, strBackupPath & strFinalFileName)

  If strFullPath = "" Then
     Error 1004
  End If

  ' Save as msg or txt?
  Select Case UCase(EXM_OPT_MAILFORMAT)
  Case "MSG":
      strFullPath = strFullPath & ".msg"
      vExtConst = olMSG
  Case Else:
      strFullPath = strFullPath & ".txt"
      vExtConst = olTXT
  End Select
  ' File already exists?
  If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
     Error 1002
  End If

  ' Save file
  myMailItem.SaveAs strFullPath, vExtConst

  ' Return true as everything was successful
  ProcessEmail = True

ExitScript:
  Exit Function
ErrorHandler:
  Select Case Err.Number
  Case 1001:     ' Not an email
      ProcessEmail = EXM_013
  Case 1002:
      ProcessEmail = EXM_014
  Case 1003:
      ProcessEmail = strErrorMsg
  Case 1004:
      ProcessEmail = EXM_021
  Case Else:
      ProcessEmail = "Error #" & Err & "" & Error$ & " (Procedure: " & PROCNAME & ")"
  End Select
  Resume ExitScript
End Function

Private Function ShowSave(Filter As String, flags As Long, _
  hWnd As LongPtrFileName As StringAs String

  Dim Buffer As String
  Dim Result As Long
  Dim ComDlgOpenFileName As OPENFILENAME

  Buffer = FileName & String$(2000 - Len(FileName), 0)

  With ComDlgOpenFileName
      .lStructSize = Len(ComDlgOpenFileName)
      .hwndOwner = hWnd
      .flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST
      .nFilterIndex = 1&
      .nMaxFile = Len(Buffer)
      .lpstrFile = Buffer
      .lpstrFilter = Filter
  End With

  Result = GetSaveFileName(ComDlgOpenFileName)

  If Result <> 0 Then
     ShowSave = Left$(ComDlgOpenFileName.lpstrFile, _
     InStr(ComDlgOpenFileName.lpstrFile, _
     Chr$(0)) - 1)
  End If
End Function

Private Function CleanString(strData As StringAs String

  Const PROCNAME As String = "CleanString"

  On Error GoTo ErrorHandler

  ' Instantiate RegEx
  Dim objRegExp As Object

  Set objRegExp = CreateObject("VBScript.RegExp")
  objRegExp.Global = True

  ' Cut out strings we don't like
  objRegExp.Pattern = EXM_OPT_CLEANSUBJECT_REGEX
  strData = objRegExp.Replace(strData, "")

  ' Replace and cut out invalid strings.
  strData = Replace(strData, Chr(9), "_")
  strData = Replace(strData, Chr(10), "_")
  strData = Replace(strData, Chr(13), "_")
  objRegExp.Pattern = "[/\\*]"
  strData = objRegExp.Replace(strData, "-")
  objRegExp.Pattern = "[""]"
  strData = objRegExp.Replace(strData, "'")
  objRegExp.Pattern = "[:?<>\|]"
  strData = objRegExp.Replace(strData, "")

  ' Replace multiple chars by 1 char
  objRegExp.Pattern = "\s+"
  strData = objRegExp.Replace(strData, " ")
  objRegExp.Pattern = "_+"
  strData = objRegExp.Replace(strData, "_")
  objRegExp.Pattern = "-+"
  strData = objRegExp.Replace(strData, "-")
  objRegExp.Pattern = "'+"
  strData = objRegExp.Replace(strData, "'")

  ' Trim
  strData = Trim(strData)

  ' Return result
  CleanString = strData


ExitScript:
  Exit Function
ErrorHandler:
  CleanString = "ERROR_OCCURRED:" & "Error #" & Err & "" & Error$ & " (Procedure: " & PROCNAME & ")"
  Resume ExitScript
End Function

Private Function GetFileDir() As String

  Const PROCNAME As String = "GetFileDir"

  On Error GoTo ErrorHandler

  Dim ret As String
  Dim lpIDList As Long
  Dim sPath As String
  Dim udtBI As BROWSEINFO
  Dim RdStrings() As String
  Dim nNewFiles As Long

  ' Show a browse-for-folder form:
  With udtBI
      .lpszTitle = lstrcat(EXM_016, "")
      .ulFlags = BIF_RETURNONLYFSDIRS
  End With

  lpIDList = SHBrowseForFolder(udtBI)
  If lpIDList = 0 Then Exit Function

  ' Get the selected folder.
  sPath = String$(MAX_PATH0)
  SHGetPathFromIDList lpIDList, sPath
  CoTaskMemFree lpIDList

  ' Strip Nulls
  If (InStr(sPath, Chr$(0)) > 0Then sPath = Left$(sPath, InStr(sPath, Chr(0)) - 1)

  ' Return Dir
  GetFileDir = sPath

ExitScript:
  Exit Function
ErrorHandler:
  GetFileDir = "ERROR_OCCURRED:" & "Error #" & Err & "" & Error$ & " (Procedure: " & PROCNAME & ")"
  Resume ExitScript
End Function
_________
viele Grüße
Karl-Heinz

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:

 
 

  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
23.07.2024 09:34:32 Coraline
NotSolved
Blau Makro zur Outlook E-Mail Ablage von 32-Bit in 64-Bit
23.07.2024 10:56:14 volti
NotSolved
23.07.2024 18:57:27 volti
*****
Solved
24.07.2024 06:52:01 Gast95667
NotSolved