Munteres Moin moin in die Runde,
Ich hatte mir von der Seite des Computerwissen Clubs die Excel-Datei „Termin Export.xla“ heruntergeladen, um Bereiche des Outlook-Kalenders in eine Exceltabelle zu exportieren.
Leider scheint diese Datei nur für 32 bit Systeme ausgelegt zu sein, denn ich erhalte jedes Mal beim Öffnen folgende Fehlermeldung:
„Fehler beim Kombilieren:
Der Code in diesem Projekt muss für die Verwendung auf 64-bit Systemen aktualisiert werden. Überarbeiten und aktualisieren Sie Declare-Anweisungen, und markieren Sie sie mit dem Ptrsafe Attribut.“
Leider für mich nur Kauderwelsch.
Falls mir jmd. helfen könnte wäre ich sehr dankbar. In Verwendung:
Outlook 2013
Windows 7 64 bit
beste Grüße und herzlichen Dank vorab.
Stephan
Hier der Quelltext:
´
´(C) Martin Althaus 2004
´
Declare Function GetWindowsDirectoryA Lib „KERNEL32“ (ByVal Puffer As String, ByVal groesse As Integer) As Integer
Declare Function GetWindowsDirectory Lib „KERNEL32“ (ByVal Puffer As String, ByVal groesse As Integer) As Integer
Private Declare Function ShellExecute Lib „shell32.dll“ Alias „ShellExecuteA“ (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Public Type PfadTyp
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
Declare Function SHGetPathFromIDList Lib „shell32.dll“ Alias „SHGetPathFromIDListA“ (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Function SHBrowseForFolder Lib „shell32.dll“ Alias „SHBrowseForFolderA“ (lpBrowseInfo As PfadTyp) As Long
Public Declare Function FindFirstFile Lib „KERNEL32“ Alias „FindFirstFileA“ _
(ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
Public Declare Function FileTimeToSystemTime Lib „KERNEL32“ _
(lpFileTime As FILETIME, lpSystemTime As SYSTEMTIME) As Long
Declare Function FileTimeToLocalFileTime Lib „KERNEL32“ _
(lpFileTime As FILETIME, lpLocalFileTime As FILETIME) As Long
Public Type FILETIME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public 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 Long
End Type
Public Type WIN32_FIND_DATA
dwFileAttributes As Long
ftCreationTime As FILETIME
ftLastAccessTime As FILETIME
ftLastWriteTime As FILETIME
nFileSizeHigh As Long
nFileSizeLow As Long
dwReserved0 As Long
dwReserved1 As Long
cFileName As String * 260
cAlternate As String * 14
End Type
Sub WebSiteAufrufen(Url As String)
On Error Resume Next
ShellExecute 0&, vbNullString, Url, vbNullString, vbNullString, vbNormalFocus
On Error GoTo 0
End Sub
Function WaehleVerzeichnis(Optional Meldung) As String
On Error Resume Next
Dim bInfo As PfadTyp
Dim path As String
Dim r As Long, x As Long, pos As Integer
bInfo.pidlRoot = 0&
If IsMissing(Meldung) Then
bInfo.lpszTitle = „Wählen Sie einen Archivierungspfad:“
Else
bInfo.lpszTitle = Meldung
End If
bInfo.ulFlags = &H1
x = SHBrowseForFolder(bInfo)
path = Space$(512)
r = SHGetPathFromIDList(ByVal x, ByVal path)
If r Then
pos = InStr(path, Chr$(0))
WaehleVerzeichnis = Left(path, pos – 1)
Else
WaehleVerzeichnis = „“
End If
On Error GoTo 0
End Function
Sub auto_open()
On Error Resume Next
MenuBars(xlWorksheet).Menus(4).MenuItems.Add OnAction:=“TermineEinfuegen“, Caption:=“Outlook-&Termine als Liste importieren“
On Error GoTo 0
End Sub
Sub auto_close()
On Error Resume Next
MenuBars(xlWorksheet).Menus(4).MenuItems(„Outlook-Termine als Liste importieren“).Delete
On Error GoTo 0
End Sub
Sub TermineEinfuegen()
On Error Resume Next
UserForm1.Label7.Caption = „Startdatum für den Import: (nicht festgelegt)“
UserForm1.Label8.Caption = „Enddatum für den Import: (nicht festgelegt)“
UserForm1.Show
On Error GoTo 0
End Sub
Sub Lesen()
On Error Resume Next
Dim oOL As Object
Dim myitem As Object
Dim oEntry As Object
Dim iCounter, startzeile, anzahl, canzahl, i, j, tzaehler As Integer
Dim datum, betreff, ort, beginn, ende, ganztaegigeinaus, erinnerungeinaus, erinnerungszeitpunkt, importieren As Boolean
Dim bln, zesp As Boolean
Dim Bereich As Range
Dim tw, tw2, ne As Worksheet
´UserForm1.Hide
bln = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Set oOL = CreateObject(„Outlook.Application“)
Set tw = ThisWorkbook.Worksheets(1)
If UserForm1.OptionButton1 = True Then
Set ne = ActiveWorkbook.Worksheets.Add
Else
Set ne = Workbooks.Add.Worksheets(1)
End If
i = 1
With UserForm1
If .CheckBox1 = True Then
datum = True
ne.Cells(1, i).Formula = „Datum“
i = i + 1
Else
datum = False
End If
If .CheckBox4 = True Then
betreff = True
ne.Cells(1, i).Formula = „Betreff“
i = i + 1
Else
betreff = False
End If
If .CheckBox5 = True Then
ort = True
ne.Cells(1, i).Formula = „Ort“
i = i + 1
Else
ort = False
End If
If .CheckBox7 = True Then
beginn = True
ne.Cells(1, i).Formula = „Beginn“
i = i + 1
Else
beginn = False
End If
If .CheckBox6 = True Then
ende = True
ne.Cells(1, i).Formula = „Ende“
i = i + 1
Else
ende = False
End If
If .CheckBox8 = True Then
ganztaegigeinaus = True
ne.Cells(1, i).Formula = „Ganztägig Ein/Aus“
i = i + 1
Else
ganztaegigeinaus = False
End If
If .CheckBox3 = True Then
erinnerungeinaus = True
ne.Cells(1, i).Formula = „Erinnerung Ein/Aus“
i = i + 1
Else
erinnerungeinaus = False
End If
If .CheckBox2 = True Then
erinnerungszeitpunkt = True
ne.Cells(1, i).Formula = „Erinnerungszeitpunkt“
i = i + 1
Else
erinnerungszeitpunkt = False
End If
End With
With ThisWorkbook.Worksheets(1)
.Range(„e16“).Formula = UserForm1.Label7.Caption
.Range(„e17“).Formula = UserForm1.Label8.Caption
End With
Set myNamespace = oOL.GetNamespace(„MAPI“)
Set mytermine = myNamespace.GetDefaultFolder(9).items ´olfoldercalendar
canzahl = mytermine.Count
i = 2
For j = 1 To canzahl
ThisWorkbook.Worksheets(1).Range(„a1“) = mytermine(j).Start
If ThisWorkbook.Worksheets(1).Range(„e8“).Value = True Then ´Termin liegt im Bereich?
importieren = False
If UserForm1.OptionButton10 = True Then importieren = True
If (UserForm1.OptionButton7 = True) And (mytermine(j).reminderset = True) Then importieren = True
If (UserForm1.OptionButton8 = True) And (mytermine(j).reminderset = False) Then importieren = True
If importieren = True Then
importieren = False
If UserForm1.OptionButton9 = True Then importieren = True
If (UserForm1.OptionButton5 = True) And (mytermine(j).alldayevent = True) Then importieren = True
If (UserForm1.OptionButton6 = True) And (mytermine(j).alldayevent = False) Then importieren = True
End If
If importieren Then
k = 1
If datum Then
ne.Cells(i, k).Formula = tw.Range(„a4“).Value
k = k + 1
End If
If betreff Then
ne.Cells(i, k).Formula = mytermine(j).Subject
k = k + 1
End If
If ort Then
If mytermine(j).Location = „“ Then
ne.Cells(i, k).Formula = „(kein)“
Else
ne.Cells(i, k).Formula = mytermine(j).Location
End If
k = k + 1
End If
If beginn Then
ne.Cells(i, k).Formula = tw.Range(„a5“).Text
k = k + 1
End If
If ende Then
tw.Range(„e10“).Value = mytermine(j).Duration
ne.Cells(i, k).Formula = tw.Range(„e12“).Text
k = k + 1
End If
If ganztaegigeinaus Then
ne.Cells(i, k).Formula = mytermine(j).alldayevent
k = k + 1
End If
If erinnerungeinaus Then
ne.Cells(i, k).Formula = mytermine(j).reminderset
k = k + 1
End If
If erinnerungszeitpunkt Then
If mytermine(j).reminderset = True Then
tw.Range(„e10“).Value = mytermine(j).reminderminutesbeforestart
ne.Cells(i, k).Formula = tw.Range(„e13“).Text
End If
k = k + 1
End If
i = i + 1
End If
End If
Next j
ne.Cells(1, 1).EntireRow.Font.Bold = True
ne.Activate
ne.Range(„a1“).Select
Selection.AutoFilter
For j = 1 To k – 1
ne.Cells(1, j).EntireColumn.AutoFit
Next j
ne.Range(Cells(1, 1), Cells(i – 1)).Sort Key1:=Range(„A2“), Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set oOL = Nothing
Application.StatusBar = False
Application.DisplayStatusBar = bln
Application.ScreenUpdating = True
´ UserForm1.Hide
On Error GoTo 0
End Sub