Makro von 32bit auf 64bit umschreiben

Moderator: ModerationP

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Gast » 04. Sep 2019, 15:07

Hallo Ulrich

ich kann das Makro komplett im Einzelschritt durchlaufen. Es öffnet sich kein Dialogfeld. Im Wert der Variablen getfildir und strbackuppath wird "" angezeigt. Ich habe keine Ahnung und komme leider per direkter Anleitung nicht weiter.

Danke und Gruss Jens
Gast
 

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 05. Sep 2019, 00:05

Hallo Jens,

wenn ich mir das genau betrachte, sind da mehrere Fehler in GetFileDir() enthalten, die sich auch noch gegenseitig beeinflussen.

1) Der ReturnCode von GetSaveFileName() wird nicht richtig ausgewertet sondern das Ergebnis wird auf 0 geprüft und mit 'Cancel' gleichgesetzt. Das führt dazu, daß nicht mehr zwischen einem Fehler bei der Ausführung und einem Abbruch durch den Benutzer unterschieden werden kann. Genau das aber ist hier der Fall. Der API Aufruf ist fehlerhaft und wird hierduch nicht erkannt. Das ist ein klassisches Beispiel aus dem Lehrbuch, wie man es nicht machen sollte!
2) Die Typdeklaration für die Struktur 'OPENFILENAME' ist fehlerhaft und verursacht in der 64Bit-Version einen Fehler.
3) Die API-Deklaration für GetSaveFileNameA ist fehlerhaft.
4) Die Größe von OPENFILENAME wird an .lStructSize für 64Bit falsch berechnet und zugewiesen.[/list]

Jens, mindestens 2. und 3. hätten nicht sein müssen, hättest du dir die Hinweise genauer angeschaut, 1. und 4. fallen hingegen kaum auf und ich bin auch erst durch deine Beschreibung vom Debuggen darauf gekommen.

zu 2 u. 3:
die richtige Deklaration, auch für 64Bit, stehen in der Datei "Win32API_PtrSafe.TXT", die du hier herunterladen kannst:
https://www.microsoft.com/en-us/download/details.aspx?id=9970

zu 4:
die richtige Größe des Typs OPENFILENAME wird mit der Funktion lenB() ermittelt! Also muß
.lStructSize = Len(SpeichernAls)
durch
.lStructSize = LenB(SpeichernAls)
ersetzt werden.
Hier nochmal erklärt (leider nur auf englisch): A common pitfall - The size of user-defined types

zu 1:
ein Beispiel, wie der Rückgabewert ausgewertet werden könnte:
Code: Alles auswählen
' air code:
dim lngDlgErrorCode as Long
...
if GetSaveFilename(SpeichernAls) = 0 then
  ' Error or canceled - get the error code
  lngDlgErrorCode = CommDlgExtendedError()

  if lngDlgErrorCode= 0 then
    ' Canceled
    getfiledir = ""
  else
    ' Error
    getfiledir = "ERROR_OCCURRED:" _
               & "Error #" & lngDlgErrorCode _
               & "(Procedure: " & PROCNAME & ")"
  end if
 
  goto ExitScript
end if
...
Die Definitionen und Deklarationen stammen aus "Win32API_PtrSafe.TXT".

GetFileDir() sollte damit erstmal laufen, wenn ich nicht noch etwas übersehen habe.

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

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon katutcho » 05. Sep 2019, 08:18

Guten Morgen Ulrich

Besten Dank, es hat geklappt und das Makro funktioniert jetzt auch unter Office 64bit.

Punkt 1: Habe ich versucht einzupflegen, es kommt folgt dann Fehler beim Kompilieren. Ich habe es dann in der Ursprungsversion gelassen und probiert und es scheint zu funktioniern.
Punkt 2 habe ich angepasst
3. Habe ich das API nach Vorlage aus dem Netz korrigiert
4. Angepasst

Besten Dank und 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 totorello » 17. Okt 2019, 09:38

Hallo Jens, wie sieht denn jetzt der richtige Code aus?
totorello
 

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Dark_Eagle87 » 11. Dez 2019, 07:45

Guten Morgen alle zusammen,

Wir haben hier in der Firma auch immer das Skript von Herrn Wöhrer, mit den Anpassungen von Herr Richter genutzt. (An dieser Stelle ein großes Danke an beide).
Nun haben wir Windows Server2019 Version 1809 mit Office Professional Plus 2019 mit Outlook 2019 (Version1808) bekommen.

Hier Stützt Outlook ohne Fehlermeldung nach Auswahl des Zielordners ab und startet neu. Mit Einzelschritten konnte ich es auf diesen Bereich eingrenzen:
Code: Alles auswählen
    'Get the selected folder.
    spath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, spath
    CoTaskMemFree lpIDList


Hat jemand eine Idee woran das liegen könnte? Wir würden uns sehr über Unterstützung freuen!

Hier nochmal der ganze Code
Code: Alles auswählen
'Attribute VB_Name = "Modul1"
'Attribute VB_Name = "ExportEmail"
'==========================================================================
'Export Outlook e-mail to drive
'--------------------------------------------------------------------------
'Author: Michael Wöhrer
'Editor: Jon Richter
'Version: 0.2, 2009-01-20
'Version: 0.3, 2012-09-14 (added Outlook 64 compatibility)
'==========================================================================
'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
'-------------------------------------------------------------
'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>"
'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)
Private Const EXM_OPT_TARGETFOLDER As String = "D:\"
'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 = 200
'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|WG:\s|\ \s|:\s|/ \s"
'Bsp: Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s|WG:\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."
'-------------------------------------------------------------

' // http://www.ms-office-forum.net/forum/showthread.php?t=263854
#If VBA7 Then    ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpFn As LongPtr
  lParam As LongPtr
  iImage As Long
End Type
 Public Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" _
   Alias "SHGetPathFromIDListA" _
   (ByVal pidl As Long, _
   ByVal pszPath As String) As Long

Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pv As LongPtr)

Public Declare PtrSafe Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hWnd As LongPtr, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
   
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
   (pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)
#Else    ' Downlevel when using previous version of VBA7

Declare Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpFn As Long
  lParam As Long
  iImage As Long
End Type
 
#End If



   
Public Const MAX_PATH As Long = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
   

'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare PtrSafe Function SHSimpleIDListFromPath Lib _
   "Shell32" Alias "#162" _
   (ByVal szPath As String) As Long


'specific to the STRING method
Public Declare PtrSafe Function LocalAlloc Lib "kernel32" _
   (ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long
   
Public Declare PtrSafe Function LocalFree Lib "kernel32" _
   (ByVal hMem As Long) As Long

Public Declare PtrSafe Function lstrcpyA Lib "kernel32" _
   (lpString1 As Any, lpString2 As Any) As Long

Public Declare PtrSafe Function lstrlenA Lib "kernel32" _
   (lpString As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
  OSVSize         As Long
  dwVerMajor      As Long
  dwVerMinor      As Long
  dwBuildNumber   As Long
  PlatformID      As Long
  szCSDVersion    As String * 128
End Type
       
Public Const VER_PLATFORM_WIN32_NT = 2

Public Declare PtrSafe Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long
 
Public Declare PtrSafe Function GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
' // http://www.ms-office-forum.net/forum/showthread.php?t=263854


'-------------------------------------
'For browse folder
'-------------------------------------
'
'Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As String
'Private Declare PtrSafe Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
'Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)



'Private Const BIF_RETURNONLYFSDIRS = 1
'Private Const MAX_PATH = 260
'Private Type BROWSEINFO
'    hwndOwner As LongPtr
'    pidlRoot As Long
'    pszDisplayName As String
'    lpszTitle As String
'    ulFlags As Long
'    lpfnCallback 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
 
    '-------------------------------------
    'Get target drive
    '-------------------------------------
    If (EXM_OPT_USEBROWSER = True) Then
        strBackupPath = GetFileDir
        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)
        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 (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


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

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

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

    'Set filename
    strDate = Format(myMailItem.SentOn, 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
   
 
    '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

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 = lstrcpyA(EXM_016, "")
        .ulFlags = BFFM_INITIALIZED
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    spath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, spath
    CoTaskMemFree lpIDList
   
    'Strip Nulls
    If (InStr(spath, Chr$(0)) > 0) Then 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





Dark_Eagle87
 

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon mmarkus » 11. Dez 2019, 08:03

Dark_Eagle87 hat geschrieben:
Code: Alles auswählen
 Public Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" _
   Alias "SHGetPathFromIDListA" _
   (ByVal pidl As Long, _
   ByVal pszPath As String) As Long



Immerhin konntest du es eingrenzen.
Der Fehler in der Deklaration springt einen förmlich an.

Schau dir in der MSDN die Bedeutung der Parameter an, dann sollte es klar sein - vorausgesetzt du weißt was du tust.
ms access what else
mmarkus
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1756
Registriert: 16. Apr 2012, 16:07
Wohnort: Oberösterreich

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Dark_Eagle » 11. Dez 2019, 15:59

Hallo mmarkus,

danke für die schnelle Antwort.

Ich muss leider sagen ich habe keine Ahnung was ich tue. Dasgenannte Makro stammt von hier (Quelle: http://www.office-loesung.de/ftopic504627_0_0_asc.php). Ich habe bisher immer nur in Excel mit einer Mischung aus C++ Grundlagen und VBA-Makrorecorder Sachen zusammengebaut. Mit Library habe ich noch nie was gebaut.
Meinst du mit Declaration das da ein String als long definiert wird?
Dark_Eagle
Neuling
 
Beiträge: 2
Registriert: 10. Dez 2019, 15:40

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Gast » 12. Dez 2019, 07:22

Hier gibts einige Grundlagen:

https://codekabinett.com/rdumps.php?Lan ... vba-64-bit

Wenn du c etwas kennst ist das eh eine Bagatelle.
Für mich ist das Thema erst interessant geworden, als ich angefangen habe dll's für Access zu schreiben
Gast
 

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon Dark_Eagle » 13. Dez 2019, 15:29

Hallo Ihr lieben,
Habe mich nun mal mit einem Bekannten Hingesetzt und wir sind mal euren Hinweisen nachgegangen und haben folgende Änderungen übernommen:

Code: Alles auswählen
Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpFn As LongPtr
  lParam As LongPtr
  iImage As Long
End Type
 Public Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" _
   Alias "SHGetPathFromIDListA" _
   (ByVal pidl As LongPtr, _
   ByVal pszPath As String) As LongPtr


Code: Alles auswählen
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr


In der Fehlersuche sind wir drauf gestoßen das scheinbar "SHGetPathFromIDList lpIDList, spath" die in lpIDList enthalne Zahlenfolge nicht wieder in einen Dateipfadstring für spath umwandelt und vermuten das daher der Absturz kommt.
Haben wir hier etwas falsch definiert oder die Funktion von SHGetPathFromIDList falsch verstanden?

Nochmal gesamter Code:
Code: Alles auswählen
'Attribute VB_Name = "Modul1"
'Attribute VB_Name = "ExportEmail"
'==========================================================================
'Export Outlook e-mail to drive
'--------------------------------------------------------------------------
'Author: Michael Wöhrer
'Editor: Jon Richter
'Version: 0.2, 2009-01-20
'Version: 0.3, 2012-09-14 (added Outlook 64 compatibility)
'==========================================================================
'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
'-------------------------------------------------------------
'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>"
'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)
Private Const EXM_OPT_TARGETFOLDER As String = "D:\"
'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 = 200
'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|WG:\s|\ \s|:\s|/ \s"
'Bsp: Private Const EXM_OPT_CLEANSUBJECT_REGEX As String = "RE:\s|Re:\s|AW:\s|FW:\s|WG:\s|SV:\s|Antwort:\s|WG:\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."
'-------------------------------------------------------------

' // http://www.ms-office-forum.net/forum/showthread.php?t=263854
#If VBA7 Then    ' VBA7
Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long

Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpFn As LongPtr
  lParam As LongPtr
  iImage As Long
End Type
 Public Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" _
   Alias "SHGetPathFromIDListA" _
   (ByVal pidl As LongPtr, _
   ByVal pszPath As String) As LongPtr

Public Declare PtrSafe Sub CoTaskMemFree Lib "ole32" (ByVal pv As LongPtr)

Public Declare PtrSafe Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
   (ByVal hWnd As LongPtr, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
   
Public Declare PtrSafe Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
   (pDest As Any, _
    pSource As Any, _
    ByVal dwLength As Long)
#Else    ' Downlevel when using previous version of VBA7

Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
  Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As LongPtr

Public Type BROWSEINFO
  hOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpFn As Long
  lParam As Long
  iImage As Long
End Type
 
#End If



   
Public Const MAX_PATH As Long = 260
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1

'Constants ending in 'A' are for Win95 ANSI
'calls; those ending in 'W' are the wide Unicode
'calls for NT.

'Sets the status text to the null-terminated
'string specified by the lParam parameter.
'wParam is ignored and should be set to 0.
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)

'If the lParam  parameter is non-zero, enables the
'OK button, or disables it if lParam is zero.
'(docs erroneously said wParam!)
'wParam is ignored and should be set to 0.
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)

'Selects the specified folder. If the wParam
'parameter is FALSE, the lParam parameter is the
'PIDL of the folder to select , or it is the path
'of the folder if wParam is the C value TRUE (or 1).
'Note that after this message is sent, the browse
'dialog receives a subsequent BFFM_SELECTIONCHANGED
'message.
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
   

'specific to the PIDL method
'Undocumented call for the example. IShellFolder's
'ParseDisplayName member function should be used instead.
Public Declare PtrSafe Function SHSimpleIDListFromPath Lib _
   "Shell32" Alias "#162" _
   (ByVal szPath As String) As Long


'specific to the STRING method
Public Declare PtrSafe Function LocalAlloc Lib "kernel32" _
   (ByVal uFlags As Long, _
    ByVal uBytes As Long) As Long
   
Public Declare PtrSafe Function LocalFree Lib "kernel32" _
   (ByVal hMem As Long) As Long

Public Declare PtrSafe Function lstrcpyA Lib "kernel32" _
   (lpString1 As Any, lpString2 As Any) As Long

Public Declare PtrSafe Function lstrlenA Lib "kernel32" _
   (lpString As Any) As Long

Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)

'windows-defined type OSVERSIONINFO
Public Type OSVERSIONINFO
  OSVSize         As Long
  dwVerMajor      As Long
  dwVerMinor      As Long
  dwBuildNumber   As Long
  PlatformID      As Long
  szCSDVersion    As String * 128
End Type
       
Public Const VER_PLATFORM_WIN32_NT = 2

Public Declare PtrSafe Function GetVersionEx Lib "kernel32" _
   Alias "GetVersionExA" _
  (lpVersionInformation As OSVERSIONINFO) As Long
 
Public Declare PtrSafe Function GetLogicalDriveStrings Lib "kernel32" _
   Alias "GetLogicalDriveStringsA" _
  (ByVal nBufferLength As Long, _
   ByVal lpBuffer As String) As Long
' // http://www.ms-office-forum.net/forum/showthread.php?t=263854


'-------------------------------------
'For browse folder
'-------------------------------------
'
'Private Declare PtrSafe Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As String
'Private Declare PtrSafe Function SHBrowseForFolder Lib "Shell32" (lpbi As BROWSEINFO) As Long
'Private Declare PtrSafe Function SHGetPathFromIDList Lib "Shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
'Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)



'Private Const BIF_RETURNONLYFSDIRS = 1
'Private Const MAX_PATH = 260
'Private Type BROWSEINFO
'    hwndOwner As LongPtr
'    pidlRoot As Long
'    pszDisplayName As String
'    lpszTitle As String
'    ulFlags As Long
'    lpfnCallback 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
 
    '-------------------------------------
    'Get target drive
    '-------------------------------------
    If (EXM_OPT_USEBROWSER = True) Then
        strBackupPath = getfiledir
        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)
        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 (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


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

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

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

    'Set filename
    strDate = Format(myMailItem.SentOn, 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
   
 
    '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

Private Function getfiledir() As String
   
    Const PROCNAME As String = "GetFileDir"

    On Error GoTo ErrorHandler

    Dim ret As String
    Dim lpIDList As LongPtr
    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 = lstrcpyA(EXM_016, "")
        .ulFlags = BFFM_INITIALIZED
    End With

    lpIDList = SHBrowseForFolder(udtBI)
    If lpIDList = 0 Then Exit Function
       
    'Get the selected folder.
    spath = String$(MAX_PATH, 0)
    SHGetPathFromIDList lpIDList, spath
    CoTaskMemFree lpIDList
   
    'Strip Nulls
    If (InStr(spath, Chr$(0)) > 0) Then 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





Dark_Eagle
Neuling
 
Beiträge: 2
Registriert: 10. Dez 2019, 15:40

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon knobbi38 » 14. Dez 2019, 00:20

Hallo Dark_Eagle,

es geht doch im Moment um Problem bei der Umsetzung von SHBrowseForFolder() für eine 64 Bit Umgebung. Eigentlich könnte man sich die API Version hiervon ersparen, weil keine Besonderheiten dieser API in GetFileDir() genutzt werden. Wenn es nur darum geht, einen Verzeichnisnamen per Dialog zu erfragen, sollte die Shell-Version ohne API vollkommen ausreichen. Man müßte also nur GetFileDir() entsprechend umschreiben.

Eine Quelle für eine Funktion Ordnerdialog() gibt es z.B. hier:
https://dbwiki.net/wiki/VBA_Tipp:_Ordnerauswahl-Dialog_1
https://docs.microsoft.com/en-us/windows/win32/shell/shell-browseforfolder

Bei der Gelegenheit würde ich diese Codepassage:
Code: Alles auswählen
    'File already exists?
    If CreateObject("Scripting.FileSystemObject").FileExists(strFullPath) = True Then
        Error 1002
    End If

durch diese ersetzen:
Code: Alles auswählen
'File already exists?
If FileExists(strFullPath) Then
    Error 1002
End If

Code: Alles auswählen
Public Function FileExists(ByVal FileName As String) As Boolean
    On Error Resume Next
    FileExists = Not CBool(GetAttr(FileName) And (vbDirectory Or vbVolume))
    On Error GoTo 0
End Function
Es gibt keinen Grund, nur für die einfache Prüfung, ob eine Datei bereits existiert, jedesmal ein Objekt aus einer externen Bibliothek zu erzeugen und dann sofort wieder zu verwerfen. Da reichen einfache interne VBA Anweisungen.

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

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon mmarkus » 14. Dez 2019, 13:18

Da kann ich mich dem Ulrich nur anschließen.
Warum Zeit investieren, wenn Windows fertige Klassen anbietet, die das bereits machen.

Ich habe auch keine Lust die Fehler in deinem Code zu suchen. Du zahlst ja nicht dafür.
Was aber wieder sofort ins Auge springt.

Code: Alles auswählen
Public Type BROWSEINFO
  hOwner As LongPtr
  pidlRoot As Long


Wenn bei einem Argument wie bei pidlRoot (p steht doch immer für einen Pointer - es wird aber wie der long eingesetzt.)
Da muss man gar nicht nachsehen um zu wissen, dass das falsch sein muss.
Du müsstest für jedes Argument prüfen wofür es steht.
Bei einer Struktur kann man sich keine Fehler erlauben.
Bei einem Einzelargument kannst du longPtr nehmen auch wenn es ein Long ist. Da passiert nichts. Der ungenutzte Datenraum wird einfach abgeschnitten.
Das ist unter anderem auch ein Problem, wenn "Programmierer" Code 64Bit Fit machen.
Der Code kann laufen, auch wenn er falsch ist - wenn z.B. nur 32 Bit der 64Bit genutzt werden.
Nach einem Update des Betriebssystems läufts dann nicht mehr.
Daher bin ich kein Freund von kopierbaren Lösungen bei solchen Themen - man muss verstehen was man tut, wenn man Windows API's verwendet.
Da ist es weit einfacher man nimmt so was wie c#, da bekommt man für alles eine fertige Klasse.
Unlustig wirds dann trotzdem, wenn man solche Klassen mit Win Api's selbst erstellen muss. Dann braucht man das Wissen dann trotzdem wieder. :D
ms access what else
mmarkus
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1756
Registriert: 16. Apr 2012, 16:07
Wohnort: Oberösterreich

Re: Makro von 32bit auf 64bit umschreiben

Beitragvon mmarkus » 14. Dez 2019, 13:21

Hier ein simples Beispiel, dass ich mal erstellt habe um einen Ordner zu suchen:

Code: Alles auswählen
Function FolderChoos(Optional ByVal RootFolder as Variant= 17) As String
    Dim AppShell As Object
    Dim BrowseDir As Object

    Set AppShell = CreateObject("Shell.Application")
    Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, RootFolder)

    If Not BrowseDir Is Nothing Then
        FolderChoos = BrowseDir.Items().Item().Path
    End If
End Function
ms access what else
mmarkus
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 1756
Registriert: 16. Apr 2012, 16:07
Wohnort: Oberösterreich

Vorherige

Zurück zu Outlook Forum (provisorisch)

Wer ist online?

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