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
nach VBA verschoben, Spoiler eingefügt
-Artentus
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
Quellcode
- DisplayYearlyCalendar()
- Sub DisplayYearlyCalendar()
- 'copyright Nick Roemer
- 'http://niveauverleih.blogspot.com/
- 'version 2.1, 22 Jan 2009
- 'this script (formerly: macro) will display the Outlook appointments over a period of several months
- 'or an empty calendar to print out
- 'the output is are 2 html files (1 portrait, 1 landscape) that are displayed with Internet Explorer
- 'Safe this file as "Yearly calendar v2.vbs" and doubleclick the resulting file to run the script
- '-----------------------------------------------------------------------------------------------
- 'some necessary objects and constants
- Const ForWriting = 2
- Set objShell = CreateObject("WScript.Shell")
- strTempFolder = objShell.ExpandEnvironmentStrings("%TEMP%") & "\YearCalendar"
- Set objFSO = CreateObject("Scripting.FileSystemObject")
- If NOT objFSO.FolderExists(strTempFolder) Then
- objFSO.CreateFolder strTempFolder
- End If
- Set OL = createObject("Outlook.Application")
- Set onNamespace = OL.GetNamespace("MAPI")
- 'SELECT THE MAILBOX / CALENDAR TO BE DISPLAYED
- 'Choose between options A, B and C
- 'uncomment the chosen code paragraph
- '--- A --- you specifiy the name of the mailbox that contains the calendar you need
- 'strMailbox = "MBX -- ServiceDesk"
- 'results = split (GetExchangeServer(strMailbox),"|")
- 'strServer = ""
- 'on error resume next
- 'strServer = results(1)
- 'strFolderName = results(0)
- 'on error goto 0
- 'Set MyCalendar = onNamespace.Folders(strFolderName).Folders("Calendar") 'if you want to indicate a calendar in a different mailbox
- 'OR --- B --- You pick a CALENDAR (If you have several)
- Set MyCalendar = onNamespace.PickFolder 'if you want to select your calendar folder manually (if you have several)
- strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
- results = split (GetExchangeServer(strMailbox),"|")
- strServer = ""
- on error resume next
- strServer = results(1)
- on error goto 0
- 'OR --- C --- You simply use the default calendar
- 'Set MyCalendar = onNamespace.GetDefaultFolder(9) ' if you want to use the default calendar
- 'strMailbox = replace(MyCalendar.Parent.Name,"Mailbox - ","")
- 'results = split (GetExchangeServer(strMailbox),"|")
- 'strServer = ""
- 'on error resume next
- 'strServer = results(1)
- 'on error goto 0
- 'FILTER CATEGORIES
- 'list here the categories that you want to hide
- arrExcludeCategories = Array()
- 'arrExcludeCategories = Array("Personal", "StaffMeetings")
- 'HIDE PRIVATE APPOINTMENTS
- 'Set this to TRUE if you want to display private appointments
- Const blShowPrivateAppointments = TRUE
- 'ALIGN BY WEEKDAY / DAY-OF-MONTH
- '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)
- Const blAlignWeekDays = True
- 'ONLY ALL-DAY-EVENTS
- 'Set this to TRUE if you want to display AllDayEvents only
- blAllDayEventsOnly = False
- 'COLORS used
- 'colors from http://web.njit.edu/~kevin/rgb.txt.html
- Const wheat_light = "#EED8AE"
- Const wheat_dark = "#CDBA96"
- Const seashell = "#EEE5DE"
- Const silver = "#C0C0C0"
- Const cornsilk = "#FFF8DC"
- 'NAME AND LOCATION OF HTML OUTPUT FILES
- strHtmlFile = strTempFolder & "\YearlyCalendar.html"
- strHtmlFileTransposed = strTempFolder & "\YearlyCalendarTransposed.html"
- strHtmlFile7Columns = strTempFolder & "\YearlyCalendar7Columns.html"
- 'SCRIPT BEGIN
- 'ASKING FOR TIMESPAN TO BE DISPLAYED
- 'ENTER 13 for next January etc.
- StartMonth = InputBox("Start Month", "Start Month", Month(Date))
- If StartMonth = "" Then Exit Sub
- StartMonth = CInt(StartMonth)
- EndMonth = InputBox("End Month", "End Month", StartMonth - 1)
- If EndMonth = "" Then Exit Sub
- EndMonth = CInt(EndMonth)
- If EndMonth < StartMonth Then
- NbMonths = EndMonth - StartMonth + 13
- EndMonth = EndMonth + 12
- Else
- NbMonths = EndMonth - StartMonth + 1
- End If
- 'DISPLAY EMPTY CALENDAR?
- strEmptyCalendar = vbNo
- 'strEmptyCalendar = MsgBox("Empty Calendar?", vbYesNo + vbDefaultButton2)
- dim arrTable(100,100) 'array used to created the transposed version of the calendar
- 'Create Table: 1 Header Row
- ' 7 days x 5 weeks = 35 day rows
- ' 1 Header column
- ' 1 column for each month
- strHeader = "<head><title>Yearly Calendar</title></head>"
- 'NOTE: We are trying to use the available space efficiently to put all appointments on one sheet of paper
- 'You should play around with the "font-size:50%" bit, depending on how packed your calendar is
- 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'>"
- 'header row
- Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & seashell & "'>"
- Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
- arrTable(0,0) = "<TD name='tableHeader' style='border-color:gray;width:70'><b>" & "Month" & "</b></TD>"
- 'First Row/col
- intYear = Year(Date)
- nextYear = intYear + 1
- k = 0
- LastRowOfTable = 0
- For i = StartMonth To EndMonth
- k = k+1
- MonthInNumbers = i
- If i > 12 Then
- MonthInNumbers = i - 12
- intYear = nextYear
- End If
- 'Determine the last Row of the Table
- StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
- StrMonthEndsOnA = day(dateserial(intYear,i+1,0))
- LastRowOfMonth = StrMonthStartsOnA + StrMonthEndsOnA - 1
- If LastRowOfMonth > LastRowOfTable Then LastRowOfTable = LastRowOfMonth
- Contents = Contents & vbCrLf & "<TD style='border-color:gray;width:" & Int(100 / NbMonths) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
- arrTable(0,k) = "<TD name='tableHeader' style='border-color:gray;width:" & Int(100 / LastRowOfTable) & "%'><b>" & MonthName(MonthInNumbers) & " " & intYear & "</b></TD>"
- Next
- Contents = Contents & vbCrLf & "</TR>"
- If strEmptyCalendar = vbNo Then
- Set MyFolder = MyCalendar.Items
- storeID = MyCalendar.storeID
- MyFolder.IncludeRecurrences = True
- MyFolder.Sort "[Start]"
- 'create CDO session in order to get appointment label colors
- strProfileInfo = strServer & vbLf & strMailbox
- 'You must add a Reference to Microsoft CDO version 1.21.
- On Error Resume next
- Set objCDO = CreateObject("MAPI.Session")
- 'IMPORTANT: log on using a new MAPI session with a dynamically created profile
- 'we can't simply reuse the existing MAPI session -> script will not retrieve colors for all appointments
- objCDO.Logon "", "", False, True, 0, False, strProfileInfo & "rtrtrtr"
- ErrNum = err.number
- On Error GoTo 0
- If ErrNum<>0 Then
- MsgBox "Could not create MAPI session to retrieve appointment colors. Will continue without colors."
- End If
- End If
- 'Day Rows
- RowCount = 0
- For week = 1 To 6 'The macro was originally written for the case blAlignWeekDays = True
- For intWeekday = 1 To 7 'Therefore I used a double loop: weeks then weekdays
- ColCount = 0
- RowCount = RowCount + 1
- 'First column
- Contents = Contents & vbCrLf & "<TR valign='top' bgcolor='" & bgcolor & "'>"
- If blAlignWeekDays Then
- Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'>" & WeekdayName(intWeekday, False, vbMonday) & "</TD>"
- arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'>" & left(WeekdayName(intWeekday, False, vbMonday),2) & "</TD>"
- Else
- Contents = Contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
- arrTable(RowCount,ColCount) = "<TD name='tableHeader' bgcolor='" & seashell & "' style='border-color:gray'><b>" & RowCount & "</b></TD>"
- End If
- ColCount = ColCount + 1
- intYear = Year(Date)
- 'Month columns
- For i = StartMonth To EndMonth
- MonthInNumbers = i
- If i > 12 Then
- MonthInNumbers = i - 12
- intYear = nextYear
- End If
- StrMonthStartsOnA = 1
- If blAlignWeekDays Then 'e.g. if the first of the month falls on a Friday
- ' we need to put some grey cells before the month begins
- StrMonthStartsOnA = Weekday(CDate("1 " & MonthName(MonthInNumbers) & ", " & intYear), vbMonday)
- End If
- 'Ne
- If i=StartMonth Then StrFirstMonthStartsOnA = StrMonthStartsOnA
- intDayOfMonth = 0
- If RowCount >= StrMonthStartsOnA Then
- intDayOfMonth = RowCount - StrMonthStartsOnA + 1
- End If
- 'calculate date for current cell
- strDate = ""
- If intDayOfMonth > 0 Then
- On Error Resume Next
- strDate = CDate(CStr(intDayOfMonth) & " " & MonthName(MonthInNumbers) & ", " & CStr(intYear))
- On Error GoTo 0
- End If
- 'color weekends
- intRealWeekday = intWeekday
- If Not blAlignWeekDays Then
- On Error Resume Next
- intRealWeekday = Weekday(strDate)
- On Error GoTo 0
- End If
- bgcolor = "#FFFFFF"
- If (i Mod 2 = 0) Then bgcolor = cornsilk
- Select Case intRealWeekday
- Case 6
- bgcolor = wheat_light
- Case 7
- bgcolor = wheat_dark
- End Select
- 'grey out empty cells
- dispDate = ""
- dispDateTransposed = ""
- If strDate = "" Then
- bgcolor = silver
- ElseIf blAlignWeekDays Then
- strShortMonth = MonthName(MonthInNumbers, True)
- strShortMonthTransposed = strShortMonth
- If Weekday(strDate) = 1 Or Weekday(strDate) = 7 Then strShortMonthTransposed = ""
- dispDate = "<b>" & Day(strDate) & " " & strShortMonth & "</b>"
- dispDateTransposed = "<b>" & Day(strDate) & " " & strShortMonthTransposed & "</b>"
- Else 'if blAlignWeekDays = False
- dispDate = "<b>" & Day(strDate) & " " & WeekdayName(intRealWeekday, True, vbSunday) & "</b>"
- dispDateTransposed = dispDate
- End If
- 'display date
- Contents = Contents & vbCrLf & "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDate & " "
- arrTable(RowCount,ColCount) = "<TD bgcolor = '" & bgcolor & "' style='border-color:gray'>" & dispDateTransposed & " "
- 'display appointments
- If strEmptyCalendar = vbNo Then
- strRestriction = "(([Start] >= '" & strDate & " 12:00 am' AND [Start] <= '" & strDate & " 11:59 pm')"
- strRestriction = strRestriction & " OR ([End] > '" & strDate & " 12:00 am' AND [End] <= '" & strDate & " 11:59 pm')"
- strRestriction = strRestriction & " OR ([Start] < '" & strDate & " 12:00 am' AND [End] > '" & strDate & " 11:59 pm'))"
- strRestriction = strRestriction & " AND [Duration] > 0"
- If strDate = "" Then strRestriction = "[Start] = 1" 'no result
- Set myRestrictItems = MyFolder.Restrict(strRestriction)
- myRestrictItems.Sort "[Start]"
- 'Contents = Contents & vbCrLf & myRestrictItems.Count & "<br>"
- For Each myitem In myRestrictItems
- blDisplay = True
- 'check if this appointment is in a category that we want to hide
- For Each strCat2Exclude In arrExcludeCategories
- If InStr(myitem.Categories, strCat2Exclude) Then blDisplay = False
- Next
- 'check if this is a private appointment
- If blShowPrivateAppointments = False And myitem.Sensitivity = 2 Then blDisplay = False
- blIsAllDayEvent = myitem.AllDayEvent
- If blAllDayEventsOnly And Not blIsAllDayEvent Then blDisplay = False
- 'Display the appointment
- If blDisplay Then
- strTime = ""
- If Not blIsAllDayEvent Then
- strTime = "<br>" & Hour(myitem.Start) & ":" & Left(Minute(myitem.Start) & "0",2)
- strTime = strTime & "-" & Hour(myitem.End) & ":" & Left(Minute(myitem.End) & "0",2) & " "
- End If
- 'getting color
- 'MsgBox myitem & vbcr & vbcr & storeID & vbcr & vbcr & objCDO
- strColor = GetColor(myitem, storeID, onNameSpace)
- Contents = Contents & strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
- arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount)& strTime & "<a href=""outlook:" & myitem.EntryID & """ style=""background-color: " & strColor & """>" & myitem.Subject & vbCrLf & "</a>"
- End If
- Next 'myitme In myRestrictItems
- Else 'i.e; If strEmptyCalendar = vbYes
- Contents = Contents & "<br><br>"
- arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & "<br><br>"
- End If 'If strEmptyCalendar = vbNo
- Contents = Contents & vbCrLf & "</TD>"
- arrTable(RowCount,ColCount) = arrTable(RowCount,ColCount) & vbCrLf & "</TD>"
- ColCount = ColCount + 1
- Next 'For i = StartMonth To EndMonth
- Contents = Contents & vbCrLf & "</TR>"
- If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For 'latest possible day in last week is Tuesday (31 days from Sunday)
- If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
- Next 'For intWeekday = 1 To 7
- If (Not blAlignWeekDays) And RowCount = 31 Then Exit For
- If blAlignWeekDays And RowCount = LastRowOfTable Then Exit For
- Next 'For week = 1 To 6
- 'create transposed contents
- tcontents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
- for i=0 to NbMonths
- tcontents = tcontents & "<TR valign='top' bgcolor='" & seashell & "'>"
- for j=0 to LastRowOfTable
- tcontents = tcontents & arrTable(j,i) & vbCR
- next
- tcontents = tcontents & "</TR>" & vbCR
- Next
- tcontents = tcontents & "</table>"
- 'create contents "7columns"
- c7contents = "<table width=100% border=1 style='font-family:verdana;font-size:40%;border-width:1px;border-collapse:collapse;cellpadding:2;border-color:gray'>"
- 'First Row - Weekdaynames
- c7contents = c7contents & vbCrLf & "<TR valign='top' bgcolor='gray'>"
- For intWeekday = 1 To 7
- c7contents = c7contents & vbCrLf & "<TD bgcolor='" & seashell & "' style='border-color:gray'><b>" & WeekdayName(intWeekday, False, vbMonday) & "</b></TD>"
- Next
- c7contents = c7contents & vbCrLf & "</TR><TR>"
- ColCount = 0
- 'Add some gray cells
- For i=1 To StrFirstMonthStartsOnA-1
- c7contents = c7contents & "<TD name='tableHeader' style='border-color:gray'></TD>"
- ColCount = ColCount + 1
- Next
- for i=0 to NbMonths
- For j=0 to LastRowOfTable
- 'filter out some unneeded cells with the if condition
- If InStr(arrTable(j,i),"tableHeader")=0 And InStr(arrTable(j,i),"bgcolor = '" & silver)=0 Then
- c7contents = c7contents & arrTable(j,i) & vbCR
- ColCount = ColCount +1
- End If
- If ColCount = 7 Then
- ColCount = 0
- c7contents = c7contents & "</TR>" & vbCR
- c7contents = c7contents & "<TR valign='top' bgcolor='" & seashell & "'>"
- End If
- next
- Next
- c7contents = c7contents & "</TR></table>"
- 'create the html files
- Set filesys = CreateObject("Scripting.FileSystemObject")
- Set F = filesys.OpenTextFile(strHtmlFile, ForWriting, True)
- F.Write strHeader & strTableHeader & Contents
- Set F = Nothing
- Set F = filesys.OpenTextFile(strHtmlFileTransposed, ForWriting, True)
- F.Write tcontents
- Set F = Nothing
- Set F = filesys.OpenTextFile(strHtmlFile7Columns, ForWriting, True)
- F.Write c7contents
- Set F = Nothing
- Set filesys = Nothing
- 'display the html files
- strCommand = "iexplore """ & strHtmlFile & """"
- objShell.run (strCommand)
- strCommand = "iexplore """ & strHtmlFileTransposed & """"
- objShell.run (strCommand)
- strCommand = "iexplore """ & strHtmlFile7Columns & """"
- objShell.run (strCommand)
- 'display containing folder
- strCommand = "explorer """ & strTempFolder & """"
- objShell.run (strCommand)
- Set objShell = Nothing
- Set objFSO = Nothing
- on error resume next
- objCDO.Logoff
- on error goto 0
- Set objCDO = Nothing
- Set MyFolder = Nothing
- Set MyCalendar = Nothing
- Set onNamespace = Nothing
- Set OL = Nothing
- End Sub
- '*************************************************************************************
- '***************** FUNCTIONS **************************************
- '*************************************************************************************
- Function GetColor(objAppt, storeID, onNamespace)
- 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"
- GetColor = ""
- If objAppt.Class = 26 Then ' = appointment
- Cat = objAppt.categories
- If Cat<>"" Then
- 'just the first cat
- If InStr(Cat, ",") Then Cat=Left(Cat,InStr(Cat, ",")-1)
- ColorCode = onNamespace.categories.item(Cat).Color
- GetColor = Mid(Colors,ColorCode*7+1,6)
- End if
- End If
- End Function
- Public Function GetExchangeServer(strMailbox)
- 'Root to where registry stores the outlook settings
- MainKeyPath = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
- 'get the default outlook profile option stored in the registry and add it to the key path
- Const HKEY_LOCAL_MACHINE = &H80000002
- Const HKEY_USERS = &H80000003
- strComputer ="."
- GetRegKeyStrValue strComputer, HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon", "DefaultUserName", username
- Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}//" & strComputer & "/root/default:StdRegProv")
- oReg.EnumKey HKEY_USERS,"", arrSubKeys
- 'msgbox MainKeyPath
- arrBinary = Array(1, 0)
- For i = 0 To UBound(arrBinary)
- KeyValue = KeyValue & Chr(arrBinary(i))
- Next
- For Each subkey In arrSubKeys
- sKey = subkey & "\Software\Microsoft\Windows\CurrentVersion\Explorer"
- REGusername = ""
- GetRegKeyStrValue strComputer, HKEY_USERS, sKey, "Logon User Name", REGusername
- If ucase(REGusername)=ucase(username) Then
- MainKeyPath = subkey & "\" & MainKeyPath
- GetRegKeyStrValue strComputer, HKEY_USERS, MainKeyPath, "DefaultProfile", DefaultProfile
- MainKeyPath = MainKeyPath & DefaultProfile
- GetRegKeyBinValue strComputer, HKEY_USERS, MainKeyPath & "\9207f3e0a3b11019908b08002b2a56c2", "01023d00", arrBinary
- 'msgbox MainKeyPath
- 'msgbox MainKeyPath
- arrBinary = Array(1, 0)
- For i = 0 To UBound(arrBinary)
- KeyValue = KeyValue & Chr(arrBinary(i))
- Next
- For i = 0 To UBound(arrBinary)
- KeyValue = KeyValue & Chr(arrBinary(i))
- Next
- 'msgbox Keyvalue
- NumFolders = Len(KeyValue) / 16
- For x = 1 To NumFolders
- 'Get next key name from list
- KeyName = Mid(KeyValue, ((x - 1) * 16) + 1, 16)
- KeyName = BinarySTRToText(Trim(KeyName))
- PSTKeyName = MainKeyPath & "\" & KeyName
- StoreType = ""
- If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3d09", arrBinary) <> "Failed" Then
- For i = 0 To UBound(arrBinary)-2 Step 2
- StoreType = StoreType & Chr(arrBinary(i))
- Next
- End If
- IF StoreType = "MSPST MS" or StoreType = "MSUPST MS" Then
- If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
- For i = 0 To UBound(arrBinary)-2 Step 2
- strMailboxFound = strMailboxFound & Chr(arrBinary(i))
- Next
- End If
- Else
- If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f3001", arrBinary) <> "Failed" Then
- For i = 0 To UBound(arrBinary)-2 Step 2
- PstKeyValue = PstKeyValue & Chr(arrBinary(i))
- Next
- strMailboxfound = PstKeyValue
- PstKeyValue = ""
- End If
- End If
- If GetRegKeyBinValue(strComputer, HKEY_USERS, PSTKeyName, "001f662b", arrBinary) <> "Failed" Then
- For i = 0 To UBound(arrBinary)-2 Step 2
- PstKeyValue = PstKeyValue & Chr(arrBinary(i))
- Next
- strServer = PstKeyValue
- If instr(strMailboxFound, strMailbox) Then
- 'MsgBox strMailboxFound & " " & strMailbox
- GetExchangeServer = strMailboxFound & "|" & strServer
- End If
- PstKeyValue = ""
- End If
- Next
- End If
- Next
- End Function
- Function GetRegKeyBinValue(sComputer, hTree, sKey, sValueName, sValue)
- Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
- lResult = oRegistry.GetBinaryValue(hTree, sKey, sValueName, sValue)
- If (lResult = 0) And (Err.Number = 0) Then
- GetRegKeyBinValue = "Succeeded"
- Else
- GetRegKeyBinValue = "Failed"
- sValue = ""
- End If
- Set oRegistry = Nothing
- End Function
- Function GetRegKeyStrValue(sComputer, hTree, sKey, sValueName, sValue)
- Dim oRegistry
- Dim lResult
- Set oRegistry = GetObject("winmgmts:{impersonationLevel=impersonate}//" & sComputer & "/root/default:StdRegProv")
- lResult = oRegistry.GetStringValue(hTree, sKey, sValueName, sValue)
- If (lResult = 0) And (Err.Number = 0) Then
- GetRegKeyStrValue = sValue
- Else
- GetRegKeyStrValue = "Failed"
- sValue = ""
- End If
- Set oRegistry = Nothing
- End Function
- Private Function BinarySTRToText(BinaryStr)
- For i = 1 To Len(BinaryStr)
- xstr = Mid(BinaryStr, i, 1)
- xlong = CLng(Asc(xstr))
- xvar = Hex(xlong)
- xstr = CStr(xvar)
- If Len(xstr) = 1 Then xstr = "0" & xstr
- BinarySTRToText = BinarySTRToText & xstr
- Next
- End Function
nach VBA verschoben, Spoiler eingefügt
-Artentus
Dieser Beitrag wurde bereits 2 mal editiert, zuletzt von „Artentus“ ()