Bei Outlook "Freigegebene Kalender" ansprechen und nicht die StandardMAPI

  • Outlook

Es gibt 52 Antworten in diesem Thema. Der letzte Beitrag () ist von Kleiner_VBAler.

    Bei Outlook "Freigegebene Kalender" ansprechen und nicht die StandardMAPI

    Hallo liebes Forum,
    ich habe da ein kleines Problem und komme einfach nicht weiter. Es geht um folgendes: Ich möchte aus einem "Freigegebenen Kalender" bei Outlook einen bestimmten Kalender ansprechen und den Dateninhalt als HTML Datei anzeigen lassen. Das Ganze funktioniert mit dem Standard Kalender ganz gut, nicht aber mit einem von den freigegebenen, da ich nicht weiß wie ich diese ansprechen soll... Es ist wahrscheinlich einfach nur eine Kleinigkeit, da ich aber blutiger Anfänger bin fällt es mir doch sehr schwer...
    Das Programm funktioniert super und tut auch was es soll.. nur eben nicht mit dem freigegebenen Kalender, sondern mit einem der Kalender die unter "Meine Kalender" bei Outlook zu finden sind.

    Ich würde mich wirklich freuen, wenn jemand mal über den Code schauen könnte und mir evtl. helfen kann.
    Vielen Dank und viele Grüße an euch.
    Alex

    Spoiler anzeigen

    Quellcode

    1. DisplayYearlyCalendar()
    2. Sub DisplayYearlyCalendar()
    3. 'copyright Nick Roemer
    4. 'http://niveauverleih.blogspot.com/
    5. 'version 2.1, 22 Jan 2009
    6. 'this script (formerly: macro) will display the Outlook appointments over a period of several months
    7. 'or an empty calendar to print out
    8. 'the output is are 2 html files (1 portrait, 1 landscape) that are displayed with Internet Explorer
    9. 'Safe this file as "Yearly calendar v2.vbs" and doubleclick the resulting file to run the script
    10. '-----------------------------------------------------------------------------------------------
    11. 'some necessary objects and constants
    12. Const ForWriting = 2
    13. Set objShell = CreateObject("WScript.Shell")
    14. strTempFolder = objShell.ExpandEnvironmentStrings("%TEMP%") & "\YearCalendar"
    15. Set objFSO = CreateObject("Scripting.FileSystemObject")
    16. If NOT objFSO.FolderExists(strTempFolder) Then
    17. objFSO.CreateFolder strTempFolder
    18. End If
    19. Set OL = createObject("Outlook.Application")
    20. Set onNamespace = OL.GetNamespace("MAPI")
    21. 'SELECT THE MAILBOX / CALENDAR TO BE DISPLAYED
    22. 'Choose between options A, B and C
    23. 'uncomment the chosen code paragraph
    24. '--- A --- you specifiy the name of the mailbox that contains the calendar you need
    25. 'strMailbox = "MBX -- ServiceDesk"
    26. 'results = split (GetExchangeServer(strMailbox),"|")
    27. 'strServer = ""
    28. 'on error resume next
    29. 'strServer = results(1)
    30. 'strFolderName = results(0)
    31. 'on error goto 0
    32. 'Set MyCalendar = onNamespace.Folders(strFolderName).Folders("Calendar") 'if you want to indicate a calendar in a different mailbox
    33. 'OR --- B --- You pick a CALENDAR (If you have several)
    34. Set MyCalendar = onNamespace.PickFolder 'if you want to select your calendar folder manually (if you have several)
    35. strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
    36. results = split (GetExchangeServer(strMailbox),"|")
    37. strServer = ""
    38. on error resume next
    39. strServer = results(1)
    40. on error goto 0
    41. 'OR --- C --- You simply use the default calendar
    42. 'Set MyCalendar = onNamespace.GetDefaultFolder(9) ' if you want to use the default calendar
    43. 'strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
    44. 'results = split (GetExchangeServer(strMailbox),"|")
    45. 'strServer = ""
    46. 'on error resume next
    47. 'strServer = results(1)
    48. 'on error goto 0
    49. 'FILTER CATEGORIES
    50. 'list here the categories that you want to hide
    51. arrExcludeCategories = Array()
    52. 'arrExcludeCategories = Array("Personal", "StaffMeetings")
    53. 'HIDE PRIVATE APPOINTMENTS
    54. 'Set this to TRUE if you want to display private appointments
    55. Const blShowPrivateAppointments = TRUE
    56. 'ALIGN BY WEEKDAY / DAY-OF-MONTH
    57. 'Set this to FALSE if you want the rows to be the day of month (1,2, ...31) iso. the days of the week (Mo .. Fri)
    58. Const blAlignWeekDays = True
    59. 'ONLY ALL-DAY-EVENTS
    60. 'Set this to TRUE if you want to display AllDayEvents only
    61. blAllDayEventsOnly = False
    62. 'COLORS used
    63. 'colors from http://web.njit.edu/~kevin/rgb.txt.html
    64. Const wheat_light = "#EED8AE"
    65. Const wheat_dark = "#CDBA96"
    66. Const seashell = "#EEE5DE"
    67. Const silver = "#C0C0C0"
    68. Const cornsilk = "#FFF8DC"
    69. 'NAME AND LOCATION OF HTML OUTPUT FILES
    70. strHtmlFile = strTempFolder & "\YearlyCalendar.html"
    71. strHtmlFileTransposed = strTempFolder & "\YearlyCalendarTransposed.html"
    72. strHtmlFile7Columns = strTempFolder & "\YearlyCalendar7Columns.html"
    73. 'SCRIPT BEGIN
    74. 'ASKING FOR TIMESPAN TO BE DISPLAYED
    75. 'ENTER 13 for next January etc.
    76. StartMonth = InputBox("Start Month", "Start Month", Month(Date))
    77. If StartMonth = "" Then Exit Sub
    78. StartMonth = CInt(StartMonth)
    79. EndMonth = InputBox("End Month", "End Month", StartMonth - 1)
    80. If EndMonth = "" Then Exit Sub
    81. EndMonth = CInt(EndMonth)
    82. If EndMonth < StartMonth Then
    83. NbMonths = EndMonth - StartMonth + 13
    84. EndMonth = EndMonth + 12
    85. Else
    86. NbMonths = EndMonth - StartMonth + 1
    87. End If
    88. 'DISPLAY EMPTY CALENDAR?
    89. strEmptyCalendar = vbNo
    90. 'strEmptyCalendar = MsgBox("Empty Calendar?", vbYesNo + vbDefaultButton2)
    91. dim arrTable(100,100) 'array used to created the transposed version of the calendar
    92. 'Create Table: 1 Header Row
    93. ' 7 days x 5 weeks = 35 day rows
    94. ' 1 Header column
    95. ' 1 column for each month
    96. strHeader = "<head><title>Yearly Calendar</title></head>"
    97. 'NOTE: We are trying to use the available space efficiently to put all appointments on one sheet of paper
    98. 'You should play around with the "font-size:50%" bit, depending on how packed your calendar is
    99. strTableHeader = Contents & vbCrLf & "<table width=100% border=1 style='font-family:verdana;font-size:50%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    100. 'header row
    101. Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & seashell & "'>"
    102. Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
    103. arrTable(0,0) = "<TD name='tableHeader' style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
    104. 'First Row/col
    105. intYear = Year(Date)
    106. nextYear = intYear + 1
    107. k = 0
    108. LastRowOfTable = 0
    109. For i = StartMonth To EndMonth
    110. k = k+1
    111. MonthInNumbers = i
    112. If i > 12 Then
    113. MonthInNumbers = i - 12
    114. intYear = nextYear
    115. End If
    116. 'Determine the last Row of the Table
    117. StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
    118. StrMonthEndsOnA = day(dateserial(intYear,i+1,0))
    119. LastRowOfMonth = StrMonthStartsOnA + StrMonthEndsOnA - 1
    120. If LastRowOfMonth > LastRowOfTable Then LastRowOfTable = LastRowOfMonth
    121. Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:" & Int(100 / NbMonths) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
    122. arrTable(0,k) = "<TD name='tableHeader' style='border-color:gray;width:" & Int(100 / LastRowOfTable) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
    123. Next
    124. Contents = Contents & vbCrLf & "</TR>"
    125. If strEmptyCalendar = vbNo Then
    126. Set MyFolder = MyCalendar.Items
    127. storeID = MyCalendar.storeID
    128. MyFolder.IncludeRecurrences = True
    129. MyFolder.Sort "[Start]"
    130. 'create CDO session in order to get appointment label colors
    131. strProfileInfo = strServer & vbLf & strMailbox
    132. 'You must add a Reference to Microsoft CDO version 1.21.
    133. On Error Resume next
    134. Set objCDO = CreateObject("MAPI.Session")
    135. 'IMPORTANT: log on using a new MAPI session with a dynamically created profile
    136. 'we can't simply reuse the existing MAPI session -> script will not retrieve colors for all appointments
    137. objCDO.Logon "", "", False, True, 0, False, strProfileInfo & "rtrtrtr"
    138. ErrNum = err.number
    139. On Error GoTo 0
    140. If ErrNum<>0 Then
    141. MsgBox "Could not create MAPI session to retrieve appointment colors. Will continue without colors."
    142. End If
    143. End If
    144. 'Day Rows
    145. RowCount = 0
    146. For week = 1 To 6 'The macro was originally written for the case blAlignWeekDays = True
    147. For intWeekday = 1 To 7 'Therefore I used a double loop: weeks then weekdays
    148. ColCount = 0
    149. RowCount = RowCount + 1
    150. 'First column
    151. Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & bgcolor & "'>"
    152. If blAlignWeekDays Then
    153. Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'>" & WeekdayName(intWeekday, False, vbMonday) & "</TD>"
    154. arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'>" & left(WeekdayName(intWeekday, False, vbMonday),2) & "</TD>"
    155. Else
    156. Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
    157. arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
    158. End If
    159. ColCount = ColCount + 1
    160. intYear = Year(Date)
    161. 'Month columns
    162. For i = StartMonth To EndMonth
    163. MonthInNumbers = i
    164. If i > 12 Then
    165. MonthInNumbers = i - 12
    166. intYear = nextYear
    167. End If
    168. StrMonthStartsOnA = 1
    169. If blAlignWeekDays Then 'e.g. if the first of the month falls on a Friday
    170. ' we need to put some grey cells before the month begins
    171. StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
    172. End If
    173. 'Ne
    174. If i=StartMonth Then StrFirstMonthStartsOnA = StrMonthStartsOnA
    175. intDayOfMonth = 0
    176. If RowCount >= StrMonthStartsOnA Then
    177. intDayOfMonth = RowCount - StrMonthStartsOnA + 1
    178. End If
    179. 'calculate date for current cell
    180. strDate = ""
    181. If intDayOfMonth > 0 Then
    182. On Error Resume Next
    183. strDate = CDate(CStr(intDayOfMonth) & " " & MonthName(MonthInNumbers) & ", " & CStr(intYear))
    184. On Error GoTo 0
    185. End If
    186. 'color weekends
    187. intRealWeekday = intWeekday
    188. If Not blAlignWeekDays Then
    189. On Error Resume Next
    190. intRealWeekday = Weekday(strDate)
    191. On Error GoTo 0
    192. End If
    193. bgcolor = "#FFFFFF"
    194. If (i Mod 2 = 0) Then bgcolor = cornsilk
    195. Select Case intRealWeekday
    196. Case 6
    197. bgcolor = wheat_light
    198. Case 7
    199. bgcolor = wheat_dark
    200. End Select
    201. 'grey out empty cells
    202. dispDate = ""
    203. dispDateTransposed = ""
    204. If strDate = "" Then
    205. bgcolor = silver
    206. ElseIf blAlignWeekDays Then
    207. strShortMonth = MonthName(MonthInNumbers, True)
    208. strShortMonthTransposed = strShortMonth
    209. If Weekday(strDate) = 1 Or Weekday(strDate) = 7 Then strShortMonthTransposed = ""
    210. dispDate = "<b>" & Day(strDate) & " " & strShortMonth & "</b>"
    211. dispDateTransposed = "<b>" & Day(strDate) & " " & strShortMonthTransposed & "</b>"
    212. Else 'if blAlignWeekDays = False
    213. dispDate = "<b>" & Day(strDate) & " " & WeekdayName(intRealWeekday, True, vbSunday) & "</b>"
    214. dispDateTransposed = dispDate
    215. End If
    216. 'display date
    217. Contents = Contents & vbCrLf & "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDate & " "
    218. arrTable(RowCount,ColCount) = "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDateTransposed & " "
    219. 'display appointments
    220. If strEmptyCalendar = vbNo Then
    221. strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
    222. strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
    223. strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
    224. strRestriction = strRestriction & " AND [Duration] > 0"
    225. If strDate = "" Then strRestriction = "[Start] = 1" 'no result
    226. Set myRestrictItems = MyFolder.Restrict(strRestriction)
    227. myRestrictItems.Sort "[Start]"
    228. 'Contents = Contents & vbCrLf & myRestrictItems.Count & "<br>"
    229. For Each myitem In myRestrictItems
    230. blDisplay = True
    231. 'check if this appointment is in a category that we want to hide
    232. For Each strCat2Exclude In arrExcludeCategories
    233. If InStr(myitem.Categories, strCat2Exclude) Then blDisplay = False
    234. Next
    235. 'check if this is a private appointment
    236. If blShowPrivateAppointments = False And myitem.Sensitivity = 2 Then blDisplay = False
    237. blIsAllDayEvent = myitem.AllDayEvent
    238. If blAllDayEventsOnly And Not blIsAllDayEvent Then blDisplay = False
    239. 'Display the appointment
    240. If blDisplay Then
    241. strTime = ""
    242. If Not blIsAllDayEvent Then
    243. strTime = "<br>" & Hour(myitem.Start) & ":" & Left(Minute(myitem.Start) & "0",2)
    244. strTime = strTime & "-" & Hour(myitem.End) & ":" & Left(Minute(myitem.End) & "0",2) & " "
    245. End If
    246. 'getting color
    247. 'MsgBox myitem & vbcr & vbcr & storeID & vbcr & vbcr & objCDO
    248. strColor = GetColor(myitem, storeID, onNameSpace)
    249. Contents = Contents & strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
    250. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount)& strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
    251. End If
    252. Next 'myitme In myRestrictItems
    253. Else 'i.e; If strEmptyCalendar = vbYes
    254. Contents = Contents & "<br><br>"
    255. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & "<br><br>"
    256. End If 'If strEmptyCalendar = vbNo
    257. Contents = Contents & vbCrLf & "</TD>"
    258. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & vbCrLf & "</TD>"
    259. ColCount = ColCount + 1
    260. Next 'For i = StartMonth To EndMonth
    261. Contents = Contents & vbCrLf & "</TR>"
    262. If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For 'latest possible day in last week is Tuesday (31 days from Sunday)
    263. If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
    264. Next 'For intWeekday = 1 To 7
    265. If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
    266. If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For
    267. Next 'For week = 1 To 6
    268. 'create transposed contents
    269. tcontents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    270. for i=0 to NbMonths
    271. tcontents = tcontents & "<TR valign='top' bgcolor='" & seashell & "'>"
    272. for j=0 to LastRowOfTable
    273. tcontents = tcontents & arrTable(j,i) & vbCR
    274. next
    275. tcontents = tcontents & "</TR>" & vbCR
    276. Next
    277. tcontents = tcontents & "</table>"
    278. 'create contents "7columns"
    279. c7contents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    280. 'First Row - Weekdaynames
    281. c7contents = c7contents & vbCrLf & "<TR valign='top' bgcolor='gray'>"
    282. For intWeekday = 1 To 7
    283. c7contents = c7contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & WeekdayName(intWeekday, False, vbMonday) & "</b></TD>"
    284. Next
    285. c7contents = c7contents & vbCrLf & "</TR><TR>"
    286. ColCount = 0
    287. 'Add some gray cells
    288. For i=1 To StrFirstMonthStartsOnA-1
    289. c7contents = c7contents & "<TD name='tableHeader' style='border-color:gray'></TD>"
    290. ColCount = ColCount + 1
    291. Next
    292. for i=0 to NbMonths
    293. For j=0 to LastRowOfTable
    294. 'filter out some unneeded cells with the if condition
    295. If InStr(arrTable(j,i),"tableHeader")=0 And InStr(arrTable(j,i),"bgcolor = '" & silver)=0 Then
    296. c7contents = c7contents & arrTable(j,i) & vbCR
    297. ColCount = ColCount +1
    298. End If
    299. If ColCount = 7 Then
    300. ColCount = 0
    301. c7contents = c7contents & "</TR>" & vbCR
    302. c7contents = c7contents & "<TR valign='top' bgcolor='" & seashell & "'>"
    303. End If
    304. next
    305. Next
    306. c7contents = c7contents & "</TR></table>"
    307. 'create the html files
    308. Set filesys = CreateObject("Scripting.FileSystemObject")
    309. Set F = filesys.OpenTextFile(strHtmlFile, ForWriting, True)
    310. F.Write strHeader & strTableHeader & Contents
    311. Set F = Nothing
    312. Set F = filesys.OpenTextFile(strHtmlFileTransposed, ForWriting, True)
    313. F.Write tcontents
    314. Set F = Nothing
    315. Set F = filesys.OpenTextFile(strHtmlFile7Columns, ForWriting, True)
    316. F.Write c7contents
    317. Set F = Nothing
    318. Set filesys = Nothing
    319. 'display the html files
    320. strCommand = "iexplore """ & strHtmlFile & """"
    321. objShell.run (strCommand)
    322. strCommand = "iexplore """ & strHtmlFileTransposed & """"
    323. objShell.run (strCommand)
    324. strCommand = "iexplore """ & strHtmlFile7Columns & """"
    325. objShell.run (strCommand)
    326. 'display containing folder
    327. strCommand = "explorer """ & strTempFolder & """"
    328. objShell.run (strCommand)
    329. Set objShell = Nothing
    330. Set objFSO = Nothing
    331. on error resume next
    332. objCDO.Logoff
    333. on error goto 0
    334. Set objCDO = Nothing
    335. Set MyFolder = Nothing
    336. Set MyCalendar = Nothing
    337. Set onNamespace = Nothing
    338. Set OL = Nothing
    339. End Sub
    340. '*************************************************************************************
    341. '***************** FUNCTIONS **************************************
    342. '*************************************************************************************
    343. Function GetColor(objAppt, storeID, onNamespace)
    344. Colors="FFFFFF E7A1A2 F7DD8F F9BA89 FCFA90 78D168 9FDCC9 C6D2B0 9DB7E8 B5A1E2 DAAEC2 DAD9DC 6B7994 BFBFBF 6F6F6F 4F4F4F C11A25 E2620D C79930 B9B300 368F2B 329B7A 778B45 2858A5 5C3FA3 93446B"
    345. GetColor = ""
    346. If objAppt.Class = 26 Then ' = appointment
    347. Cat = objAppt.categories
    348. If Cat<>"" Then
    349. 'just the first cat
    350. If InStr(Cat, ",") Then Cat=Left(Cat,InStr(Cat, ",")-1)
    351. ColorCode = onNamespace.categories.item(Cat).Color
    352. GetColor = Mid(Colors,ColorCode*7+1,6)
    353. End if
    354. End If
    355. End Function
    356. Public Function GetExchangeServer(strMailbox)
    357. 'Root to where registry stores the outlook settings
    358. MainKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
    359. 'get the default outlook profile option stored in the registry and add it to the key path
    360. Const HKEY_LOCAL_MACHINE = &H80000002
    361. Const HKEY_USERS = &H80000003
    362. strComputer ="."
    363. GetRegKeyStrValue strComputer, HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName", username
    364. Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" & strComputer & "/root/default:StdRegProv")
    365. oReg.EnumKey HKEY_USERS,"", arrSubKeys
    366. 'msgbox MainKeyPath
    367. arrBinary = Array(1, 0)
    368. For i = 0 To UBound(arrBinary)
    369. KeyValue = KeyValue & Chr(arrBinary(i))
    370. Next
    371. For Each subkey In arrSubKeys
    372. sKey = subkey & "\Software\Microsoft\Windows\CurrentVersion\Explorer"
    373. REGusername = ""
    374. GetRegKeyStrValue strComputer, HKEY_USERS, sKey, "Logon User Name", REGusername
    375. If ucase(REGusername)=ucase(username) Then
    376. MainKeyPath = subkey & "\" & MainKeyPath
    377. GetRegKeyStrValue strComputer, HKEY_USERS, MainKeyPath, "DefaultProfile", DefaultProfile
    378. MainKeyPath = MainKeyPath & DefaultProfile
    379. GetRegKeyBinValue strComputer, HKEY_USERS, MainKeyPath & "\9207f3e0a3b11019908b08002b2a56c2", "01023d00", arrBinary
    380. 'msgbox MainKeyPath
    381. 'msgbox MainKeyPath
    382. arrBinary = Array(1, 0)
    383. For i = 0 To UBound(arrBinary)
    384. KeyValue = KeyValue & Chr(arrBinary(i))
    385. Next
    386. For i = 0 To UBound(arrBinary)
    387. KeyValue = KeyValue & Chr(arrBinary(i))
    388. Next
    389. 'msgbox Keyvalue
    390. NumFolders = Len(KeyValue) / 16
    391. For x = 1 To NumFolders
    392. 'Get next key name from list
    393. KeyName = Mid(KeyValue, ((x - 1) * 16) + 1, 16)
    394. KeyName = BinarySTRToText(Trim(KeyName))
    395. PSTKeyName = MainKeyPath & "\" & KeyName
    396. StoreType = ""
    397. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3d09", arrBinary) <> "Failed" Then
    398. For i = 0 To UBound(arrBinary)-2 Step 2
    399. StoreType = StoreType & Chr(arrBinary(i))
    400. Next
    401. End If
    402. IF StoreType = "MSPST MS" or StoreType = "MSUPST MS" Then
    403. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
    404. For i = 0 To UBound(arrBinary)-2 Step 2
    405. strMailboxFound = strMailboxFound & Chr(arrBinary(i))
    406. Next
    407. End If
    408. Else
    409. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
    410. For i = 0 To UBound(arrBinary)-2 Step 2
    411. PstKeyValue = PstKeyValue & Chr(arrBinary(i))
    412. Next
    413. strMailboxfound = PstKeyValue
    414. PstKeyValue = ""
    415. End If
    416. End If
    417. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f662b", arrBinary) <> "Failed" Then
    418. For i = 0 To UBound(arrBinary)-2 Step 2
    419. PstKeyValue = PstKeyValue & Chr(arrBinary(i))
    420. Next
    421. strServer = PstKeyValue
    422. If instr(strMailboxFound, strMailbox) Then
    423. 'MsgBox strMailboxFound & " " & strMailbox
    424. GetExchangeServer = strMailboxFound & "|" & strServer
    425. End If
    426. PstKeyValue = ""
    427. End If
    428. Next
    429. End If
    430. Next
    431. End Function
    432. Function GetRegKeyBinValue(sComputer, hTree, sKey, sValueName, sValue)
    433. Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
    434. lResult = oRegistry.GetBinaryValue(hTree, sKey, sValueName, sValue)
    435. If (lResult = 0) And (Err.Number = 0) Then
    436. GetRegKeyBinValue = "Succeeded"
    437. Else
    438. GetRegKeyBinValue = "Failed"
    439. sValue = ""
    440. End If
    441. Set oRegistry = Nothing
    442. End Function
    443. Function GetRegKeyStrValue(sComputer, hTree, sKey, sValueName, sValue)
    444. Dim oRegistry
    445. Dim lResult
    446. Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
    447. lResult = oRegistry.GetStringValue(hTree, sKey, sValueName, sValue)
    448. If (lResult = 0) And (Err.Number = 0) Then
    449. GetRegKeyStrValue = sValue
    450. Else
    451. GetRegKeyStrValue = "Failed"
    452. sValue = ""
    453. End If
    454. Set oRegistry = Nothing
    455. End Function
    456. Private Function BinarySTRToText(BinaryStr)
    457. For i = 1 To Len(BinaryStr)
    458. xstr = Mid(BinaryStr, i, 1)
    459. xlong = CLng(Asc(xstr))
    460. xvar = Hex(xlong)
    461. xstr = CStr(xvar)
    462. If Len(xstr) = 1 Then xstr = "0" & xstr
    463. BinarySTRToText = BinarySTRToText & xstr
    464. Next
    465. End Function



    nach VBA verschoben, Spoiler eingefügt
    -Artentus

    Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Artentus“ ()

    In deinem Code stehen doch drei Varianten bereits drin.

    '--- A --- you specifiy the name of the mailbox that contains the calendar you need

    'OR --- B --- You pick a CALENDAR (If you have several)

    'OR --- C --- You simply use the default calendar
    Nimm doch einfach Block A anstatt B.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Hallo, danke schonmal. Aber Block A beschreibt ja eigtl. gar nicht mein Problem oder? Block A würde mir nur ermöglichen zwischen mehreren Accounts auszuwählen, das möchte ich ja gar nicht. Was ich möchte ist, einfach von meinem dort eingebundenen Account, einen Freigegebenen Kalender auszuwählen.

    Ihr müsst euch das so vorstellen, dass beim Ausführen des Skriptes sich eine Maske öffnet, wo ich dann auswählen kann, welchen Kalender ich importiere(hierbei beschränkt sich die Auswahl nur auf "Meine Kalender" und mir bleibt keine andere Möglichkeit dann aus den "Freigegebenen Kalendern" zu wählen,
    Ich hoffe, ihr versteht was ich meine :S

    Dazu kommt, dass ich Block A gar nicht ausprobieren kann, da immer dieser Fehler kommt...






    edit:
    hier noch ein link wo meine antwort eigtl. schon steht bzw. die syntax erklärt wird. allerdings schaffe ich es nicht, den code für meinen bedarf anzupassen...

    1. outlookcode.com/codedetail.aspx?id=43

    2. msdn.microsoft.com/en-us/libra…a220116(v=office.11).aspx

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Kleiner_VBAler“ ()

    petaod schrieb:

    Ideen hätte ich genügend, aber momentan keine Zeit, um dir das vorzukauen.
    Falls ich abends mal Luft habe, kann ich mich dahinterklemmen.

    Aber vielleicht musst du mich nochmals daran erinnern.


    oh, das wäre klasse.. du würdest mir wirklich sehr, sehr helfen! wie gesagt, meine fähigkeiten reichen noch nicht aus, um den quellcode so anzupassen wie es bei ms dort beschrieben ist... ich erinnere dich nochmal :)

    vielen dank schon mal!
    Hier noch einmal Links, die ggf. genau meine Problem schildern und auch eine Lösungsmöglichkeit schildern, die ich aber mit meinen technischen Voraussetzungen leider nicht lösen kann...

    Zum einen der hier:
    outlookcode.com/d/code/getfolder.htm

    und dann auch noch der hier:
    outlookbanter.com/outlook-vba/…etting-public-folder.html

    :S

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Kleiner_VBAler“ ()

    Visual Basic-Quellcode

    1. ​Sub Test()
    2. Set MyCalender = SharedCalender("vorname.nachname@domain.com") 'public mail address
    3. 'Bessere Alternative:
    4. Set MyCalender = SharedCalender("Username in Outlook") 'internal mail address (Exchange)
    5. If MyCalender Is Nothing Then MsgBox("Benutzer nicht gefunden")
    6. End Sub
    7. Function SharedCalender(ByVal MailAddress As String) As Object
    8. Dim NS As Outlook.NameSpace
    9. Dim Owner As Outlook.Recipient
    10. On Error Goto Done
    11. Set MAPI = Application.GetNamespace("MAPI")
    12. Set Owner = MAPI.CreateRecipient(MailAddress)
    13. Owner.Resolve
    14. If Owner.Resolved Then Set SharedCalender = MAPI.GetSharedDefaultFolder(Owner, olFolderCalendar)
    15. Done:
    16. End Function
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Vielen, vielen, vielen lieben Dank dafür, dass du die Arbeit gemacht hast, petaod!! Wirklich sehr stark!
    Hab' den Code jetzt kopiert und bei mir eingefügt ohne "Option A, B, C". Bekomme einen Kompilierungsfehler beim Ausführen, dass er in dieser Zeile hier "Function SharedCalender(ByVal MailAddress As String) As Object", dass er eine ')' erwartet...

    Habe ich das jetzt falsch reinkopiert bzw. was muss ich in meinem ursprünglichen Code anpassen? Entschuldige für eine weitere Frage...

    EDIT:

    Das erste Problem habe ich gefixt, allerdings habe ich jetzt in Zeile 113 einen Fehler. In dieser Zeile hier: " If StartMonth = "" Then Exit Sub" Da sagt er mir, dass es eine 'ungültige Exitanweisung" ist...

    Ui ui ui... Warum hat er denn jetzt da Probleme?!

    Dieser Beitrag wurde bereits 1 mal editiert, zuletzt von „Kleiner_VBAler“ ()

    Also den Code steht aktuell in einer Datei, die das Suffix ".vbs" trägt. Sie sollte auch so gestartet werden. Schöner wäre es natuerlich, wenn ich das ganze dann via Entwicklertool direkt in Outlook als Button einbinden würde.
    Aber das ist ja z.Z. nur eine Nebenrolle.

    Hier der aktuelle Code:

    Spoiler anzeigen

    Quellcode

    1. DisplayYearlyCalendar()
    2. Sub DisplayYearlyCalendar()
    3. 'copyright Nick Roemer
    4. 'http://niveauverleih.blogspot.com/
    5. 'version 2.1, 22 Jan 2009
    6. 'this script (formerly: macro) will display the Outlook appointments over a period of several months
    7. 'or an empty calendar to print out
    8. 'the output is are 2 html files (1 portrait, 1 landscape) that are displayed with Internet Explorer
    9. 'Safe this file as "Yearly calendar v2.vbs" and doubleclick the resulting file to run the script
    10. '-----------------------------------------------------------------------------------------------
    11. 'some necessary objects and constants
    12. Const ForWriting = 2
    13. Set objShell = CreateObject("WScript.Shell")
    14. strTempFolder = objShell.ExpandEnvironmentStrings("%TEMP%") & "\YearCalendar"
    15. Set objFSO = CreateObject("Scripting.FileSystemObject")
    16. If NOT objFSO.FolderExists(strTempFolder) Then
    17. objFSO.CreateFolder strTempFolder
    18. End If
    19. Set OL = createObject("Outlook.Application")
    20. Set onNamespace = OL.GetNamespace("MAPI")
    21. 'SELECT THE MAILBOX / CALENDAR TO BE DISPLAYED
    22. 'Choose between options A, B and C
    23. 'uncomment the chosen code paragraph
    24. '--- A --- you specifiy the name of the mailbox that contains the calendar you need
    25. 'strMailbox = "MBX -- ServiceDesk"
    26. 'results = split (GetExchangeServer(strMailbox),"|")
    27. 'strServer = ""
    28. 'on error resume next
    29. 'strServer = results(1)
    30. 'strFolderName = results(0)
    31. 'on error goto 0
    32. 'Set MyCalendar = onNamespace.Folders(strFolderName).Folders("Calendar") 'if you want to indicate a calendar in a different mailbox
    33. 'OR --- B --- You pick a CALENDAR (If you have several)
    34. 'Set MyCalendar = onNamespace.PickFolder 'if you want to select your calendar folder manually (if you have several)
    35. 'strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
    36. 'results = split (GetExchangeServer(strMailbox),"|")
    37. 'strServer = ""
    38. 'on error resume next
    39. 'strServer = results(1)
    40. 'on error goto 0
    41. 'OR --- C --- You simply use the default calendar
    42. 'Set MyCalendar = onNamespace.GetDefaultFolder(9) ' if you want to use the default calendar
    43. 'strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
    44. 'results = split (GetExchangeServer(strMailbox),"|")
    45. 'strServer = ""
    46. 'on error resume next
    47. 'strServer = results(1)
    48. 'on error goto 0
    49. 'End Sub
    50. Set MyCalender = SharedCalender("alex@testmail.de") 'internal mail address (Exchange)
    51. If MyCalender Is Nothing Then MsgBox("Benutzer nicht gefunden")
    52. Function SharedCalender(ByVal MailAddress As String) As Object
    53. Dim NS As Outlook.NameSpace
    54. Dim Owner As Outlook.Recipient
    55. On Error Goto Done
    56. Set MAPI = Application.GetNamespace("MAPI")
    57. Set Owner = MAPI.CreateRecipient(MailAddress)
    58. Owner.Resolve
    59. If Owner.Resolved Then Set SharedCalender = MAPI.GetSharedDefaultFolder(Owner, olFolderCalendar)
    60. Done:
    61. End Function
    62. 'FILTER CATEGORIES
    63. 'list here the categories that you want to hide
    64. arrExcludeCategories = Array()
    65. 'arrExcludeCategories = Array("Personal", "StaffMeetings")
    66. 'HIDE PRIVATE APPOINTMENTS
    67. 'Set this to TRUE if you want to display private appointments
    68. Const blShowPrivateAppointments = TRUE
    69. 'ALIGN BY WEEKDAY / DAY-OF-MONTH
    70. 'Set this to FALSE if you want the rows to be the day of month (1,2, ...31) iso. the days of the week (Mo .. Fri)
    71. Const blAlignWeekDays = True
    72. 'ONLY ALL-DAY-EVENTS
    73. 'Set this to TRUE if you want to display AllDayEvents only
    74. blAllDayEventsOnly = False
    75. 'COLORS used
    76. 'colors from http://web.njit.edu/~kevin/rgb.txt.html
    77. Const wheat_light = "#EED8AE"
    78. Const wheat_dark = "#CDBA96"
    79. Const seashell = "#EEE5DE"
    80. Const silver = "#C0C0C0"
    81. Const cornsilk = "#FFF8DC"
    82. 'NAME AND LOCATION OF HTML OUTPUT FILES
    83. strHtmlFile = strTempFolder & "\YearlyCalendar.html"
    84. strHtmlFileTransposed = strTempFolder & "\YearlyCalendarTransposed.html"
    85. strHtmlFile7Columns = strTempFolder & "\YearlyCalendar7Columns.html"
    86. 'SCRIPT BEGIN
    87. 'ASKING FOR TIMESPAN TO BE DISPLAYED
    88. 'ENTER 13 for next January etc.
    89. StartMonth = InputBox("Start Month", "Start Month", Month(Date))
    90. If StartMonth = "" Then Exit Sub
    91. StartMonth = CInt(StartMonth)
    92. EndMonth = InputBox("End Month", "End Month", StartMonth - 1)
    93. If EndMonth = "" Then Exit Sub
    94. EndMonth = CInt(EndMonth)
    95. If EndMonth < StartMonth Then
    96. NbMonths = EndMonth - StartMonth + 13
    97. EndMonth = EndMonth + 12
    98. Else
    99. NbMonths = EndMonth - StartMonth + 1
    100. End If
    101. 'DISPLAY EMPTY CALENDAR?
    102. strEmptyCalendar = vbNo
    103. 'strEmptyCalendar = MsgBox("Empty Calendar?", vbYesNo + vbDefaultButton2)
    104. dim arrTable(100,100) 'array used to created the transposed version of the calendar
    105. 'Create Table: 1 Header Row
    106. ' 7 days x 5 weeks = 35 day rows
    107. ' 1 Header column
    108. ' 1 column for each month
    109. strHeader = "<head><title>Yearly Calendar</title></head>"
    110. 'NOTE: We are trying to use the available space efficiently to put all appointments on one sheet of paper
    111. 'You should play around with the "font-size:50%" bit, depending on how packed your calendar is
    112. strTableHeader = Contents & vbCrLf & "<table width=100% border=1 style='font-family:verdana;font-size:50%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    113. 'header row
    114. Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & seashell & "'>"
    115. Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
    116. arrTable(0,0) = "<TD name='tableHeader' style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
    117. 'First Row/col
    118. intYear = Year(Date)
    119. nextYear = intYear + 1
    120. k = 0
    121. LastRowOfTable = 0
    122. For i = StartMonth To EndMonth
    123. k = k+1
    124. MonthInNumbers = i
    125. If i > 12 Then
    126. MonthInNumbers = i - 12
    127. intYear = nextYear
    128. End If
    129. 'Determine the last Row of the Table
    130. StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
    131. StrMonthEndsOnA = day(dateserial(intYear,i+1,0))
    132. LastRowOfMonth = StrMonthStartsOnA + StrMonthEndsOnA - 1
    133. If LastRowOfMonth > LastRowOfTable Then LastRowOfTable = LastRowOfMonth
    134. Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:" & Int(100 / NbMonths) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
    135. arrTable(0,k) = "<TD name='tableHeader' style='border-color:gray;width:" & Int(100 / LastRowOfTable) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
    136. Next
    137. Contents = Contents & vbCrLf & "</TR>"
    138. If strEmptyCalendar = vbNo Then
    139. Set MyFolder = MyCalendar.Items
    140. storeID = MyCalendar.storeID
    141. MyFolder.IncludeRecurrences = True
    142. MyFolder.Sort "[Start]"
    143. 'create CDO session in order to get appointment label colors
    144. strProfileInfo = strServer & vbLf & strMailbox
    145. End If
    146. 'Day Rows
    147. RowCount = 0
    148. For week = 1 To 6 'The macro was originally written for the case blAlignWeekDays = True
    149. For intWeekday = 1 To 7 'Therefore I used a double loop: weeks then weekdays
    150. ColCount = 0
    151. RowCount = RowCount + 1
    152. 'First column
    153. Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & bgcolor & "'>"
    154. If blAlignWeekDays Then
    155. Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'>" & WeekdayName(intWeekday, False, vbMonday) & "</TD>"
    156. arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'>" & left(WeekdayName(intWeekday, False, vbMonday),2) & "</TD>"
    157. Else
    158. Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
    159. arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
    160. End If
    161. ColCount = ColCount + 1
    162. intYear = Year(Date)
    163. 'Month columns
    164. For i = StartMonth To EndMonth
    165. MonthInNumbers = i
    166. If i > 12 Then
    167. MonthInNumbers = i - 12
    168. intYear = nextYear
    169. End If
    170. StrMonthStartsOnA = 1
    171. If blAlignWeekDays Then 'e.g. if the first of the month falls on a Friday
    172. ' we need to put some grey cells before the month begins
    173. StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
    174. End If
    175. 'Ne
    176. If i=StartMonth Then StrFirstMonthStartsOnA = StrMonthStartsOnA
    177. intDayOfMonth = 0
    178. If RowCount >= StrMonthStartsOnA Then
    179. intDayOfMonth = RowCount - StrMonthStartsOnA + 1
    180. End If
    181. 'calculate date for current cell
    182. strDate = ""
    183. If intDayOfMonth > 0 Then
    184. On Error Resume Next
    185. strDate = CDate(CStr(intDayOfMonth) & " " & MonthName(MonthInNumbers) & ", " & CStr(intYear))
    186. On Error GoTo 0
    187. End If
    188. 'color weekends
    189. intRealWeekday = intWeekday
    190. If Not blAlignWeekDays Then
    191. On Error Resume Next
    192. intRealWeekday = Weekday(strDate)
    193. On Error GoTo 0
    194. End If
    195. bgcolor = "#FFFFFF"
    196. If (i Mod 2 = 0) Then bgcolor = cornsilk
    197. Select Case intRealWeekday
    198. Case 6
    199. bgcolor = wheat_light
    200. Case 7
    201. bgcolor = wheat_dark
    202. End Select
    203. 'grey out empty cells
    204. dispDate = ""
    205. dispDateTransposed = ""
    206. If strDate = "" Then
    207. bgcolor = silver
    208. ElseIf blAlignWeekDays Then
    209. strShortMonth = MonthName(MonthInNumbers, True)
    210. strShortMonthTransposed = strShortMonth
    211. If Weekday(strDate) = 1 Or Weekday(strDate) = 7 Then strShortMonthTransposed = ""
    212. dispDate = "<b>" & Day(strDate) & " " & strShortMonth & "</b>"
    213. dispDateTransposed = "<b>" & Day(strDate) & " " & strShortMonthTransposed & "</b>"
    214. Else 'if blAlignWeekDays = False
    215. dispDate = "<b>" & Day(strDate) & " " & WeekdayName(intRealWeekday, True, vbSunday) & "</b>"
    216. dispDateTransposed = dispDate
    217. End If
    218. 'display date
    219. Contents = Contents & vbCrLf & "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDate & " "
    220. arrTable(RowCount,ColCount) = "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDateTransposed & " "
    221. 'display appointments
    222. If strEmptyCalendar = vbNo Then
    223. strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
    224. strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
    225. strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
    226. strRestriction = strRestriction & " AND [Duration] > 0"
    227. If strDate = "" Then strRestriction = "[Start] = 1" 'no result
    228. Set myRestrictItems = MyFolder.Restrict(strRestriction)
    229. myRestrictItems.Sort "[Start]"
    230. 'Contents = Contents & vbCrLf & myRestrictItems.Count & "<br>"
    231. For Each myitem In myRestrictItems
    232. blDisplay = True
    233. 'check if this appointment is in a category that we want to hide
    234. For Each strCat2Exclude In arrExcludeCategories
    235. If InStr(myitem.Categories, strCat2Exclude) Then blDisplay = False
    236. Next
    237. 'check if this is a private appointment
    238. If blShowPrivateAppointments = False And myitem.Sensitivity = 2 Then blDisplay = False
    239. blIsAllDayEvent = myitem.AllDayEvent
    240. If blAllDayEventsOnly And Not blIsAllDayEvent Then blDisplay = False
    241. 'Display the appointment
    242. If blDisplay Then
    243. strTime = ""
    244. If Not blIsAllDayEvent Then
    245. strTime = "<br>" & Hour(myitem.Start) & ":" & Left(Minute(myitem.Start) & "0",2)
    246. strTime = strTime & "-" & Hour(myitem.End) & ":" & Left(Minute(myitem.End) & "0",2) & " "
    247. End If
    248. 'getting color
    249. 'MsgBox myitem & vbcr & vbcr & storeID & vbcr & vbcr & objCDO
    250. strColor = GetColor(myitem, storeID, onNameSpace)
    251. Contents = Contents & strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
    252. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount)& strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
    253. End If
    254. Next 'myitme In myRestrictItems
    255. Else 'i.e; If strEmptyCalendar = vbYes
    256. Contents = Contents & "<br><br>"
    257. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & "<br><br>"
    258. End If 'If strEmptyCalendar = vbNo
    259. Contents = Contents & vbCrLf & "</TD>"
    260. arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & vbCrLf & "</TD>"
    261. ColCount = ColCount + 1
    262. Next 'For i = StartMonth To EndMonth
    263. Contents = Contents & vbCrLf & "</TR>"
    264. If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For 'latest possible day in last week is Tuesday (31 days from Sunday)
    265. If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
    266. Next 'For intWeekday = 1 To 7
    267. If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
    268. If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For
    269. Next 'For week = 1 To 6
    270. 'create transposed contents
    271. tcontents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    272. for i=0 to NbMonths
    273. tcontents = tcontents & "<TR valign='top' bgcolor='" & seashell & "'>"
    274. for j=0 to LastRowOfTable
    275. tcontents = tcontents & arrTable(j,i) & vbCR
    276. next
    277. tcontents = tcontents & "</TR>" & vbCR
    278. Next
    279. tcontents = tcontents & "</table>"
    280. 'create contents "7columns"
    281. c7contents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
    282. 'First Row - Weekdaynames
    283. c7contents = c7contents & vbCrLf & "<TR valign='top' bgcolor='gray'>"
    284. For intWeekday = 1 To 7
    285. c7contents = c7contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & WeekdayName(intWeekday, False, vbMonday) & "</b></TD>"
    286. Next
    287. c7contents = c7contents & vbCrLf & "</TR><TR>"
    288. ColCount = 0
    289. 'Add some gray cells
    290. For i=1 To StrFirstMonthStartsOnA-1
    291. c7contents = c7contents & "<TD name='tableHeader' style='border-color:gray'></TD>"
    292. ColCount = ColCount + 1
    293. Next
    294. for i=0 to NbMonths
    295. For j=0 to LastRowOfTable
    296. 'filter out some unneeded cells with the if condition
    297. If InStr(arrTable(j,i),"tableHeader")=0 And InStr(arrTable(j,i),"bgcolor = '" & silver)=0 Then
    298. c7contents = c7contents & arrTable(j,i) & vbCR
    299. ColCount = ColCount +1
    300. End If
    301. If ColCount = 7 Then
    302. ColCount = 0
    303. c7contents = c7contents & "</TR>" & vbCR
    304. c7contents = c7contents & "<TR valign='top' bgcolor='" & seashell & "'>"
    305. End If
    306. next
    307. Next
    308. c7contents = c7contents & "</TR></table>"
    309. 'create the html files
    310. Set filesys = CreateObject("Scripting.FileSystemObject")
    311. Set F = filesys.OpenTextFile(strHtmlFile, ForWriting, True)
    312. F.Write strHeader & strTableHeader & Contents
    313. Set F = Nothing
    314. Set F = filesys.OpenTextFile(strHtmlFileTransposed, ForWriting, True)
    315. F.Write tcontents
    316. Set F = Nothing
    317. Set F = filesys.OpenTextFile(strHtmlFile7Columns, ForWriting, True)
    318. F.Write c7contents
    319. Set F = Nothing
    320. Set filesys = Nothing
    321. 'display the html files
    322. strCommand = "iexplore """ & strHtmlFile & """"
    323. objShell.run (strCommand)
    324. strCommand = "iexplore """ & strHtmlFileTransposed & """"
    325. objShell.run (strCommand)
    326. strCommand = "iexplore """ & strHtmlFile7Columns & """"
    327. objShell.run (strCommand)
    328. 'display containing folder
    329. strCommand = "explorer """ & strTempFolder & """"
    330. objShell.run (strCommand)
    331. Set objShell = Nothing
    332. Set objFSO = Nothing
    333. on error resume next
    334. objCDO.Logoff
    335. on error goto 0
    336. Set objCDO = Nothing
    337. Set MyFolder = Nothing
    338. Set MyCalendar = Nothing
    339. Set onNamespace = Nothing
    340. Set OL = Nothing
    341. End Sub
    342. '*************************************************************************************
    343. '***************** FUNCTIONS **************************************
    344. '*************************************************************************************
    345. Function GetColor(objAppt, storeID, onNamespace)
    346. Colors="FFFFFF E7A1A2 F7DD8F F9BA89 FCFA90 78D168 9FDCC9 C6D2B0 9DB7E8 B5A1E2 DAAEC2 DAD9DC 6B7994 BFBFBF 6F6F6F 4F4F4F C11A25 E2620D C79930 B9B300 368F2B 329B7A 778B45 2858A5 5C3FA3 93446B"
    347. GetColor = ""
    348. If objAppt.Class = 26 Then ' = appointment
    349. Cat = objAppt.categories
    350. If Cat<>"" Then
    351. 'just the first cat
    352. If InStr(Cat, ",") Then Cat=Left(Cat,InStr(Cat, ",")-1)
    353. ColorCode = onNamespace.categories.item(Cat).Color
    354. GetColor = Mid(Colors,ColorCode*7+1,6)
    355. End if
    356. End If
    357. End Function
    358. Public Function GetExchangeServer(strMailbox)
    359. 'Root to where registry stores the outlook settings
    360. MainKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
    361. 'get the default outlook profile option stored in the registry and add it to the key path
    362. Const HKEY_LOCAL_MACHINE = &H80000002
    363. Const HKEY_USERS = &H80000003
    364. strComputer ="."
    365. GetRegKeyStrValue strComputer, HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName", username
    366. Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" & strComputer & "/root/default:StdRegProv")
    367. oReg.EnumKey HKEY_USERS,"", arrSubKeys
    368. 'msgbox MainKeyPath
    369. arrBinary = Array(1, 0)
    370. For i = 0 To UBound(arrBinary)
    371. KeyValue = KeyValue & Chr(arrBinary(i))
    372. Next
    373. For Each subkey In arrSubKeys
    374. sKey = subkey & "\Software\Microsoft\Windows\CurrentVersion\Explorer"
    375. REGusername = ""
    376. GetRegKeyStrValue strComputer, HKEY_USERS, sKey, "Logon User Name", REGusername
    377. If ucase(REGusername)=ucase(username) Then
    378. MainKeyPath = subkey & "\" & MainKeyPath
    379. GetRegKeyStrValue strComputer, HKEY_USERS, MainKeyPath, "DefaultProfile", DefaultProfile
    380. MainKeyPath = MainKeyPath & DefaultProfile
    381. GetRegKeyBinValue strComputer, HKEY_USERS, MainKeyPath & "\9207f3e0a3b11019908b08002b2a56c2", "01023d00", arrBinary
    382. 'msgbox MainKeyPath
    383. 'msgbox MainKeyPath
    384. arrBinary = Array(1, 0)
    385. For i = 0 To UBound(arrBinary)
    386. KeyValue = KeyValue & Chr(arrBinary(i))
    387. Next
    388. For i = 0 To UBound(arrBinary)
    389. KeyValue = KeyValue & Chr(arrBinary(i))
    390. Next
    391. 'msgbox Keyvalue
    392. NumFolders = Len(KeyValue) / 16
    393. For x = 1 To NumFolders
    394. 'Get next key name from list
    395. KeyName = Mid(KeyValue, ((x - 1) * 16) + 1, 16)
    396. KeyName = BinarySTRToText(Trim(KeyName))
    397. PSTKeyName = MainKeyPath & "\" & KeyName
    398. StoreType = ""
    399. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3d09", arrBinary) <> "Failed" Then
    400. For i = 0 To UBound(arrBinary)-2 Step 2
    401. StoreType = StoreType & Chr(arrBinary(i))
    402. Next
    403. End If
    404. IF StoreType = "MSPST MS" or StoreType = "MSUPST MS" Then
    405. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
    406. For i = 0 To UBound(arrBinary)-2 Step 2
    407. strMailboxFound = strMailboxFound & Chr(arrBinary(i))
    408. Next
    409. End If
    410. Else
    411. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
    412. For i = 0 To UBound(arrBinary)-2 Step 2
    413. PstKeyValue = PstKeyValue & Chr(arrBinary(i))
    414. Next
    415. strMailboxfound = PstKeyValue
    416. PstKeyValue = ""
    417. End If
    418. End If
    419. If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f662b", arrBinary) <> "Failed" Then
    420. For i = 0 To UBound(arrBinary)-2 Step 2
    421. PstKeyValue = PstKeyValue & Chr(arrBinary(i))
    422. Next
    423. strServer = PstKeyValue
    424. If instr(strMailboxFound, strMailbox) Then
    425. 'MsgBox strMailboxFound & " " & strMailbox
    426. GetExchangeServer = strMailboxFound & "|" & strServer
    427. End If
    428. PstKeyValue = ""
    429. End If
    430. Next
    431. End If
    432. Next
    433. End Function
    434. Function GetRegKeyBinValue(sComputer, hTree, sKey, sValueName, sValue)
    435. Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
    436. lResult = oRegistry.GetBinaryValue(hTree, sKey, sValueName, sValue)
    437. If (lResult = 0) And (Err.Number = 0) Then
    438. GetRegKeyBinValue = "Succeeded"
    439. Else
    440. GetRegKeyBinValue = "Failed"
    441. sValue = ""
    442. End If
    443. Set oRegistry = Nothing
    444. End Function
    445. Function GetRegKeyStrValue(sComputer, hTree, sKey, sValueName, sValue)
    446. Dim oRegistry
    447. Dim lResult
    448. Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
    449. lResult = oRegistry.GetStringValue(hTree, sKey, sValueName, sValue)
    450. If (lResult = 0) And (Err.Number = 0) Then
    451. GetRegKeyStrValue = sValue
    452. Else
    453. GetRegKeyStrValue = "Failed"
    454. sValue = ""
    455. End If
    456. Set oRegistry = Nothing
    457. End Function
    458. Private Function BinarySTRToText(BinaryStr)
    459. For i = 1 To Len(BinaryStr)
    460. xstr = Mid(BinaryStr, i, 1)
    461. xlong = CLng(Asc(xstr))
    462. xvar = Hex(xlong)
    463. xstr = CStr(xvar)
    464. If Len(xstr) = 1 Then xstr = "0" & xstr
    465. BinarySTRToText = BinarySTRToText & xstr
    466. Next
    467. End Function


    Uff.
    Das so wenige Grundlagen da sind, dass du nicht mal einen Funktionsaufruf interpretieren kannst, hätte ich nicht erwartet.

    Dann machen wir's in Stufe 1 halt ohne Funktionsaufruf.
    Binde anstatt dem eingefügten Code nur diesen Block ein:

    Visual Basic-Quellcode

    1. Set Owner = onNamespace.CreateRecipient("alex@testmail.de")
    2. Owner.Resolve
    3. If Owner.Resolved Then Set MyCalender = onNamespace.GetSharedDefaultFolder(Owner, 9)
    Ich frage mich dann nur, wie du es später anstellst, verschiedene Benutzer zu verwenden.
    Möglich wäre, den Namen an VBS per Parameter zu übergeben, aber da wird dann vermutlich nochmals ein Grundlagenkurs notwendig sein. ;)

    Den Code direkt in Outlook auszuführen, wäre logischer und einfacher, als den Umweg über VBS zu nehmen.
    Aber bei deinem Basiswissen scheint mir selbst das eine Herausforderung zu sein.
    Bring mal Stufe1 zum Laufen, damit du schon mal ein Erfolgserlebnis hast.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    Ja.. die Skills lassen wirklich zu wünschen übrig, aber ich habe mit vba leider nie etwas zu tun gehabt und dann gleich so ein dicker fisch... Ich denke aber, dass ich es aufgeben muss, da ich zum einen nicht über die Fähigkeiten verfüge und zum anderen es eigtl. nicht meine Art ist, dass euch hier ständig auf die Nerven gehe...

    Den Quellcode, den du mir im letzten Post eingefügt hat, erzeugt einen Fehler beim Ausführen bei mir nachdem ich ausgewählt habe in was für einem Zeitraum der Kalender abgebildet werden soll. Wenn ich das richtig verstanden habe, sollte ich deinen vorletzten Code rauspacken und den neuen einfügen. Das habe ich auch soweit getan, aber dann kommt diese Fehlermeldung:

    In dieser Zeile hier: "Set MyFolder = MyCalendar.Items" -> "Objekt erforderlich: 'MyCalendar'", "Code: 800A01A8"


    Vielen Dank auf jeden Fall für deine großen Bemühungen mit so einem Grünschnabel wie mir...
    Nimm mal den Code aus Post #8, füge ihn in Outlook ein und führe ihn aus.
    Wenn er die MessageBox anzeigt, hat er den Kalender des Benutzers nicht gefunden.
    Falls der Exchange-Server auch interne Adressen vergibt, die von der öffentlichen abweichen, verwende diese.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --
    ah okay, scheinbar findet er meinen User, denn wenn ich meine E-Mail eingebe, die im Exchange hinterlegt ist, kommt keine MessageBox von wegen "Benutzer nicht gefunden".

    D.h., dass das auf jeden Fall schon mal funktioniert, also der Code aus Post#8.
    Sorry für den Doppelpost, aber der Code lässt sich in Kombination mit dem restlichen Code nicht ausführen :/
    Bin ich wieder blind auf beiden Augen?! Um es noch einmal zu erwähnen. Ich probiere es gerade direkt in der Outlook VBA Umgebung aus...

    Kleiner_VBAler schrieb:

    direkt in der Outlook VBA Umgebung
    solltest du z.B. die Zeile Set OL = createObject("Outlook.Application") vermeiden, damit du nicht versuchst, mehrere Instanzen zu öffnen.
    Statt dessen solltest du OL der aktiven Instanz zuweisen Set OL = Application.

    In Outlook-VBA hast du ja eine IDE, mit der du auch debuggen kannst.
    Geh zunächst mit F8 durch den Code durch, dann merkst du wenn's kracht und kannst die Zeile veröffentlichen.

    Vielleicht muss ich auch noch erwähnen, dass du die erste Zeile in eine Sub einpacken müsstest, aber in deinem Fall auch wegwerfen kannst und gleich bei Sub DisplayYearlyCalendar() mit Debuggen anfangen kannst.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --

    petaod schrieb:

    Kleiner_VBAler schrieb:

    direkt in der Outlook VBA Umgebung
    solltest du z.B. die Zeile Set OL = createObject("Outlook.Application") vermeiden, damit du nicht versuchst, mehrere Instanzen zu öffnen.
    Statt dessen solltest du OL der aktiven Instanz zuweisen Set OL = Application.

    In Outlook-VBA hast du ja eine IDE, mit der du auch debuggen kannst.
    Geh zunächst mit F8 durch den Code durch, dann merkst du wenn's kracht und kannst die Zeile veröffentlichen.

    Vielleicht muss ich auch noch erwähnen, dass du die erste Zeile in eine Sub einpacken müsstest, aber in deinem Fall auch wegwerfen kannst und gleich bei Sub DisplayYearlyCalendar() mit Debuggen anfangen kannst.


    hab das "Set OL = Application" angepasst. allerdings bekomme ich leider nicht einmal die Möglichkeit Zeile für Zeile die Fehler zu posten, da er mir sagt, dass ich nach nach einem "End Sub, End Function end Property nur Kommentare stehen können"...
    Ich weiß einfach nicht weiter. Habe meinen geposteten Quellcode genau so belassen gehabt. Hab' ihn in Outlook VBA kopiert, deinen Quellcode reinkopiert, angepasst mit der/den neue/neuen Zeilen und habe die Auswahlmöglichkeit "B" im Code ausgeklammert, doch das alles hat bislang zu keinem Erfolg geführt.. :(

    Kleiner_VBAler schrieb:

    da er mir sagt, dass ich nach nach einem "End Sub, End Function end Property nur Kommentare stehen können"

    Dann bleibt dir nur zu suchen, wo du bei ungleiche Paare von Sub .. End Sub oder Function .. End Function codiert hast.
    oder zwischen zwei Subs oder Functions noch ein Stück Code existiert.

    Suche alle ​End Sub und ​End Function und schaue, ob danach etwas steht, was keine neue Sub oder Function definiert.
    --
    If Not Program.isWorking Then Code.Debug Else Code.DoNotTouch
    --