Daily hours of recurring/ multi-day appts, & accessing mult calend

Status
Not open for further replies.
A

a2VyXzAx

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
 
1) See http://www.outlookcode.com/article.aspx?id=30 for information on how

to search for appointments over a date range and include recurrences.

2) You can use the Namespace.GetSharedDefaultFolder() method to return

another Exchange mailbox's Calendar folder.

Sue Mosher

"ker_01" <ker01> wrote in message

news:40396880-1E47-4D67-9D08-64E4277BA793@microsoft.com...
> 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

>
 
Re: Daily hours of recurring/ multi-day appts, & accessing mult ca

Awesome- thanks Sue!

Keith

"Sue Mosher [MVP]" wrote:


> 1) See http://www.outlookcode.com/article.aspx?id=30 for information on how
> to search for appointments over a date range and include recurrences.

> 2) You can use the Namespace.GetSharedDefaultFolder() method to return
> another Exchange mailbox's Calendar folder.

> > Sue Mosher
> > >

> "ker_01" <ker01> wrote in message
> news:40396880-1E47-4D67-9D08-64E4277BA793@microsoft.com...
> > 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
> >


>
 
Status
Not open for further replies.
Similar threads
Thread starter Title Forum Replies Date
K Daily Task List Minimized Cannot Display Using Outlook 5
M Calendar daily Appointments and printing Using Outlook 0
A Create date folder and move messages daily Outlook VBA and Custom Forms 1
M Daily Task List Minimized Cannot Display Using Outlook 2
K Daily task list > show tasks on the exact due date and not on the "current date" Using Outlook 1
S Calendar Daily Eventy Grouping Using Outlook 1
N Daily email Using Outlook 2
X When travel between time zones Calendar Daily Items a fixed times vs Meetings? Using Outlook 2
P Daily Automatic Reply Using Outlook 1
E Adding Start and End Time to Daily View in Calendar Printing assistant Using Outlook 1
M Rules - daily status (email) doesn't change much daily, save 1 per week how? Using Outlook 1
R Outlook 2010 Daily Calender need high detail Using Outlook 2
E Daily Task List customization Using Outlook 1
Cathy Rhone New template: Daily Index Card Calendar Template for CPAO Using Outlook 1
S Identify weekend from daily RecurrencePattern Outlook VBA and Custom Forms 2
G Daily Task List for shared calendar Using Outlook 3
G What does 'daily limit has been reached' mean in Outlook 2007? BCM (Business Contact Manager) 1
H daily email count in Outlook Using Outlook 3
L Outlook 2019 MAC sync error after working for 4 hours Using Outlook 1
G Calendar View in Outlook Office 365 - Doesn't show enough hours, and the 30/60 min choice isn't the solution Using Outlook 4
Venkata Murugan Guna How to sum hours, minutes, or seconds in Outlook Using Outlook 51
GregS Outlook mail arrives in batches, sometimes hours late Using Outlook 1
Diane Poremsky How to Process Mail After Business Hours Using Outlook 0
Diane Poremsky How to Always Process Mail After Business Hours Using Outlook 0
C Need rule to alert when an email has not been replied to within 24 hours Using Outlook 1
M Outlook Is Disconnected In the Morning Or After Few Hours Exchange Server Administration 1
L Schedule Assistant shows wrong working hours Using Outlook 1
M Run rules after mail is 24 hours old Using Outlook 1
B Microsoft office outlook 2007 showing configuring outlook accounts for hours Using Outlook 6
S Emails during business hours ONLY. Using Outlook 1
P Change the hours in a working day Using Outlook 6
B Recurring meeting times off by several hours Exchange Server Administration 5
K report of Available hours for a team of staff from OUtlook Calenda Outlook VBA and Custom Forms 2
R Unable to set outlook task due date in hours Outlook VBA and Custom Forms 1
D Desperate hours BCM (Business Contact Manager) 1
S Outlook 2016 Understand and customize prepended behavior of recurring task Using Outlook 0
J Recurrence pattern blank on recurring meetings? Using Outlook 4
G Schedule recurring email and attachments display Outlook VBA and Custom Forms 3
V Outlook 2016 Multiple recurring tasks getting created Using Outlook 0
S Changing colors of today's appointments, but not recurring ones Using Outlook 33
G Recurring tasks break links Outlook 2016 Using Outlook 5
A Unable to save recurring Meeting to Documents folder due to error Using Outlook 2
K Recurring all day annual event Using Outlook 3
P Restore an individual all-day recurring event Using Outlook 2
F Year-and-a-day recurring appointments Using Outlook 1
P Receiving a Meeting Declined notice for a recurring meeting Using Outlook 0
N Recurring invite sent w/distribution list adding/removing attendees Using Outlook 0
C Recurring Task End Date Varies Using Outlook 3
M Expected behaviour of recurring appointments? Using Outlook 2
K Outlook 2013 Recurring Tasks Not Showing Complete Outlook.com Using Outlook.com accounts in Outlook 1

Similar threads

Back
Top