Anzeige
Archiv - Navigation
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
240to244
240to244
Aktuelles Verzeichnis
Verzeichnis Index
Verzeichnis Index
Übersicht Verzeichnisse
Inhaltsverzeichnis

Beim Speichern von Mails, Zeitstempel übernehmen

Beim Speichern von Mails, Zeitstempel übernehmen
04.04.2003 12:17:27
Steffi
Hallo!
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

3
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
Re: Beim Speichern von Mails, Zeitstempel übernehmen
04.04.2003 18:10:18
GerdZ
Hallo Steffi,

eventuell ist das Setzen der Zeit mit OpenFile nicht möglich.
Bei der Beschreibung zur SetFileTime-API-Funktion auf allapi.net ist angegeben, daß die Datei mit GENERIC_WRITE-Access geöffnet sein muß. Im Beispiel dazu wird die CreateFile-API-Funktion zum Öffnen benutzt.


Handle = CreateFile(Filename, GENERIC_WRITE, FILE_SHARE_READ Or FILE_SHARE_WRITE, ByVal 0&, OPEN_EXISTING, 0, 0)

Gruß
Gerd
Danke aber...
07.04.2003 10:16:54
Steffi
Hi, vielen Dank erstmal, aber die ganzen Variablen, wie definiere ich die denn?????
http://www.allapi.net/
07.04.2003 15:39:55
GerdZ
Hallo Steffi,

schau Dir die Beschreibung und Beispiele dazu auf allapi.net an
http://www.mentalis.org/apilist/CreateFile.shtml
oder installiere Dir den API-Guide von dort.

Gruß
Gerd


Anzeige

300 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige