---

Hallo,

ich habe hier ein Macro mit dem ich eMails speichern kann. Es funzt auch super, nur ist mir das Fenster zur Auswahl des Speicherortes zu klein. Könnte mir bitte jemand schreiben wie, wo und was geändert werden muß um das Fenster zu vergrößern!?

Danke

-----------------------------------------------------------------------------------------
Public Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Public Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Public Const BIF_RETURNONLYFSDIRS = 1
Public Const MAX_PATH = 260

Public Type BrowseInfo
    hwndOwner As Long
    pIDLRoot As Long
    pszDisplayName As Long
    lpszTitle As Long
    ulFlags As Long
    lpfnCallback As Long
    lParam As Long
    iImage As Long
End Type

Sub SpeichernalsMSG()

Dim myExplorer As Outlook.Explorer
Dim myfolder As Outlook.MAPIFolder
Dim strname As String
Dim myItem As MailItem
Dim olSelection As Selection
Dim strBackupPath As String

Set myExplorer = Application.ActiveExplorer
Set myfolder = myExplorer.CurrentFolder

If Not myfolder.DefaultItemType = olMailItem Then GoTo Ende

strBackupPath = GetFileDir

Set olSelection = myExplorer.Selection

For Each myItem In olSelection

strname = Format(myItem.ReceivedTime, "dd-mm-yyyy hh-nn-ss") _
& "__" & myItem.SentOnBehalfOfName & "__" & IIf(Len(strBackupPath & myItem.Subject & myItem.SentOnBehalfOfName) > 255, _
Left(myItem.Subject, 255 - Len(strBackupPath)), myItem.Subject) & ".msg"

myItem.SaveAs strBackupPath & "\" & CleanString(strname), olMSG
       
Next
Ende:

End Sub

Private Function CleanString(strData As String) As String

    'Replace invalid strings.
    strData = ReplaceChar(strData, "´", "_")
    strData = ReplaceChar(strData, "`", "_")
    strData = ReplaceChar(strData, "'", "_")
    strData = ReplaceChar(strData, "{", "(")
    strData = ReplaceChar(strData, "[", "(")
    strData = ReplaceChar(strData, "]", ")")
    strData = ReplaceChar(strData, "}", ")")
    strData = ReplaceChar(strData, "/", "-")
    strData = ReplaceChar(strData, "\", "-")
    strData = ReplaceChar(strData, ":", "")
   
    'Cut out invalid signs.
    strData = ReplaceChar(strData, "*", "_")
    strData = ReplaceChar(strData, "?", "")
    strData = ReplaceChar(strData, """", "_")
    strData = ReplaceChar(strData, "<", "")
    strData = ReplaceChar(strData, ">", "")
    strData = ReplaceChar(strData, "|", "")
    CleanString = Trim(strData)
   
End Function

Private Function ReplaceChar(strData As String, strBadChar As String, strGoodChar As String) As String

    Dim tmpChar    As String
    Dim tmpString  As String
    Dim i          As Long
   
    For i = 1 To Len(strData)
   
        tmpChar = Mid(strData, i, 1)
       
        If tmpChar = strBadChar Then
            tmpString = tmpString & strGoodChar
        Else
            tmpString = tmpString & tmpChar
        End If
       
    Next i
   
    ReplaceChar = Trim(tmpString)

End Function

Public Function GetFileDir() As String
Dim ret As String
    Dim lpIDList As Long
    Dim sPath As String, udtBI As BrowseInfo
    Dim RdStrings() As String, nNewFiles As Long

    'Show a browse-for-folder form:
    With udtBI
        .lpszTitle = lstrcat("Bitte wählen Sie den Ordner zum Exportieren:", "")
        .ulFlags = BIF_RETURNONLYFSDIRS
    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
    sPath = StripNulls(sPath)
    GetFileDir = sPath
End Function

Public Function StripNulls(ByVal OriginalStr As String) As String
    If (InStr(OriginalStr, Chr$(0)) > 0) Then
        OriginalStr = Left$(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
    End If
    StripNulls = OriginalStr
End Function

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Lösung:

Option Explicit

Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
  Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private OFName As OPENFILENAME
Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type
Private Const OFN_ALLOWMULTISELECT As Long = &H200
Private Const OFN_CREATEPROMPT As Long = &H2000
Private Const OFN_ENABLEHOOK As Long = &H20
Private Const OFN_ENABLETEMPLATE As Long = &H40
Private Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Private Const OFN_EXPLORER As Long = &H80000
Private Const OFN_EXTENSIONDIFFERENT As Long = &H400
Private Const OFN_FILEMUSTEXIST As Long = &H1000
Private Const OFN_HIDEREADONLY As Long = &H4
Private Const OFN_LONGNAMES As Long = &H200000
Private Const OFN_NOCHANGEDIR As Long = &H8
Private Const OFN_NODEREFERENCELINKS As Long = &H100000
Private Const OFN_NOLONGNAMES As Long = &H40000
Private Const OFN_NONETWORKBUTTON As Long = &H20000
Private Const OFN_NOREADONLYRETURN As Long = &H8000&
Private Const OFN_NOTESTFILECREATE As Long = &H10000
Private Const OFN_NOVALIDATE As Long = &H100
Private Const OFN_OVERWRITEPROMPT As Long = &H2
Private Const OFN_PATHMUSTEXIST As Long = &H800
Private Const OFN_READONLY As Long = &H1
Private Const OFN_SHAREAWARE As Long = &H4000
Private Const OFN_SHAREFALLTHROUGH As Long = 2
Private Const OFN_SHAREWARN As Long = 0
Private Const OFN_SHARENOWARN As Long = 1
Private Const OFN_SHOWHELP As Long = &H10

Public Sub ListSaveAs()
' Definition der Variablen
Dim myOLApp
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
Dim myOlSel As Outlook.Selection
Dim myOlExp As Outlook.Explorer
Dim MsgTxt As String
Dim strText As String
Dim strMail As MailItem
Dim antw, x As Integer
' Mail-Eingangsordner festlegen
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
' Markierter Eintrag
On Error Resume Next
' Ansicht auf Eingangsordner
'Set Application.ActiveExplorer.CurrentFolder = _
    myNameSpace.GetDefaultFolder(olFolderInbox)
Set myOlExp = Outlook.ActiveExplorer
' Markierte Mails zuweisen
Set myOlSel = myOlExp.Selection
' Alle markierten Mails durchlaufen
For x = 1 To myOlSel.Count
  Set myItem = myOlSel.Item(x)
  If myItem Is Nothing Then
    MsgBox "Nichts markiert"
  End If
  On Error GoTo 0
    ' Exportieren
    fkt_Export myItem
  Next x
' Aufräumen
Set myItem = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
Set myfolder = Nothing
Set myNameSpace = Nothing
End Sub

Function fkt_Export(ByRef myItem As MailItem)
Dim datum, Pfad, absender, Betreff, dateiname, antwort, Zeit, adresse
Dim myuser As Object
Dim ret As String
Dim antw As String
Dim sDate As Date
If myItem Is Nothing Then Exit Function
datum = Format(myItem.SentOn, "dd.mm.yyyy")  ' Festlegung des Datumsformats für den Dateinamen
Zeit = Format(myItem.SentOn, "hh-mm-ss")      ' Festlegung des Zeitformats für den Dateinamen

adresse = myItem.To
absender = myItem.SenderName
sDate = myItem.ReceivedTime
Set myuser = Application.GetNamespace("MAPI").CurrentUser
If absender = "" Then
  absender = myuser
  datum = Format(Date, "dd.mm.yyyy")
  Zeit = Format(Time, "hh-mm-ss")
End If

Betreff = myItem.Subject
Betreff = Replace(Betreff, ":", "_")
Betreff = Replace(Betreff, Chr$(34), "_")
Betreff = Replace(Betreff, "<", "_")
Betreff = Replace(Betreff, ">", "_")
Betreff = Replace(Betreff, "?", "_")
Betreff = Replace(Betreff, "/", "_")
Betreff = Replace(Betreff, "\", "_")
Betreff = Replace(Betreff, "*", "_")
Betreff = Replace(Betreff, ".", ". ")
dateiname = Pfad & datum & " " & Zeit & " _ AN " & adresse & " _ VON " & absender & " _ BETR " & Betreff
ret = fkt_FileSaveAs(dateiname)
If ret <> "" Then
myItem.SaveAs ret, olMSG
'antw = fkt_setTime(ret, sDate)
End If
End Function

Function fkt_FileSaveAs(sName) As String
'Dim sFilters As String
Dim intError As Integer
' Formattyp-Filter festlegen

With OFName
  'Setzt die Größe der OPENFILENAME Struktur
  .lStructSize = Len(OFName)
  'Der Window Handle ist bei VBA fast immer &O0
  .hwndOwner = &O0
  ' Formattyp-Filter setzen
  .lpstrFilter = "Nachrichtenformat (*.msg)"
  ' Buffer für Dateinamen erzeugen
  .lpstrFile = sName & Space$(1024) & vbNullChar & vbNullChar
  ' Maximale Anzahl der Dateinamen-Zeichen
  .nMaxFile = Len(.lpstrFile)
  ' Buffer für Titel erzeugen
  .lpstrFileTitle = sName
  ' Maximale Anzahl der Titel-Zeichen
  .nMaxFileTitle = 255
  ' Anfangsverzeichnis vorgeben
  .lpstrInitialDir = "p:\"
  .lpstrDefExt = "msg"
  ' Titel des Dialogfester festlegen
  .lpstrTitle = "Datei speichern"
  ' Flags zum Festlegen eines bestimmten Verhaltens,
  ' OFN_LONGNAMES = lange Dateinamen verwenden
  ' OFN_OVERWRITEPROMPT = Abfrage vorm Überschreiben
  .flags = OFN_LONGNAMES Or OFN_OVERWRITEPROMPT
End With
' API aufrufen und evtl. Fehler abfangen
intError = GetSaveFileName(OFName)
If intError <> 0 Then
  fkt_FileSaveAs = Left(OFName.lpstrFile, InStr(1, OFName.lpstrFile, Chr(0)) - 1)
ElseIf intError = 0 Then
  ' Abbruch durch Benutzer oder Fehler
  fkt_FileSaveAs = ""
End If
End Function

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP