|
Hallo liebe Community,
ich brauche eure Hilfe.
Wie müsste ich den folgenden Code ergänzen, sodass ich bei der Ordnerauswahl, alle Ordner zu sehen bekommen. (Am wichtigsten: Die Verknüpfungen).
Vielen Dank im Voraus für eure Tipps!
Option Explicit
Function BrowseForFolder(Optional OpenAt As Variant) As Variant
Dim ShellApp As Object
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Bitte den Ordner auswählen:", &H1000, OpenAt)
'Set BrowseDir = ShellApp.BrowseForFolder(0, "Bitte Ordner auswählen", &H4000, OpenAt)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0
Set ShellApp = Nothing
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select
Exit Function
Invalid:
BrowseForFolder = False
End Function
Public Sub speichern()
Dim oMail As Outlook.mailitem
Dim objItem As Object
Dim sPath, strFolderpath As String
Dim dtDate As Date
Dim sName As String
Dim enviro As String
enviro = CStr(Environ("USERPROFILE"))
strFolderpath = BrowseForFolder
sPath = strFolderpath & "\"
For Each objItem In ActiveExplorer.Selection
If objItem.MessageClass = "IPM.Note" Then
Set oMail = objItem
sName = oMail.Subject
ReplaceCharsForFileName sName, "-"
dtDate = oMail.ReceivedTime
sName = Format(dtDate, "yyyy-mm-dd", vbUseSystemDayOfWeek, _
vbUseSystem) & " " & "-" & " " & UCase(Split(Trim(Split(objItem.SenderEmailAddress, "@")(0)), ".")(1)) & " " & "-" & " " & sName & ".msg"
Debug.Print sPath & sName
sName = InputBox( _
prompt:="Dateiname. Bei Fertigstellung OK klicken.", _
Default:=sName)
oMail.SaveAs sPath & sName, olMSG
End If
Next
End Sub
Private Sub ReplaceCharsForFileName(sName As String, _
sChr As String _
)
sName = Replace(sName, "'", sChr)
sName = Replace(sName, "*", sChr)
sName = Replace(sName, "/", sChr)
sName = Replace(sName, "\", sChr)
sName = Replace(sName, ":", sChr)
sName = Replace(sName, "?", sChr)
sName = Replace(sName, Chr(34), sChr)
sName = Replace(sName, "<", sChr)
sName = Replace(sName, ">", sChr)
sName = Replace(sName, "|", sChr)
End Sub
|