Makro von 32bit auf 64bit umschreiben

Moderator: ModerationP

Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 21. Aug 2019, 15:07

Liebes Forum

Ich nutze ein Makro von Michael Wöhrer, welches mir erlaubt Mails auf einem internen Laufwerk abzuspeichern. Ich kenn mich leider absolut nicht mit der Programmierung aus, und kann daher nur rudimentäre Eigenschaften am Makro ändern. Nun haben wir das 64bit System aufgespielt bekommen und das Makro läuft nicht mehr. Ich weiss jetzt nicht wie gross der Aufwand ist. Falls jemand von euch mir helfen kann, wäre das super!!

Fehlermeldung: Code muss überarbeitet werden. AAktualisieren sie die Declare-Anweisung und markieren sie sie mit dem PtrSafe-Attribute

Dann wird diese Zeile angesteuert: Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _


Besten Dank

'==========================================================================
'Export Outlook e-mail to drive
'--------------------------------------------------------------------------
'Original von 'Author: Michael Wöhrer 'Version: 0.2, 2009-01-20
'umgeschrieben und erweitert von Hanners
'==========================================================================
'Terms and conditions
' You can use, redistribute and/or modify this code under the terms of
' the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it
' will be useful, but WITHOUT ANY WARRANTY; without even the implied
' warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
' See the SOFTWARE GUIDE LICENSE for more details.
'==========================================================================

Option Explicit

'-------------------------------------------------------------
' OPTIONS Hier die Einstellung für die Funktion vornehmen
'-------------------------------------------------------------
'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 = "yyyy-mm-dd "
'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> - <SUBJECT>"
'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
Private Const EXM_OPT_USEBROWSER As Boolean = True
'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE) und Voreinstellung für Ordnerauswahlfenster
Private Const EXM_OPT_TARGETFOLDER As String = "N:\
'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 = 3000
'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 " ". Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
'Final Message (Mitteilung wieviele Dateien gespeichert wurden) gewünscht = 1, nicht gewünscht =0
Private Const finalmessage As Integer = 0
'Datei nach Export in Ordner gelöschte Elemente schieben? ja= ture nein=false
Private Const loeschen As Boolean = 1
'Explorer öffnen mit Dateipfad des Speicherorts? set true. Otherwise false
Private Const explorer_oeffnen As Boolean = False


'-------------------------------------------------------------
' TRANSLATIONS
'-------------------------------------------------------------

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."
'-------------------------------------------------------------


'-------------------------------------
'For browse folder; hier werden die Funktionen & Variablen für Fensteraufruf definiert
'-------------------------------------
Public DateiSpeichernAlsName As String 'Loeschen

Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(lpofn As OPENFILENAME) As Long

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long

Public A$
Public Const HandCursor = 32649&
Public Const OFN_EXTENSIONDIFFERENT = &H400&
Public Const OFN_PATHMUSTEXIST = &H800
Public NeuProfil As String

Type OPENFILENAME
lStructSize As Long
hWndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustomFilter 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
nFilextension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type


' *** Hauptmakro Anfang ***
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 vSuccess2 As Variant
Dim strTemp1 As String
Dim strTemp2 As String
Dim strErrorMsg As String

'-------------------------------------
'Get target drive
'-------------------------------------
If (EXM_OPT_USEBROWSER = True) Then
strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT) 'ruft Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
strErrorMsg = Mid(strBackupPath, 16, 9999)
Error 5004
End If
Else
strBackupPath = EXM_OPT_TARGETFOLDER
End If
If strBackupPath = "" Then GoTo ExitScript
If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"



'-------------------------------------
'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) 'ruft Funktion "ProcessEmail" auf und gibt Wert 1 zurück
'setzt Attribute der Datei
If (Not vSuccess = True) Then
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 (finalmessage = 1) Then 'Message Ein- Ausschalten
If (intCountFailures = 0) Then 'No failure occurred
MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
ElseIf (intCountAll = 1) Then 'Only one email was selected and a failure occurred
MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_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, 48, EXM_017
End If
End If


'Datei in Ordner "Gelöschte Elemente" verschieben
If (loeschen = False) Then
On Error Resume Next

Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

Set objNS = Application.GetNamespace("MAPI")
Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")

If objFolder Is Nothing Then
MsgBox "Dieser Ordner existiert nicht!", vbOKOnly + vbExclamation, "Fehler"
End If

If Application.ActiveExplorer.Selection.Count = 0 Then
Exit Sub
End If

For Each objItem In Application.ActiveExplorer.Selection
objItem.UnRead = False 'Email in Outlook wird als gelesen markieren
If objFolder.DefaultItemType = olMailItem Then
If objItem.Class = olMail Then
objItem.Move objFolder 'Datei wird verschoben
End If
End If
Next

Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End If
'Ende der Datei Verschieben

'Explorer öffnen
If (explorer_oeffnen = True) Then
Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
Else
End If


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

Private Function ProcessEmail(myItem As Object, strBackupPath As String) As 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
Dim success As Variant


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, 16, 9999)
Error 1003
End If
strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
strFullPath = strBackupPath & strFinalFileName

'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 'hier wird die Datei erzeugt: .SaveAs strFullPath = Pfad&Name; vExtConst=Dateityp

'setzt Attribute der Datei
success = AttributeSetzen(strFullPath, strSender, strReceiver, strSubject)

'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 Else:
ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
End Select
Resume ExitScript
End Function



Private Function CleanString(strData As String) As 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

'************************************************** Hohlt Pfad über Eingabefenster

Private Function getfiledir(saveAspath As String, DateiEndung As String) As String

Const PROCNAME As String = "GetFileDir"
On Error GoTo ErrorHandler


Dim DateiName As String
Dim FilterName As String
Dim SpeichernAls As OPENFILENAME
Dim ExistiertDatei
Dim i As Integer

DateiName = "Neu1"
FilterName = "outlook"
DateiEndung = "*." & DateiEndung


With SpeichernAls
.lStructSize = Len(SpeichernAls)
.hWndOwner = FindWindow("XLMAIN", "Outlook")
.hInstance = GetModuleHandle("Outlook.EXE")
.lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & vbNullChar
.lpstrCustomFilter = vbNullString
.nFilterIndex = 1
DateiName = Replace(DateiName, ":", "")
.lpstrFile = DateiName & Space(255) & vbNullChar
.nMaxFile = Len(.lpstrFile)
.lpstrFileTitle = Len(.lpstrFileTitle)
.lpstrInitialDir = saveAspath
.lpstrTitle = "Email speichern"
.flags = OFN_EXTENSIONDIFFERENT
End With

If GetSaveFileName(SpeichernAls) = 0 Then 'Funktion mit Übergabevariable wird aufgerufen; = als übergabewert ist Abbruchbedingung
getfiledir = ""
GoTo ErrorHandler
End If

getfiledir = SpeichernAls.lpstrFile
getfiledir = Left(getfiledir, InStr(1, getfiledir, "Neu1") - 1)
'getfiledir = Right(getfiledir, InStrRev(getfiledir, "\"))
'Right(getfiledir, 3) <> DateiEndung Then DateiSpeichernAlsName = DateiSpeichernAlsName & DateiEndung
'MsgBox (getfiledir)

'Wenn Datei Name mit abgespeichert werden soll, hier nicht der Fall, nur der Pfad wird benötigt
'On Error Resume Next
'ExistiertDatei = Not CBool(GetAttr(datei) And (vbVolume))
'On Error GoTo 0
'If datei = "Falsch" Then Exit Function
'If ExistiertDatei Then
' If MsgBox("Diese Datei existiert schon!" & vbCrLf & _
' "Möchten Sie sie überschreiben?", vbYesNo, "Datei existiert schon!") = vbNo Then
' MsgBox "Datei wurde nicht exportiert", vbInformation, "Abgebrochen"
' Exit Function
' End If
'End If

'DateiSpeichernAlsName = SpeichernAls.lpstrFile

'DateiSpeichernAlsName = DateiSpeichernAlsName

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


End Function

Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, Betreff As String)

Const PROCNAME As String = "AttributeSetzen"

Dim objFilePropReader As Object
Dim objDocProp As Object
On Error Resume Next
Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
objFilePropReader.Open DateiPfad
Set objDocProp = objFilePropReader.summaryproperties
Debug.Print objDocProp.Title
'With objFilePropReader
' .IsReadOnly = "true" '?
' .oledocumentformat = "oledoc" '?
' End With

'vbhidden

With objDocProp
.Author = Sender 'Autoren
'.Category = "category" '
'.Comments = "comments" 'Kommentare
'.DataCreated = "Datacreated" '?
.Keywords = Empfaenger 'Markierungen
'.Manager = "Manager"
'.Subject = "Subject" 'Thema
.Title = Betreff 'Titel

End With

objFilePropReader.Save
objFilePropReader.Close
Set objDocProp = Nothing

AttributeSetzen = 1
End Function



katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon hddiesel » 21. Aug 2019, 18:13

Hallo katutcho,

Deklariere diesen nur 32-Bit Teil
Code: Alles auswählen
Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
(lpofn As OPENFILENAME) As Long

Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
(ByVal lpModuleName As String) As Long

Flexiebel In 32-Bit und 64-Bit, sollte dann auf beiden Systemen laufen.
Code: Alles auswählen
#If VBA7 And Win64 Then
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As LongPtr

    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

    Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As LongPtr
#Else
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As Long

    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As Long
#End If

Eventuell auch einmal Private Declare, statt nur Declare verwenden.
Schau auch einmal im VBA-Editor, unter Extras/ Verweise..., was noch an Häkchen fehlt.
Mit freundlichen Grüssen
Karl


BS: Windows 10_64-Bit, MS Office Professional Plus 2016_32-Bit
Benutzeravatar
hddiesel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 3783
Registriert: 17. Feb 2006, 11:40
Wohnort: Deutschland

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 21. Aug 2019, 18:46

@hddiesel:
Ganz so einfach dürfte es nicht gehen, weil auch noch die benutzerdefinierten Typen wie z.B. OPENFILENAME, berücksichtigt und ggf. umgesetzt werden müssen. Längenzuweisungen im Sourcecode, wie z.B. Len und LenB, sollten auf jeden Fall auch noch überprüft werden.

Ein paar vorgefertigte Lösungen findet man hier:https://www.jkp-ads.com/Articles/apideclarations.asp

Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 22. Aug 2019, 07:49

Guten Morgen

Danke für die Hilfe. Leider kommt bereits die nächste Fehlermeldung, nach dem Ersetzen des von hddiesel angegebenen Code.

Fehler: Typen unverträglich ==> FindWindow
Zeile: hWndOwner = FindWindow ("XLMAIN", "Outlook")

Wenn das jetzt immer so weiter geht, von Zeile zu Zeile, ist es besser das Thema sein zu lassen, da ich sonst immer hier nachfragen muss. Ich kenn mich da leider "0" aus, Grüsse

Folgende Häckchen sind gesetzt:

Verweise.PNG
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon hddiesel » 23. Aug 2019, 10:47

Hallo katutcho,

alle Variablen, welche nicht verarbeitet werden, delarierst du statt As Long(Bit-32), in As LongPtr(Bit-64)
Klar könnten wir dir den CODE voll in 64-Bit umschreiben, aber dann lernst du nichts dabei.

Hangel dich von Fehlermeldung zur Fehlermeldung und ändere die Variablen As Long, in As LongPtr,
wenn du dann noch Probleme hast, dann kannst du deinen kompletten CODE nochmals Posten, aber so dass man ihn auch lesen kann.

Dazu klickst du vor dem einfügen hier im Forums- Editor auf den Button CODE, anschließend die Tastenkombination Strg + V drücken,
dann wird dein Code zwischen die Markierung eingefügt, dann kannst du bei klick auf Vorschau, deinen CODE vernünftig lesen.

z.B. so, nach klick vor dem einfügen deines CODE, auf den Button CODE:
Code: Alles auswählen
Das ist dann dein eingefügter Code.

und nicht so, wie vor dem einfügen deines CODE, mit klick auf den Button Quote:
Das is nicht die richtige Wahl, für deinen eingefügten Code.

und du wirst sehen, die Spezies hier im Forum helfen dir dann auch gerne weiter,
siehe Ulrich hat dir ja schon aufgezeigt, wie man das am Ende, für 32-Bit und 64-Bit tauglich lösen kann.
Selbst arbeite ich sehr selten mit Outlook und VBA in Outlook so gut wie Nichts.
Mit freundlichen Grüssen
Karl


BS: Windows 10_64-Bit, MS Office Professional Plus 2016_32-Bit
Benutzeravatar
hddiesel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 3783
Registriert: 17. Feb 2006, 11:40
Wohnort: Deutschland

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Gast » 28. Aug 2019, 14:57

Hallo

Ich habe die entsprechenden Fehlermeldungen in AsLongPtr abgeändert. Nun kommt diese Fehlermeldung:

Error 20: Resume ohne Fehler (Procedure: GetFileDir)

Grüsse
Katutcho
Gast
 

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 29. Aug 2019, 01:10

Hallo,

dann hast du offensichtlich etwa in der Funktion GetFileDir zuviel gelöscht.
Btw. AsLongPtr wind getrennt geschieben: As LongPtr

Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 29. Aug 2019, 13:31

Die angezeigten Fehler hatte ich in As LongPtr umgeschrieben. Nur im Post falsch geschrieben.

Gelöscht habe ich nur den von hddiesel in Post 2 angezeigten 32 bit Teil und dann durch den 32 bit und 64 bit Teil ersetzt.

Der von mir korrigierte Code ist nun:
Code: Alles auswählen
'==========================================================================
 'Export Outlook e-mail to drive
 '--------------------------------------------------------------------------
 'Original von 'Author: Michael Wöhrer 'Version: 0.2, 2009-01-20
 'umgeschrieben und erweitert von Hanners
 '==========================================================================
 'Terms and conditions
 '  You can use, redistribute and/or modify this code under the terms of
 '  the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it
 '  will be useful, but WITHOUT ANY WARRANTY; without even the implied
 '  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 '  See the SOFTWARE GUIDE LICENSE for more details.
 '==========================================================================

 Option Explicit

 '-------------------------------------------------------------
 ' OPTIONS Hier die Einstellung für die Funktion vornehmen
 '-------------------------------------------------------------
 '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 = "yyyy-mm-dd "
 '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> - <SUBJECT>"
 'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
 Private Const EXM_OPT_USEBROWSER As Boolean = True
 'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE) und Voreinstellung für Ordnerauswahlfenster
 Private Const EXM_OPT_TARGETFOLDER As String = "N:\"
 '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 = 3000
 '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 " ". Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 'Final Message (Mitteilung wieviele Dateien gespeichert wurden) gewünscht = 1, nicht gewünscht =0
 Private Const finalmessage As Integer = 0
 'Datei nach Export in Ordner gelöschte Elemente schieben? ja= ture nein=false
 Private Const loeschen As Boolean = 1
 'Explorer öffnen mit Dateipfad des Speicherorts? set true. Otherwise false
 Private Const explorer_oeffnen As Boolean = False


 '-------------------------------------------------------------
 ' TRANSLATIONS
 '-------------------------------------------------------------

 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."
 '-------------------------------------------------------------


 '-------------------------------------
 'For browse folder; hier werden die Funktionen & Variablen für Fensteraufruf definiert
 '-------------------------------------
 
#If VBA7 And Win64 Then
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As LongPtr

    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

    Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As LongPtr
#Else
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As Long

    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As Long
#End If

 Public A$
 Public Const HandCursor = 32649&
 Public Const OFN_EXTENSIONDIFFERENT = &H400&
 Public Const OFN_PATHMUSTEXIST = &H800
 Public NeuProfil As String

 Type OPENFILENAME
   lStructSize As Long
   hWndOwner As LongPtr
   hInstance As LongPtr
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustomFilter 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
   nFilextension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
 End Type


 ' *** Hauptmakro Anfang ***
 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 vSuccess2 As Variant
     Dim strTemp1 As String
     Dim strTemp2 As String
     Dim strErrorMsg As String
   
     '-------------------------------------
     'Get target drive
     '-------------------------------------
     If (EXM_OPT_USEBROWSER = True) Then
         strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)             'ruft Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
         If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
             strErrorMsg = Mid(strBackupPath, 16, 9999)
             Error 5004
         End If
     Else
         strBackupPath = EXM_OPT_TARGETFOLDER
     End If
     If strBackupPath = "" Then GoTo ExitScript
     If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
     
     
   
     '-------------------------------------
     '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)  'ruft Funktion "ProcessEmail" auf und gibt Wert 1 zurück
             'setzt Attribute der Datei
         If (Not vSuccess = True) Then
             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 (finalmessage = 1) Then      'Message Ein- Ausschalten
     If (intCountFailures = 0) Then  'No failure occurred
         MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
     ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
         MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_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, 48, EXM_017
     End If
     End If


 'Datei in Ordner "Gelöschte Elemente" verschieben
 If (loeschen = False) Then
 On Error Resume Next

 Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
 Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

 Set objNS = Application.GetNamespace("MAPI")
 Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

 Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")

 If objFolder Is Nothing Then
 MsgBox "Dieser Ordner existiert nicht!", vbOKOnly + vbExclamation, "Fehler"
 End If

 If Application.ActiveExplorer.Selection.Count = 0 Then
 Exit Sub
 End If

 For Each objItem In Application.ActiveExplorer.Selection
 objItem.UnRead = False 'Email in Outlook wird als gelesen markieren
 If objFolder.DefaultItemType = olMailItem Then
 If objItem.Class = olMail Then
 objItem.Move objFolder  'Datei wird verschoben
 End If
 End If
 Next

 Set objItem = Nothing
 Set objFolder = Nothing
 Set objInbox = Nothing
 Set objNS = Nothing
 End If
 'Ende der Datei Verschieben

 'Explorer öffnen
 If (explorer_oeffnen = True) Then
     Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
     Else
 End If


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

 Private Function ProcessEmail(myItem As Object, strBackupPath As String) As 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
     Dim success As Variant
     

     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, 16, 9999)
         Error 1003
     End If
     strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
     strFullPath = strBackupPath & strFinalFileName
     
     '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 'hier wird die Datei erzeugt: .SaveAs  strFullPath = Pfad&Name; vExtConst=Dateityp
     
    'setzt Attribute der Datei
     success = AttributeSetzen(strFullPath, strSender, strReceiver, strSubject)
     
     '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 Else:
         ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
     End Select
     Resume ExitScript
 End Function



 Private Function CleanString(strData As String) As 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

 '************************************************** Hohlt Pfad über Eingabefenster
   
 Private Function getfiledir(saveAspath As String, DateiEndung As String) As String

 Const PROCNAME As String = "GetFileDir"
 On Error GoTo ErrorHandler


 Dim DateiName As String
 Dim FilterName As String
 Dim SpeichernAls As OPENFILENAME
 Dim ExistiertDatei
 Dim i As Integer

 DateiName = "Neu1"
 FilterName = "outlook"
 DateiEndung = "*." & DateiEndung
   
       
 With SpeichernAls
     .lStructSize = Len(SpeichernAls)
     .hWndOwner = FindWindow("XLMAIN", "Outlook")
     .hInstance = GetModuleHandle("Outlook.EXE")
     .lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & vbNullChar
     .lpstrCustomFilter = vbNullString
     .nFilterIndex = 1
     DateiName = Replace(DateiName, ":", "")
     .lpstrFile = DateiName & Space(255) & vbNullChar
     .nMaxFile = Len(.lpstrFile)
     .lpstrFileTitle = Len(.lpstrFileTitle)
     .lpstrInitialDir = saveAspath
     .lpstrTitle = "Email speichern"
     .flags = OFN_EXTENSIONDIFFERENT
 End With
   
 If GetSaveFileName(SpeichernAls) = 0 Then   'Funktion mit Übergabevariable wird aufgerufen; = als übergabewert ist Abbruchbedingung
 getfiledir = ""
 GoTo ErrorHandler
 End If
   
 getfiledir = SpeichernAls.lpstrFile
 getfiledir = Left(getfiledir, InStr(1, getfiledir, "Neu1") - 1)
 'getfiledir = Right(getfiledir, InStrRev(getfiledir, "\"))
 'Right(getfiledir, 3) <> DateiEndung Then DateiSpeichernAlsName = DateiSpeichernAlsName & DateiEndung
 'MsgBox (getfiledir)

 'Wenn Datei Name mit abgespeichert werden soll, hier nicht der Fall, nur der Pfad wird benötigt
 'On Error Resume Next
 'ExistiertDatei = Not CBool(GetAttr(datei) And (vbVolume))
 'On Error GoTo 0
 'If datei = "Falsch" Then Exit Function
 'If ExistiertDatei Then
 '    If MsgBox("Diese Datei existiert schon!" & vbCrLf & _
 '    "Möchten Sie sie überschreiben?", vbYesNo, "Datei existiert schon!") = vbNo Then
 '        MsgBox "Datei wurde nicht exportiert", vbInformation, "Abgebrochen"
 '        Exit Function
 '    End If
 'End If
   
 'DateiSpeichernAlsName = SpeichernAls.lpstrFile
   
 'DateiSpeichernAlsName = DateiSpeichernAlsName

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


 End Function

 Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, Betreff As String)

 Const PROCNAME As String = "AttributeSetzen"

 Dim objFilePropReader As Object
 Dim objDocProp As Object
 On Error Resume Next
 Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
 objFilePropReader.Open DateiPfad
 Set objDocProp = objFilePropReader.summaryproperties
 Debug.Print objDocProp.Title
 'With objFilePropReader
  '   .IsReadOnly = "true"    '?
   '  .oledocumentformat = "oledoc"   '?
    ' End With
     
 'vbhidden
     
 With objDocProp
     .Author = Sender         'Autoren
    '.Category = "category"          '
    '.Comments = "comments"          'Kommentare
    '.DataCreated = "Datacreated"    '?
     .Keywords = Empfaenger          'Markierungen
    '.Manager = "Manager"
    '.Subject = "Subject"            'Thema
     .Title = Betreff              'Titel

 End With
     
 objFilePropReader.Save
 objFilePropReader.Close
 Set objDocProp = Nothing

 AttributeSetzen = 1
 End Function









Edit: unter 32 Bit läuft das angepasst Marko. Wenn ich das Makro laufen lassen dann öffnet sich auch der Pfad zum N Laufwerk. Wenn ich anstatt speichern auf abbrechen drücke, dann erscheint die gleiche Fehlermeldung mit error 20 etc... Das war bereits vorher schon so gewesen.

Grüsse
Jens
katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 29. Aug 2019, 13:54

Hallo Katutcho,

in der Funktion GetFileDir() ist ein direkter Sprung zum ErrorHandler:
Code: Alles auswählen
...
If GetSaveFileName(SpeichernAls) = 0 Then   'Funktion mit Übergabevariable wird aufgerufen; = als übergabewert ist Abbruchbedingung
getfiledir = ""
GoTo ErrorHandler
End If
...
Das kann so nicht richtig sein. Ersetze "Goto ErrorHandler" durch "Goto ExitScript". Prüfe auch nochmal die anderen Funktion, ob das dort auch noch auftaucht. Ein direkter Sprung zum Errorhandler sollte niemals so gemacht werden, wenn dieser mit Resume aufhört.

Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 02. Sep 2019, 10:36

Hallo Ulrich

Ich habe das soweit angepasst. Nach dem Ausführen des Makros kommt normalerweise das Fenster zur Auswahl des Ablegeordners öffnen, aber es passiert nun gar nichts.

Grüsse
Jens
katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 02. Sep 2019, 12:04

Hallo Jens,

und nun?
Was meinst du, wie könnte dir jemand helfen?

Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 02. Sep 2019, 16:14

Hallo Ulrich

Was meinst du, wie könnte dir jemand helfen?

Ich könnte ein Päckchen mit lecker Bier schnüren, wenn das hilft. Schliesslich sitze ich an der Quelle :wink:

Ich habe herausgefunden, dass wenn ich in der Anfangsbedingung
Private Const EXM_OPT_USEBROWSER As Boolean = True


anstatt True ==> False einsetze, dann speichert mir das Makro die markierte Mail unter dem Pfad direkt ab. Soweit funktioniert das Makro. Jedoch ist die Funktion, mit dem vorherigen Öffnen der Ordnerauswahl besser, dann kann man den Ablageort selbst bestimmen, nur das klappt noch nicht. Wenn ich bei dem Befehl "True" eingebe, passiert nichts. Konnte hier den Grund noch nicht herausfinden, woran des liegen könnte. Die Funktion Get target file, hängt mit dem getfiledir zusammen, aber auch hier konnte ich keinen Ansatz finden.

der aktuelle Code ist

Grüsse
Jens

Code: Alles auswählen
'==========================================================================
 'Export Outlook e-mail to drive
 '--------------------------------------------------------------------------
 'Original von 'Author: Michael Wöhrer 'Version: 0.2, 2009-01-20
 'umgeschrieben und erweitert von Hanners
 '==========================================================================
 'Terms and conditions
 '  You can use, redistribute and/or modify this code under the terms of
 '  the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it
 '  will be useful, but WITHOUT ANY WARRANTY; without even the implied
 '  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 '  See the SOFTWARE GUIDE LICENSE for more details.
 '==========================================================================

 Option Explicit

 '-------------------------------------------------------------
 ' OPTIONS Hier die Einstellung für die Funktion vornehmen
 '-------------------------------------------------------------
 '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 = "yyyy-mm-dd "
 '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> - <SUBJECT>"
 'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
 Private Const EXM_OPT_USEBROWSER As Boolean = True
 'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE) und Voreinstellung für Ordnerauswahlfenster
 Private Const EXM_OPT_TARGETFOLDER As String = "N:\"
 '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 = 3000
 '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 " ". Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 'Final Message (Mitteilung wieviele Dateien gespeichert wurden) gewünscht = 1, nicht gewünscht =0
 Private Const finalmessage As Integer = 0
 'Datei nach Export in Ordner gelöschte Elemente schieben? ja= true nein=false
 Private Const loeschen As Boolean = 1
 'Explorer öffnen mit Dateipfad des Speicherorts? set true. Otherwise false
 Private Const explorer_oeffnen As Boolean = False


 '-------------------------------------------------------------
 ' TRANSLATIONS
 '-------------------------------------------------------------

 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."
 '-------------------------------------------------------------


 '-------------------------------------
 'For browse folder; hier werden die Funktionen & Variablen für Fensteraufruf definiert
 '-------------------------------------
 
#If VBA7 And Win64 Then
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As LongPtr

    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

    Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As LongPtr
#Else
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As Long

    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As Long
#End If

 Public A$
 Public Const HandCursor = 32649&
 Public Const OFN_EXTENSIONDIFFERENT = &H400&
 Public Const OFN_PATHMUSTEXIST = &H800
 Public NeuProfil As String

 Type OPENFILENAME
   lStructSize As Long
   hWndOwner As LongPtr
   hInstance As LongPtr
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustomFilter 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
   nFilextension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
 End Type


 ' *** Hauptmakro Anfang ***
 Public Sub ExportEmailToDrive()
     
     Const PROCNAME As String = "ExportEmailToDrive"
     
     On Error GoTo ExitScript
     
     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 vSuccess2 As Variant
     Dim strTemp1 As String
     Dim strTemp2 As String
     Dim strErrorMsg As String
   
     '-------------------------------------
     'Get target drive
     '-------------------------------------
     If (EXM_OPT_USEBROWSER = True) Then
         strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)             'ruft Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
         If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
             strErrorMsg = Mid(strBackupPath, 16, 9999)
             Error 5004
         End If
     Else
         strBackupPath = EXM_OPT_TARGETFOLDER
     End If
     If strBackupPath = "" Then GoTo ExitScript
     If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
     
     
   
     '-------------------------------------
     '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)  'ruft Funktion "ProcessEmail" auf und gibt Wert 1 zurück
             'setzt Attribute der Datei
         If (Not vSuccess = True) Then
             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 (finalmessage = 1) Then      'Message Ein- Ausschalten
     If (intCountFailures = 0) Then  'No failure occurred
         MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
     ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
         MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_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, 48, EXM_017
     End If
     End If


 'Datei in Ordner "Gelöschte Elemente" verschieben
 If (loeschen = False) Then
 On Error Resume Next

 Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
 Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

 Set objNS = Application.GetNamespace("MAPI")
 Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

 Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")

 If objFolder Is Nothing Then
 MsgBox "Dieser Ordner existiert nicht!", vbOKOnly + vbExclamation, "Fehler"
 End If

 If Application.ActiveExplorer.Selection.Count = 0 Then
 Exit Sub
 End If

 For Each objItem In Application.ActiveExplorer.Selection
 objItem.UnRead = False 'Email in Outlook wird als gelesen markieren
 If objFolder.DefaultItemType = olMailItem Then
 If objItem.Class = olMail Then
 objItem.Move objFolder  'Datei wird verschoben
 End If
 End If
 Next

 Set objItem = Nothing
 Set objFolder = Nothing
 Set objInbox = Nothing
 Set objNS = Nothing
 End If
 'Ende der Datei Verschieben

 'Explorer öffnen
 If (explorer_oeffnen = True) Then
     Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
     Else
 End If


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

 Private Function ProcessEmail(myItem As Object, strBackupPath As String) As 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 ExitScript

     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
     Dim success As Variant
     

     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, 16, 9999)
         Error 1003
     End If
     strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
     strFullPath = strBackupPath & strFinalFileName
     
     '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 'hier wird die Datei erzeugt: .SaveAs  strFullPath = Pfad&Name; vExtConst=Dateityp
     
    'setzt Attribute der Datei
     success = AttributeSetzen(strFullPath, strSender, strReceiver, strSubject)
     
     '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 Else:
         ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
     End Select
     Resume ExitScript
 End Function



 Private Function CleanString(strData As String) As String

     Const PROCNAME As String = "CleanString"

     On Error GoTo ExitScript

     '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

 '************************************************** Hohlt Pfad über Eingabefenster
   
 Private Function getfiledir(saveAspath As String, DateiEndung As String) As String

 Const PROCNAME As String = "GetFileDir"
 On Error GoTo ExitScript


 Dim DateiName As String
 Dim FilterName As String
 Dim SpeichernAls As OPENFILENAME
 Dim ExistiertDatei
 Dim i As Integer

 DateiName = "Neu1"
 FilterName = "outlook"
 DateiEndung = "*." & DateiEndung
   
       
 With SpeichernAls
     .lStructSize = Len(SpeichernAls)
     .hWndOwner = FindWindow("XLMAIN", "Outlook")
     .hInstance = GetModuleHandle("Outlook.EXE")
     .lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & vbNullChar
     .lpstrCustomFilter = vbNullString
     .nFilterIndex = 1
     DateiName = Replace(DateiName, ":", "")
     .lpstrFile = DateiName & Space(255) & vbNullChar
     .nMaxFile = Len(.lpstrFile)
     .lpstrFileTitle = Len(.lpstrFileTitle)
     .lpstrInitialDir = saveAspath
     .lpstrTitle = "Email speichern"
     .flags = OFN_EXTENSIONDIFFERENT
 End With
   
 If GetSaveFileName(SpeichernAls) = 0 Then   'Funktion mit Übergabevariable wird aufgerufen; = als übergabewert ist Abbruchbedingung
 getfiledir = ""
 GoTo ExitScript
 End If
   
 getfiledir = SpeichernAls.lpstrFile
 getfiledir = Left(getfiledir, InStr(1, getfiledir, "Neu1") - 1)
 'getfiledir = Right(getfiledir, InStrRev(getfiledir, "\"))
 'Right(getfiledir, 3) <> DateiEndung Then DateiSpeichernAlsName = DateiSpeichernAlsName & DateiEndung
 'MsgBox (getfiledir)

 'Wenn Datei Name mit abgespeichert werden soll, hier nicht der Fall, nur der Pfad wird benötigt
 'On Error Resume Next
 'ExistiertDatei = Not CBool(GetAttr(datei) And (vbVolume))
 'On Error GoTo 0
 'If datei = "Falsch" Then Exit Function
 'If ExistiertDatei Then
 '    If MsgBox("Diese Datei existiert schon!" & vbCrLf & _
 '    "Möchten Sie sie überschreiben?", vbYesNo, "Datei existiert schon!") = vbNo Then
 '        MsgBox "Datei wurde nicht exportiert", vbInformation, "Abgebrochen"
 '        Exit Function
 '    End If
 'End If
   
 'DateiSpeichernAlsName = SpeichernAls.lpstrFile
   
 'DateiSpeichernAlsName = DateiSpeichernAlsName

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


 End Function

 Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, Betreff As String)

 Const PROCNAME As String = "AttributeSetzen"

 Dim objFilePropReader As Object
 Dim objDocProp As Object
 On Error Resume Next
 Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
 objFilePropReader.Open DateiPfad
 Set objDocProp = objFilePropReader.summaryproperties
 Debug.Print objDocProp.Title
 'With objFilePropReader
  '   .IsReadOnly = "true"    '?
   '  .oledocumentformat = "oledoc"   '?
    ' End With
     
 'vbhidden
     
 With objDocProp
     .Author = Sender         'Autoren
    '.Category = "category"          '
    '.Comments = "comments"          'Kommentare
    '.DataCreated = "Datacreated"    '?
     .Keywords = Empfaenger          'Markierungen
    '.Manager = "Manager"
    '.Subject = "Subject"            'Thema
     .Title = Betreff              'Titel

 End With
     
 objFilePropReader.Save
 objFilePropReader.Close
 Set objDocProp = Nothing

 AttributeSetzen = 1
 End Function







katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 02. Sep 2019, 17:49

Hallo Jens,

das mit dem Päckchen ist sicherlich eine nette Idee, aber hier nicht unbedingt notwendig. Trotzdem Danke für dein Angebot.

Um solche Fälle einzugrenzen, gibt es den Debugger. Setzte auf die Prozedur ExportEmailToDrive() einen Breakpoint und gehe von dort aus im Einzelschritt die Routine durch. Lasse dir im Lokalfenster die jeweiligen Inhalte der Variablen anzeigen und prüfe, ob diese plausibel sind. So wirst du selber am schnellsten erkennen, wo etwas schief läuft.

Code: Alles auswählen
If (EXM_OPT_USEBROWSER = True) Then
Einen Vergleich mit der Konstanten True ist doppelt gemoppelt und kannst du dir auch sparen.
(Btw. wo kommt diese Unart eigentlich her?)
Es reicht:
Code: Alles auswählen
If EXM_OPT_USEBROWSER Then


Gruß Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 04. Sep 2019, 13:06

Hallo Ulrich

Danke!


(Btw. wo kommt diese Unart eigentlich her?)

Das Makro ist nicht von mir.


Ich habe versucht mit dem Lokal-Fenster auf den Fehler zu kommen, aber mir gelingt das nicht. Ich weiss da nicht auf was ich genau achten soll. Das aktuelle Makro läuft, trotz den ganzen Anpassungen auf dem 32bit System ohne Probleme, nur auf dem 64Bit noch nicht. Es kommt aber keine Fehlermeldung mehr.

Edit:
Ich habe jetzt mal das 32bit und 64bit Lokal-Fenster parallel laufen lassen (2 Laptops) und verglichen. Mir ist folgendes aufgefallen. Vielleicht ist das ein Fehler. ich meine das "^" Zeichen im Wert und das LongLong im Typ. Beim 32bit ist das nicht bzw. steht nur Long

LongLong.PNG


Das aktuelle Makro Version ist:
Code: Alles auswählen
'==========================================================================
 'Export Outlook e-mail to drive
 '--------------------------------------------------------------------------
 'Original von 'Author: Michael Wöhrer 'Version: 0.2, 2009-01-20
 'umgeschrieben und erweitert von Hanners
 '==========================================================================
 'Terms and conditions
 '  You can use, redistribute and/or modify this code under the terms of
 '  the SOFTWARE GUIDE LICENSE. This code is distributed in the hope that it
 '  will be useful, but WITHOUT ANY WARRANTY; without even the implied
 '  warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 '  See the SOFTWARE GUIDE LICENSE for more details.
 '==========================================================================

 Option Explicit

 '-------------------------------------------------------------
 ' OPTIONS Hier die Einstellung für die Funktion vornehmen
 '-------------------------------------------------------------
 '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 = "yyyy-mm-dd "
 '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> - <SUBJECT>"
 'Use browse folder? Set to FALSE if you don't want to use browser for selecting target folder
 Private Const EXM_OPT_USEBROWSER As Boolean = True
 'Target folder (used if EXM_OPT_USEBROWSER is set to FALSE) und Voreinstellung für Ordnerauswahlfenster
 Private Const EXM_OPT_TARGETFOLDER As String = "N:\CH_Marketing\Produktentwicklung\Projekte"
 '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 = 20
 '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 " ". Argumente für Gänsefüsschen "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s"
 'Final Message (Mitteilung wieviele Dateien gespeichert wurden) gewünscht = 1, nicht gewünscht =0
 Private Const finalmessage As Integer = 0
 'Datei nach Export in Ordner gelöschte Elemente schieben? ja= ture nein=false
 Private Const loeschen As Boolean = 1
 'Explorer öffnen mit Dateipfad des Speicherorts? set true. Otherwise false
 Private Const explorer_oeffnen As Boolean = False


 '-------------------------------------------------------------
 ' TRANSLATIONS
 '-------------------------------------------------------------

 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."
 '-------------------------------------------------------------


 '-------------------------------------
 'For browse folder; hier werden die Funktionen & Variablen für Fensteraufruf definiert
 '-------------------------------------
 Public DateiSpeichernAlsName As String   'Loeschen

#If VBA7 Then
    Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As LongPtr

    Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr

    Declare PtrSafe Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As LongPtr
#Else
    Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" _
        (lpofn As OPENFILENAME) As Long

    Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
        (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Declare Function GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" _
        (ByVal lpModuleName As String) As Long
#End If

 Public A$
 Public Const HandCursor = 32649&
 Public Const OFN_EXTENSIONDIFFERENT = &H400&
 Public Const OFN_PATHMUSTEXIST = &H800
 Public NeuProfil As String

 Type OPENFILENAME
   lStructSize As Long
   hWndOwner As LongPtr
   hInstance As LongPtr
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustomFilter 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
   nFilextension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
 End Type


 ' *** Hauptmakro Anfang ***
 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 vSuccess2 As Variant
     Dim strTemp1 As String
     Dim strTemp2 As String
     Dim strErrorMsg As String
   
     '-------------------------------------
     'Get target drive
     '-------------------------------------
     If EXM_OPT_USEBROWSER Then
         strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)             'ruft Funktion auf getfiledir, die das Fenster für Ordnerwahl öffnet
         If Left(strBackupPath, 15) = "ERROR_OCCURRED:" Then
             strErrorMsg = Mid(strBackupPath, 16, 9999)
             Error 5004
         End If
     Else
         strBackupPath = EXM_OPT_TARGETFOLDER
     End If
     If strBackupPath = "" Then GoTo ExitScript
     If (Not Right(strBackupPath, 1) = "\") Then strBackupPath = strBackupPath & "\"
     
     
   
     '-------------------------------------
     '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)  'ruft Funktion "ProcessEmail" auf und gibt Wert 1 zurück
             'setzt Attribute der Datei
         If (Not vSuccess = True) Then
             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 (finalmessage = 1) Then      'Message Ein- Ausschalten
     If (intCountFailures = 0) Then  'No failure occurred
         MsgBox strStatusMsg & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 64, EXM_018
     ElseIf (intCountAll = 1) Then   'Only one email was selected and a failure occurred
         MsgBox EXM_002 & Chr(10) & vSuccess & Chr(10) & Chr(10) & EXM_003 & " " & strBackupPath, 48, EXM_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, 48, EXM_017
     End If
     End If


 'Datei in Ordner "Gelöschte Elemente" verschieben
 If (loeschen = False) Then
 On Error Resume Next

 Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
 Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem

 Set objNS = Application.GetNamespace("MAPI")
 Set objInbox = objNS.GetDefaultFolder(olFolderInbox)

 Set objFolder = objInbox.Parent.Folders("Gelöschte Elemente")

 If objFolder Is Nothing Then
 MsgBox "Dieser Ordner existiert nicht!", vbOKOnly + vbExclamation, "Fehler"
 End If

 If Application.ActiveExplorer.Selection.Count = 0 Then
 Exit Sub
 End If

 For Each objItem In Application.ActiveExplorer.Selection
 objItem.UnRead = False 'Email in Outlook wird als gelesen markieren
 If objFolder.DefaultItemType = olMailItem Then
 If objItem.Class = olMail Then
 objItem.Move objFolder  'Datei wird verschoben
 End If
 End If
 Next

 Set objItem = Nothing
 Set objFolder = Nothing
 Set objInbox = Nothing
 Set objNS = Nothing
 End If
 'Ende der Datei Verschieben

 'Explorer öffnen
 If explorer_oeffnen Then
     Shell "explorer.exe " & EXM_OPT_TARGETFOLDER, vbNormalFocus
     Else
 End If


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

 Private Function ProcessEmail(myItem As Object, strBackupPath As String) As 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
     Dim success As Variant
     

     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, 16, 9999)
         Error 1003
     End If
     strFinalFileName = IIf(Len(strFinalFileName) > 251, Left(strFinalFileName, 251), strFinalFileName)
     strFullPath = strBackupPath & strFinalFileName
     
     '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 'hier wird die Datei erzeugt: .SaveAs  strFullPath = Pfad&Name; vExtConst=Dateityp
     
    'setzt Attribute der Datei
     success = AttributeSetzen(strFullPath, strSender, strReceiver, strSubject)
     
     '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 Else:
         ProcessEmail = "Error #" & Err & ": " & Error$ & " (Procedure: " & PROCNAME & ")"
     End Select
     Resume ExitScript
 End Function



 Private Function CleanString(strData As String) As 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

 '************************************************** Hohlt Pfad über Eingabefenster
   
 Private Function getfiledir(saveAspath As String, DateiEndung As String) As String

 Const PROCNAME As String = "GetFileDir"
 On Error GoTo ErrorHandler


 Dim DateiName As String
 Dim FilterName As String
 Dim SpeichernAls As OPENFILENAME
 Dim ExistiertDatei
 Dim i As Integer

 DateiName = "Neu1"
 FilterName = "outlook"
 DateiEndung = "*." & DateiEndung
   
       
 With SpeichernAls
     .lStructSize = Len(SpeichernAls)
     .hWndOwner = FindWindow("XLMAIN", "Outlook")
     .hInstance = GetModuleHandle("Outlook.EXE")
     .lpstrFilter = FilterName & DateiEndung & vbNullChar & DateiEndung & vbNullChar & vbNullChar
     .lpstrCustomFilter = vbNullString
     .nFilterIndex = 1
     DateiName = Replace(DateiName, ":", "")
     .lpstrFile = DateiName & Space(255) & vbNullChar
     .nMaxFile = Len(.lpstrFile)
     .lpstrFileTitle = Len(.lpstrFileTitle)
     .lpstrInitialDir = saveAspath
     .lpstrTitle = "Email speichern"
     .flags = OFN_EXTENSIONDIFFERENT
 End With
   
 If GetSaveFileName(SpeichernAls) = 0 Then   'Funktion mit Übergabevariable wird aufgerufen; = als übergabewert ist Abbruchbedingung
 getfiledir = ""
 GoTo ExitScript
 End If
   
 getfiledir = SpeichernAls.lpstrFile
 getfiledir = Left(getfiledir, InStr(1, getfiledir, "Neu1") - 1)
 'getfiledir = Right(getfiledir, InStrRev(getfiledir, "\"))
 'Right(getfiledir, 3) <> DateiEndung Then DateiSpeichernAlsName = DateiSpeichernAlsName & DateiEndung
 'MsgBox (getfiledir)

 'Wenn Datei Name mit abgespeichert werden soll, hier nicht der Fall, nur der Pfad wird benötigt
 'On Error Resume Next
 'ExistiertDatei = Not CBool(GetAttr(datei) And (vbVolume))
 'On Error GoTo 0
 'If datei = "Falsch" Then Exit Function
 'If ExistiertDatei Then
 '    If MsgBox("Diese Datei existiert schon!" & vbCrLf & _
 '    "Möchten Sie sie überschreiben?", vbYesNo, "Datei existiert schon!") = vbNo Then
 '        MsgBox "Datei wurde nicht exportiert", vbInformation, "Abgebrochen"
 '        Exit Function
 '    End If
 'End If
   
 'DateiSpeichernAlsName = SpeichernAls.lpstrFile
   
 'DateiSpeichernAlsName = DateiSpeichernAlsName

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


 End Function

 Private Function AttributeSetzen(DateiPfad As String, Sender As String, Empfaenger As String, Betreff As String)

 Const PROCNAME As String = "AttributeSetzen"

 Dim objFilePropReader As Object
 Dim objDocProp As Object
 On Error Resume Next
 Set objFilePropReader = CreateObject("DSOFile.OleDocumentProperties")
 objFilePropReader.Open DateiPfad
 Set objDocProp = objFilePropReader.summaryproperties
 Debug.Print objDocProp.Title
 'With objFilePropReader
  '   .IsReadOnly = "true"    '?
   '  .oledocumentformat = "oledoc"   '?
    ' End With
     
 'vbhidden
     
 With objDocProp
     .Author = Sender         'Autoren
    '.Category = "category"          '
    '.Comments = "comments"          'Kommentare
    '.DataCreated = "Datacreated"    '?
     .Keywords = Empfaenger          'Markierungen
    '.Manager = "Manager"
    '.Subject = "Subject"            'Thema
     .Title = Betreff              'Titel

 End With
     
 objFilePropReader.Save
 objFilePropReader.Close
 Set objDocProp = Nothing

 AttributeSetzen = 1
 End Function
Du hast keine ausreichende Berechtigung, um die Dateianhänge dieses Beitrags anzusehen.
katutcho
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 13
Registriert: 07. Mär 2016, 10:24

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 04. Sep 2019, 14:04

Hallo Jens,

du solltest darauf achten, welchen Inhalt die Variablen haben, ob die Prozedure GetFileDir() überhaupt durchlaufen wird und was anschließend nach dem Aufruf von strBackupPath = getfiledir(EXM_OPT_TARGETFOLDER, EXM_OPT_MAILFORMAT)in der Variablen strBackupPath steht. Während des Einzelschrittbetriebes sollte eigentlich irgendwann ein Dialogfenster geöffnet werden.

Gruß Ulrich
knobbi38
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1302
Registriert: 02. Jul 2015, 14:23

Nächste

Zurück zu Outlook Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 2 Gäste