Ich habe ein Programm zum Speichern von Mails und möchte in die spalte"geädnert am" den Zeitstempel des Versendens/Empfangens haben, hier der Code, funktioniert aber noch nicht, ist aber doch was mit "setFileTime" oder???
Option Explicit
Private Declare Function OpenFile Lib "kernel32" (ByVal _
lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal _
wStyle As Long) As Long
Private Declare Function SetFileTime Lib "kernel32" (ByVal _
hFile As Long, lpCreationTime As FILETIME, _
lpLastAccessTime As FILETIME, lpLastWriteTime As _
FILETIME) As Long
Private Declare Function SystemTimeToFileTime Lib "kernel32" _
(lpSystemTime As SYSTEMTIME, lpFileTime As FILETIME) _
As Long
Private Declare Function LocalFileTimeToFileTime Lib "kernel32" _
(lpFileTime As FILETIME, lpLocalFileTime As FILETIME) _
As Long
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" _
Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private OFName As OPENFILENAME
Private Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Const OF_READ = &H0
Const OF_WRITE = &H1
Const OFS_MAXPATHNAME = 128
Private Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type
Private Type SYSTEMTIME
wYear As Integer
wMonth As Integer
wDayOfWeek As Integer
wDay As Integer
wHour As Integer
wMinute As Integer
wSecond As Integer
wMilliseconds As Integer
End Type
Dim hFile&, DTformat$
Dim sTime As SYSTEMTIME
Dim OFS As OFSTRUCT
Dim cTime As FILETIME
Dim lTime As FILETIME
Dim lwTime As FILETIME
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
'Dim datum, Pfad, absender, Betreff, Dateiname, antwort, Zeit
Sub myFileSaveAs()
' definition der Variablen
Dim myOLApp As Object
Dim myInspector As Inspector
Dim myItem As MailItem
Dim myuser As Object
Dim myNameSpace As NameSpace
Dim myfolder As MAPIFolder
On Error Resume Next
Set myOLApp = GetObject(, "Outlook.Application")
'If myOLApp Is Nothing Then 'Läuft noch nicht
' Set myOLApp = CreateObject("Outlook.Application")
'End If
Set myInspector = Application.ActiveInspector
Set myItem = myInspector.CurrentItem
Set myuser = Application.GetNamespace("MAPI").CurrentUser
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myItem = myOLApp.ActiveInspector.CurrentItem
fkt_Export myItem
Set myNameSpace = Nothing
Set myfolder = Nothing
End Sub
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 antw, x As Integer
' Mail-Ordner
Set myNameSpace = Outlook.GetNamespace("MAPI")
Set myfolder = myNameSpace.GetDefaultFolder(olFolderInbox)
On Error Resume Next
Set myOlExp = Outlook.ActiveExplorer
Set myOlSel = myOlExp.Selection
' Markierte Einträge
For x = 1 To myOlSel.Count
' MsgTxt = MsgTxt & myOlSel.Item(x).SenderName & Chr(13)
'Debug.Print MsgTxt
Set myItem = myOlSel.Item(x)
If myItem Is Nothing Then
MsgBox "Nichts markiert"
End If
On Error GoTo 0
fkt_Export myItem
Next 'x
Set myNameSpace = Nothing
Set myfolder = Nothing
End Sub
Function fkt_Export(ByRef myItem As MailItem)
Dim datum, Pfad, absender, Betreff, Dateiname, antwort, Zeit
Dim myuser As Object
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
absender = myItem.SenderName
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, "*", "_")
Dateiname = Pfad & absender & " - " & Betreff & " - " & datum & " " & Zeit
On Error GoTo fehler
myItem.SaveAs fkt_FileSaveAs(Dateiname), olMSG
On Error GoTo fehler
OFS.cBytes = Len(OFS)
hFile = OpenFile(Dateiname, OFS, OF_WRITE)
If hFile > 0 Then
cTime = CalcNewfTime((datum))
lTime = CalcNewfTime((datum))
lwTime = CalcNewfTime((datum))
Call SetFileTime(hFile, cTime, lTime, lwTime)
Call CloseHandle(hFile)
End If
GoTo ende:
fehler:
MsgBox "Fehler beim Speichern, Dateinamen prüfen!"
ende:
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 = "c:\temp"
.lpstrDefExt = ".msg"
' Titel des Dialogfester festlegen
.lpstrTitle = "Datei speichern"
' Flags zum Festlegen eines bestimmten Verhaltens,
' OFN_LONGNAMES = lange Dateinamen verwenden
' OFN_OVERWRITEPROMPT = Abfrage vorm =DCberschreiben
.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
End If
End Function
'----------------
Private Function CalcNewfTime(datum$) As FILETIME
Dim SysT As SYSTEMTIME
Dim FT As FILETIME
Dim FT1 As FILETIME
With SysT
.wDay = CInt(Left$(datum, 2))
.wMonth = CInt(Mid$(datum, 4, 2))
.wYear = CInt(Mid$(datum, 7, 4))
.wHour = CInt(Mid$(datum, 12, 2))
.wMinute = CInt(Mid$(datum, 15, 2))
.wSecond = CInt(Mid$(datum, 18, 2))
End With
Call SystemTimeToFileTime(SysT, FT1)
Call LocalFileTimeToFileTime(FT1, FT)
CalcNewfTime = FT
End Function