K
ker_01
Well, I don't see a way to cross-post using MS's Discussion Groups interface
(the only option I have, here at work) so I'll post here first, then switch
to the Excel group if needed later. I'm working in a mixed environment of
Office/Outlook XP and 2007
I have some code (pasted below) that allows each user of a workbook to run
the main macro and it searches their calendar for any appointments that have
the word "vacation" in the subject line, and transfers the duration and
subject line to a calendar built in Excel. Each user has their own sheet in
the Excel workbook, and that is used as the overall mechanism for vacation
tracking.
I'm interested in improving this in two ways, and would welcome any
suggestions.
(1) Currently, it only works with same-day, non-recurring appointments. In
other words, if someone makes their vacation date on Monday and sets it to
recur daily for 4 more days (one week of vacation) this code only recognizes
the first day of vacation. Ideally it would pull over all the days of
vacation. Similar problem with long appointments- a vacation appointment
starts Monday at 8am and ends Friday at 5pm- I'm not sure how to accurately
break that up into the component days. Is there any reliable way to do this?
(2) We would like to make one person in our office an 'administrator' on
everyone's calendar- with viewing priviledges. Rather than having to have
each person open the Excel workbook and run the macro, it would be simpler
(and more reliable) to have one person run them all at once (monthly).
Assuming I have an array of the appropriate user IDs, can anyone provide
sample code for searching more than one shared calendar for appointments,
using a loop so I always know which calendar to assign a vacation date to?
Thank you!
Keith
My apologies if I've forgotten to give credit anywhere in the code:
Option Base 1
'Randy Birch code:
'Declarations deleted for this post
'Randy Birch code:
'Function/Sub deleted for this post
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Part of this code Copyright ©1996-2004 VBnet, Randy Birch, All Rights
Reserved.
' See distribution note below for why some of the functions are not included
in this post
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
' (Randy Birch code)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Randy Birch code:
'Declarations deleted for this post
'Randy Birch code:
'Private Function to get user name deleted for this post
Sub JustGetName()
Dim oWrkSht As Worksheet
Dim sUsername As String
sUsername = LCase(Trim(GetThreadUserName()))
CheckArray = Array("userID_1", "userID_2","userID_3", "userID_4")
UseRef = Array(Sheet1, Sheet2, Sheet3, Sheet4)
For checkname = 1 To 4
If CheckArray(checkname) = LCase(sUsername) Then
Set oWrkSht = UseRef(checkname)
oWrkSht.Visible = xlSheetVisible
FoundIt = True
Exit For
End If
Next
If FoundIt = False Then '(show a sample for new users)
Sheet5.Visible = xlSheetVisible
End If
End Sub
Public Sub Synch_Vacation_Time() 'This is the main sub
Dim oWrkSht As Worksheet
Dim ApptArray(1 To 12, 1 To 3, 1 To 25) 'holds appt data
Dim LocArray(1 To 12) 'Counting array for how many appts per month
Dim UseRef As Variant '() As Worksheets 'holds worksheet names
Dim CheckArray As Variant '() As String 'holds all possible UserIDs
Dim MAdjArray As Variant '() 'offsets number of days to start of month
Dim okArray As Variant
Dim RefArray As Variant
Dim SetMonthlyOffsets As Variant
Dim sUsername As String
Dim i As Integer
Dim p As Integer
Dim UserRow As Integer
CheckArray = ("userID_1", "userID_2","userID_3", "userID_4")
UseRef = Array(Sheet1, Sheet2, Sheet3, Sheet4)
'number of "empty" days before first day on first line each month
'MAdjArray = Array(6, 2, 2, 5, 0, 3, 5, 1, 4, 6, 2, 4) '2005
'MAdjArray = Array(0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5) '2006
'MAdjArray = Array(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6) '2007
'MAdjArray = Array(2, 5, 6, 2, 4, 0, 2, 5, 1, 3, 6, 1) '2008
MAdjArray = Array(4, 0, 0, 3, 5, 1, 3, 6, 2, 4, 0, 2) '2009
i = 1
p = 1
UserRow = 1
'***** Set counting array so that each month starts with no entries *****
For MyReset = 1 To 12
LocArray(MyReset) = 1
Next
'***** Find the sheet assigned to the UserID *****
sUsername = LCase(Trim(GetThreadUserName()))
FoundIt = False
For checkname = 1 To 22
If CheckArray(checkname) = sUsername Then
Set oWrkSht = UseRef(checkname)
FoundIt = True
Exit For
End If
Next
If FoundIt = True Then
If SocketsInitialize() Then
oWrkSht.Range("V1").Value = GetIPFromHostName(GetPcName)
End If
SocketsCleanup
End If
If FoundIt = False Then
Set oWrkSht = UseRef(20)
MsgBox "Your UserID (" & sUsername & ") was not found in the names
list." & Chr(13) & _
"If you wish to be added after playing with this
sample, please press the Print Screen (PrtSc) key in the upper right part of
your keyboard, then paste from the clipboard into an email to Keith so he can
add you." _
, , "UserID not found"
'Exit Sub
End If
'***** Clear any existing records *****
With oWrkSht
.Activate
..Range("17:17,19:19,21:21,23:23,25:25,27:27,33:33,35:35,37:37,39:39,41:41,43:43,49:49,51:51,53:53,55:55,57:57,59:59,65:65,67:67,69:69,71:71,73:73,75:75").Select
.Range("A75").Activate
Selection.ClearContents
Selection.ClearComments
Range("A1").Select
End With
'for late binding:
Dim olApp As Object
Dim olNs As Object
Const olFldrCalendar As Long = 9
Dim olApt As Object
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFldrCalendar)
'Set olApt = olFldr.Items
'appointmentitem = sub of olApt, holds subject, etc.
'for early binding
' Dim olApp As Outlook.Application
' Dim olNs As Namespace
' Dim olFldr As MAPIFolder
' Dim olApt As AppointmentItem
' Set olApp = New Outlook.Application
' Set olNs = olApp.GetNamespace("MAPI")
' Set olFldr = olNs.GetDefaultFolder(olFolderCalendar)
'***** Pull all outlook data into an array *****
For Each olApt In olFldr.Items
If TypeName(olApt) = "AppointmentItem" Then
If InStr(1, olApt.Subject, "Vacation", vbTextCompare) > 0 Then
If Year(olApt.Start) = 2009 Then
MyDur = olApt.Duration / 60
If MyDur > 24 Then MsgBox "A 'Vacation' entry of more than
one day was detected. This workbook can only detect non-repeating, single-day
vacation entries", , "Error: Source data problem"
If MyDur > 8 Then MyDur = 8
' UseRow = Format(olApt.Start, "mm")
eachmonth = Val(Format(olApt.Start, "mm"))
ThisDay = Val(Format(olApt.Start, "dd"))
'LastDay = Val(Format(olApt.End, "dd"))
'Gives starting row position
PasteMonthStartRow = 16 * ((eachmonth - 1) \ 3) + 17
'gives 1, 2, or 3 for the column grouping
PasteMonthStartColumn = (eachmonth Mod 3)
If PasteMonthStartColumn = 0 Then PasteMonthStartColumn = 3
'Gives the number of the actual start column
PasteMonthStartColumn = ((PasteMonthStartColumn - 1) * 7) + 1
OffsetX = (((MAdjArray(eachmonth)) + (ThisDay - 1)) \ 7) * 2
OffsetY = ((MAdjArray(eachmonth)) + (ThisDay - 1)) Mod 7
PasteMonthRow = PasteMonthStartRow + OffsetX
PasteMonthColumn = Trim(Chr((PasteMonthStartColumn +
OffsetY) + 64))
With oWrkSht
.Activate
.Range(PasteMonthColumn & PasteMonthRow).Select
Selection.Value = MyDur
Selection.AddComment (olApt.Subject)
End With
'MsgBox "Appt found:" & Chr(13) & Format(olApt.Start,
"mm/dd/yy") & Chr(13) & _
' "'" & PasteMonthColumn & "' '" & PasteMonthRow &
"'" & Chr(13) & _
' "'" & PasteMonthStartColumn & "' '" &
PasteMonthAddColumns & "'" & Chr(13) & _
' "'" & PasteMonthStartRow & "' '" &
PasteMonthAddRows & "'" & Chr(13)
'Debug.Print olApt.Subject, MyDur, Format(olApt.Start,
"mm/dd/yy")
End If
End If
End If
Next olApt
Set olApt = Nothing
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
(the only option I have, here at work) so I'll post here first, then switch
to the Excel group if needed later. I'm working in a mixed environment of
Office/Outlook XP and 2007
I have some code (pasted below) that allows each user of a workbook to run
the main macro and it searches their calendar for any appointments that have
the word "vacation" in the subject line, and transfers the duration and
subject line to a calendar built in Excel. Each user has their own sheet in
the Excel workbook, and that is used as the overall mechanism for vacation
tracking.
I'm interested in improving this in two ways, and would welcome any
suggestions.
(1) Currently, it only works with same-day, non-recurring appointments. In
other words, if someone makes their vacation date on Monday and sets it to
recur daily for 4 more days (one week of vacation) this code only recognizes
the first day of vacation. Ideally it would pull over all the days of
vacation. Similar problem with long appointments- a vacation appointment
starts Monday at 8am and ends Friday at 5pm- I'm not sure how to accurately
break that up into the component days. Is there any reliable way to do this?
(2) We would like to make one person in our office an 'administrator' on
everyone's calendar- with viewing priviledges. Rather than having to have
each person open the Excel workbook and run the macro, it would be simpler
(and more reliable) to have one person run them all at once (monthly).
Assuming I have an array of the appropriate user IDs, can anyone provide
sample code for searching more than one shared calendar for appointments,
using a loop so I always know which calendar to assign a vacation date to?
Thank you!
Keith
My apologies if I've forgotten to give credit anywhere in the code:
Option Base 1
'Randy Birch code:
'Declarations deleted for this post
'Randy Birch code:
'Function/Sub deleted for this post
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Part of this code Copyright ©1996-2004 VBnet, Randy Birch, All Rights
Reserved.
' See distribution note below for why some of the functions are not included
in this post
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
' applications, but you may not reproduce
' or publish this code on any web site,
' online service, or distribute as source
' on any media without express permission.
' (Randy Birch code)
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'Randy Birch code:
'Declarations deleted for this post
'Randy Birch code:
'Private Function to get user name deleted for this post
Sub JustGetName()
Dim oWrkSht As Worksheet
Dim sUsername As String
sUsername = LCase(Trim(GetThreadUserName()))
CheckArray = Array("userID_1", "userID_2","userID_3", "userID_4")
UseRef = Array(Sheet1, Sheet2, Sheet3, Sheet4)
For checkname = 1 To 4
If CheckArray(checkname) = LCase(sUsername) Then
Set oWrkSht = UseRef(checkname)
oWrkSht.Visible = xlSheetVisible
FoundIt = True
Exit For
End If
Next
If FoundIt = False Then '(show a sample for new users)
Sheet5.Visible = xlSheetVisible
End If
End Sub
Public Sub Synch_Vacation_Time() 'This is the main sub
Dim oWrkSht As Worksheet
Dim ApptArray(1 To 12, 1 To 3, 1 To 25) 'holds appt data
Dim LocArray(1 To 12) 'Counting array for how many appts per month
Dim UseRef As Variant '() As Worksheets 'holds worksheet names
Dim CheckArray As Variant '() As String 'holds all possible UserIDs
Dim MAdjArray As Variant '() 'offsets number of days to start of month
Dim okArray As Variant
Dim RefArray As Variant
Dim SetMonthlyOffsets As Variant
Dim sUsername As String
Dim i As Integer
Dim p As Integer
Dim UserRow As Integer
CheckArray = ("userID_1", "userID_2","userID_3", "userID_4")
UseRef = Array(Sheet1, Sheet2, Sheet3, Sheet4)
'number of "empty" days before first day on first line each month
'MAdjArray = Array(6, 2, 2, 5, 0, 3, 5, 1, 4, 6, 2, 4) '2005
'MAdjArray = Array(0, 3, 3, 6, 1, 4, 6, 2, 5, 0, 3, 5) '2006
'MAdjArray = Array(1, 4, 4, 0, 2, 5, 0, 3, 6, 1, 4, 6) '2007
'MAdjArray = Array(2, 5, 6, 2, 4, 0, 2, 5, 1, 3, 6, 1) '2008
MAdjArray = Array(4, 0, 0, 3, 5, 1, 3, 6, 2, 4, 0, 2) '2009
i = 1
p = 1
UserRow = 1
'***** Set counting array so that each month starts with no entries *****
For MyReset = 1 To 12
LocArray(MyReset) = 1
Next
'***** Find the sheet assigned to the UserID *****
sUsername = LCase(Trim(GetThreadUserName()))
FoundIt = False
For checkname = 1 To 22
If CheckArray(checkname) = sUsername Then
Set oWrkSht = UseRef(checkname)
FoundIt = True
Exit For
End If
Next
If FoundIt = True Then
If SocketsInitialize() Then
oWrkSht.Range("V1").Value = GetIPFromHostName(GetPcName)
End If
SocketsCleanup
End If
If FoundIt = False Then
Set oWrkSht = UseRef(20)
MsgBox "Your UserID (" & sUsername & ") was not found in the names
list." & Chr(13) & _
"If you wish to be added after playing with this
sample, please press the Print Screen (PrtSc) key in the upper right part of
your keyboard, then paste from the clipboard into an email to Keith so he can
add you." _
, , "UserID not found"
'Exit Sub
End If
'***** Clear any existing records *****
With oWrkSht
.Activate
..Range("17:17,19:19,21:21,23:23,25:25,27:27,33:33,35:35,37:37,39:39,41:41,43:43,49:49,51:51,53:53,55:55,57:57,59:59,65:65,67:67,69:69,71:71,73:73,75:75").Select
.Range("A75").Activate
Selection.ClearContents
Selection.ClearComments
Range("A1").Select
End With
'for late binding:
Dim olApp As Object
Dim olNs As Object
Const olFldrCalendar As Long = 9
Dim olApt As Object
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFldrCalendar)
'Set olApt = olFldr.Items
'appointmentitem = sub of olApt, holds subject, etc.
'for early binding
' Dim olApp As Outlook.Application
' Dim olNs As Namespace
' Dim olFldr As MAPIFolder
' Dim olApt As AppointmentItem
' Set olApp = New Outlook.Application
' Set olNs = olApp.GetNamespace("MAPI")
' Set olFldr = olNs.GetDefaultFolder(olFolderCalendar)
'***** Pull all outlook data into an array *****
For Each olApt In olFldr.Items
If TypeName(olApt) = "AppointmentItem" Then
If InStr(1, olApt.Subject, "Vacation", vbTextCompare) > 0 Then
If Year(olApt.Start) = 2009 Then
MyDur = olApt.Duration / 60
If MyDur > 24 Then MsgBox "A 'Vacation' entry of more than
one day was detected. This workbook can only detect non-repeating, single-day
vacation entries", , "Error: Source data problem"
If MyDur > 8 Then MyDur = 8
' UseRow = Format(olApt.Start, "mm")
eachmonth = Val(Format(olApt.Start, "mm"))
ThisDay = Val(Format(olApt.Start, "dd"))
'LastDay = Val(Format(olApt.End, "dd"))
'Gives starting row position
PasteMonthStartRow = 16 * ((eachmonth - 1) \ 3) + 17
'gives 1, 2, or 3 for the column grouping
PasteMonthStartColumn = (eachmonth Mod 3)
If PasteMonthStartColumn = 0 Then PasteMonthStartColumn = 3
'Gives the number of the actual start column
PasteMonthStartColumn = ((PasteMonthStartColumn - 1) * 7) + 1
OffsetX = (((MAdjArray(eachmonth)) + (ThisDay - 1)) \ 7) * 2
OffsetY = ((MAdjArray(eachmonth)) + (ThisDay - 1)) Mod 7
PasteMonthRow = PasteMonthStartRow + OffsetX
PasteMonthColumn = Trim(Chr((PasteMonthStartColumn +
OffsetY) + 64))
With oWrkSht
.Activate
.Range(PasteMonthColumn & PasteMonthRow).Select
Selection.Value = MyDur
Selection.AddComment (olApt.Subject)
End With
'MsgBox "Appt found:" & Chr(13) & Format(olApt.Start,
"mm/dd/yy") & Chr(13) & _
' "'" & PasteMonthColumn & "' '" & PasteMonthRow &
"'" & Chr(13) & _
' "'" & PasteMonthStartColumn & "' '" &
PasteMonthAddColumns & "'" & Chr(13) & _
' "'" & PasteMonthStartRow & "' '" &
PasteMonthAddRows & "'" & Chr(13)
'Debug.Print olApt.Subject, MyDur, Format(olApt.Start,
"mm/dd/yy")
End If
End If
End If
Next olApt
Set olApt = Nothing
Set olFldr = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub