I stepped through this multiple times and it executes without issue.
I set up a watch on "Item.GetReccurrencePattern.PatternEndDate" for the calling procedure (i.e. Application_Reminder event) and the end date does change.
But, when I view my calendar, the additional meetings haven't been created.
And when I open up an occurrence of the meeting, it shows the original end date in the recurrence settings.
Private Sub Application_Reminder(ByVal Item As Object)
If Item.MessageClass <> "IPM.Appointment" Then Exit Sub
Dim myItem As AppointmentItem
Set myItem = Item
Dim DoIt As Boolean
Select Case myItem.ConversationTopic
Case "TEST"
DoIt = True
'Will use this for multiple meetings, that's why using select
End Select
If DoIt Then ExtendAppt myItem
Set myItem = Nothing
End Sub
Private Sub ExtendAppt(ByRef myApptItem As Outlook.AppointmentItem)
Dim myRecurrPatt As Outlook.RecurrencePattern
Set myRecurrPatt = myApptItem.GetRecurrencePattern
Dim origStart As Date
Dim origEnd As Date
Dim thisWeek As Date
Dim recDate As Long
Dim deltaEnd As Long
Dim newEnd As Date
Dim howMany As Long
origStart = myRecurrPatt.PatternStartDate
origEnd = myRecurrPatt.PatternEndDate
Select Case myRecurrPatt.DayOfWeekMask
Case olFriday
recDate = vbFriday
Case olMonday
recDate = vbMonday
Case olTuesday
recDate = vbTuesday
Case olWednesday
recDate = vbWednesday
Case olThursday
recDate = vbThursday
Case olFriday
recDate = vbFriday
Case olSaturday
recDate = vbSaturday
Case olSunday
recDate = vbSunday
Case Else
'not recurring or error
Exit Sub
End Select
thisWeek = Date - Weekday(Date, recDate) + 1
deltaEnd = DateDiff("ww", origEnd, thisWeek)
If deltaEnd Mod (2) = 0 Then howMany = 10 Else howMany = 9
newEnd = DateAdd("ww", howMany, thisWeek)
myRecurrPatt.PatternEndDate = newEnd
myApptItem.Save
'Release references to the appointment series
Set myApptItem = Nothing
Set myRecurrPatt = Nothing
End Sub
Related
Sorry but I'm a total newbie in CATScript.
But I'm looking for a solution that will provide me to check every node in my Product structure recursively.
I try to adopt the Fibonacci procedure:
Function Fib(n As Long) As Long
Dim first As Long
Dim second As Long
Dim sum As Long
Dim i As Long
first = 0
second = 1
sum = 0
If n = 0 Then
Fib = first
ElseIf n = 1 Then
Fib = second
Else
For i = 2 To n
sum = first + second
first = second
second = sum
Next i
Fib = sum
End If
End Function
with this:
Private Sub TestMain
Dim searchName As String
searchName = "SearchName"
' Start with the selected object
Dim doc As Document
Set doc = CATIA.ActiveDocument
Dim prod As Product
Set prod = doc.Product
Dim foundItem As Object
foundItem = TestMainChildren(doc.Selection.Item(1).Value, searchName)
MsgBox "Found: " & foundItem.Name
End Sub
Private Function TestMainChildren(ByRef catiaObject As Object, ByVal searchName As String) As Object
Dim item As Object
For Each item In catiaObject.Items
If item.Name = "SearchName" then
Set TestMainChildren = item
Exit For
End if
Dim catiaType As String
catiaType = TypeName(item)
If catiaType = "Product" Then
TestMainChildren item, searchName
End If
Next
End Sub
but I have no idea how to do this. Can anybody help here?
It depends on what you want, but it is often very useless to check all the instances whith a recursive loop.
what is your end goal?
i suggest you to check every instance opened :
Sub main()
Dim d As Document
For Each d In CATIA.Documents
Dim p As Product
Set p = d.Product
MsgBox (p.Name)
Next
End Sub
If you insist and really want a recursive loop :
Sub main()
Dim d As Document
Set d = CATIA.ActiveDocument
Dim p As Product
Set p = d.Product
Call RecursiveAllProducts(p) 'here your recursive starts
End Sub
Sub RecursiveAllProducts(p As Product) 'your recursive
MsgBox (p.PartNumber)
If p.Products.Count > 0 Then
For i = 1 To p.Products.Count
Dim p_ As Product
Set p_ = p.Products.Item(i)
Call RecursiveAllProducts(p_) 'you call your recursive again
Next i
End If
End Sub
I am using a function to get dates between 2 sets of dates, it works, however I would like to only get dates that are workdays:
Have tried incorporating
Application.WorksheetFunction.WorkDay but I am still getting non workdays in the set of dates - any suggestions?
Original function:
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(StartDate)
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
End Function
Trial to exclude non workdays:
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
For lngDateCounter = LBound(varDates) To UBound(varDates)
varDates(lngDateCounter) = CDate(Application.WorksheetFunction.WorkDay(StartDate, 0))
StartDate = CDate(CDbl(StartDate) + 1)
Next lngDateCounter
getDates = varDates
End Function
Give this a try:
The collections for holidays (fixed and floating) are initialized with hard coded dates but it would be better if the dates were read from a worksheet or table.
Private mFixedHolidays As Collection
Private mFloatingHolidays As Collection
Public Function getDates(ByVal StartDate As Date, ByVal EndDate As Date) As Variant
Dim varDates() As Date
Dim lngDateCounter As Long
ReDim varDates(0 To CLng(EndDate) - CLng(StartDate))
Dim dTotalWorkdays As Long
dTotalWorkdays = 0
Dim dDate As Date
dDate = StartDate
For lngDateCounter = LBound(varDates) To UBound(varDates)
If Not (IsWeekendDay(dDate) Or IsFixedHoliday(dDate) Or IsFloatingHoliday(dDate)) Then
varDates(dTotalWorkdays) = dDate
dTotalWorkdays = dTotalWorkdays + 1
End If
dDate = CDate(CDbl(dDate) + 1)
Next lngDateCounter
ReDim Preserve varDates(dTotalWorkdays - 1)
getDates = varDates
End Function
Private Function IsWeekendDay(ByVal dateOfInterest As Date) As Boolean
IsWeekendDay = _
Weekday(dateOfInterest) = VbDayOfWeek.vbSaturday _
Or Weekday(dateOfInterest) = VbDayOfWeek.vbSunday
End Function
Private Function IsFixedHoliday(ByVal dateOfInterest As Date) As Boolean
Dim result As Boolean
result = False
If mFixedHolidays Is Nothing Then
Set mFixedHolidays = New Collection
'Year portion of dates will be ignored
With mFixedHolidays
.Add "7/4/2022"
.Add "12/25/2022"
.Add "1/1/2022"
'Add other fixed date holidays
End With
End If
Dim fixedDate As Date
Dim dateToken As Variant
For Each dateToken In mFixedHolidays
fixedDate = DateValue(dateToken)
If Month(fixedDate) = Month(dateOfInterest) And Day(fixedDate) = Day(dateOfInterest) Then
result = True
Exit For
End If
Next
IsFixedHoliday = result
End Function
Private Function IsFloatingHoliday(ByVal dateOfInterest As Date) As Boolean
Dim result As Boolean
result = False
If mFloatingHolidays Is Nothing Then
Set mFloatingHolidays = New Collection
With mFloatingHolidays
.Add "5/30/2022" 'Memorial Day
'Add other floating date holidays
End With
End If
Dim floatingDate As Date
Dim dateToken As Variant
For Each dateToken In mFloatingHolidays
floatingDate = DateValue(dateToken)
If floatingDate = dateOfInterest Then
result = True
Exit For
End If
Next
IsFloatingHoliday = result
End Function
I had previously asked about how to evenly distribute the items in n lists into a single list and was referred to this question: Good algorithm for combining items from N lists into one with balanced distribution?.
I made a practical example of my solution for this in VBA for Excel, since my application for this was resorting my Spotify lists which can be easily pasted into Excel for manipulation. Assumptions are that you have a headerless worksheet (wsSource) of songs with columns A, B, C representing Artist, Song, SpotifyURI respectively, a "Totals" worksheet (wsTotals) containing the sum of songs for each Artist from wsSource sorted in descending order, and a "Destination" worksheet where the new list will be created. Could I get some suggestions to improve this? I was going to get rid of the totals worksheet and have this portion done in code, but I have to go and I wanted to go ahead and put this out there. Thanks!
Sub WeaveSort()
Dim wb As Workbook
Dim wsDest As Worksheet
Dim wsSource As Worksheet
Dim wsTotals As Worksheet
Dim i As Integer
Dim iLast As Integer
Dim iDest As Integer
Dim iSource As Integer
Dim iOldRow As Integer
Dim iNewRow As Integer
Dim dDiff As Double
Dim dDiffSum As Double
Set wb = ThisWorkbook
Set wsTotals = wb.Worksheets("Totals")
Set wsSource = wb.Worksheets("Source")
Set wsDest = wb.Worksheets("Dest")
iLast = wsTotals.Range("A1").End(xlDown).Row - 1
For i = 2 To iLast
iSource = wsTotals.Range("B" & i).Value
iDest = wsDest.Range("A99999").End(xlUp).Row
If i = 2 Then
wsDest.Range("A1:C" & iSource).Value2 = wsSource.Range("A1:C" & iSource).Value2
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
GoTo NextI
End If
dDiff = iDest / iSource
dDiffSum = 0
iNewRow = 0
For iOldRow = 1 To iSource
dDiff = iDest / iSource
dDiffSum = dDiffSum + dDiff
iNewRow = Round(dDiffSum, 0)
wsSource.Rows(iOldRow).Copy
wsDest.Rows(iNewRow).Insert xlShiftDown
iDest = iDest + 1
Next iOldRow
wsSource.Range("A1:C" & iSource).Delete (xlShiftUp)
NextI:
Next i
End Sub
Great question! I would take an object oritentated approach. Also I didn;t think it was clear what the logic was so here is my answer. Two classes and one normal module. Save these separately with the filenames ListManager.cls, List.cls, tstListManager.bas
So the ListManager.cls is this
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "ListManager"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mdic As Object
Public Sub Initialise(ByVal vLists As Variant)
Set mdic = VBA.CreateObject("Scripting.Dictionary")
Dim vListLoop As Variant
For Each vListLoop In vLists
Dim oList As List
Set oList = New List
oList.Initialise vListLoop, ""
mdic.Add mdic.Count, oList
Next
End Sub
Public Function WeaveSort() As Variant
Dim dicReturn As Object
Set dicReturn = VBA.CreateObject("Scripting.Dictionary")
Dim oNextList As List
Set oNextList = Me.WhichListHasLeastProgress
While oNextList.PercentageDone <= 1
Dim vListItem As Variant
vListItem = oNextList.GetListItem
dicReturn.Add dicReturn.Count, vListItem
oNextList.MoveNext
Set oNextList = Me.WhichListHasLeastProgress
Wend
Dim vItems As Variant
vItems = dicReturn.Items
'I don't like this bit
ReDim vRet(1 To dicReturn.Count, 1 To 1)
Dim lLoop As Long
For lLoop = 0 To dicReturn.Count - 1
vRet(lLoop + 1, 1) = vItems(lLoop)
Next lLoop
WeaveSort = vRet
End Function
Public Function WhichListHasLeastProgress() As List
Dim vKeyLoop As Variant
Dim oListLoop As List
Dim oLeastProgress As List
For Each vKeyLoop In mdic.keys
Set oListLoop = mdic.Item(vKeyLoop)
If oLeastProgress Is Nothing Then
'nothing to compare yet
Set oLeastProgress = oListLoop
Else
If oListLoop.PercentageDone < oLeastProgress.PercentageDone Then
'definitely take this new candidate
Set oLeastProgress = oListLoop
ElseIf oListLoop.PercentageDone = oLeastProgress.PercentageDone And oListLoop.Size > oListLoop.Size Then
'close thing, both showing equal progress but we should give it to the one with the bigger "queue"
Set oLeastProgress = oListLoop
Else
'no swap
End If
End If
Next
'return the answer
Set WhichListHasLeastProgress = oLeastProgress
End Function
and the List.cls file is
VERSION 1.0 CLASS
BEGIN
MultiUse = -1 'True
END
Attribute VB_Name = "List"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
Private mvList As Variant
Private mlCount As Long
Private mlCursor As Long
Private mvName As Variant
Public Function Initialise(ByRef vList As Variant, ByVal vName As Variant)
Debug.Assert TypeName(vList(1, 1)) <> "" ' this will break unless you specify a 2d array
Debug.Assert LBound(vList, 1) = 1 ' this ensure you got it from a sheet
mvList = vList
mlCount = UBound(mvList)
mlCursor = 1
mvName = vName
End Function
Public Function GetListItem()
GetListItem = mvList(mlCursor, 1)
End Function
Public Function Name() As Variant
Name = mvName
End Function
Public Function MoveNext() As Boolean
mlCursor = mlCursor + 1
MoveNext = (mlCursor < mlCount)
End Function
Public Function Size() As Long
Size = mlCount
End Function
Public Function PercentageDone() As Double
PercentageDone = mlCursor / mlCount
End Function
The last file is this tstListManager.bas
Attribute VB_Name = "tstListManager"
Option Explicit
Sub test()
Dim oListMan As ListManager
Set oListMan = New ListManager
Dim vLists As Variant
vLists = VBA.Array(ThisWorkbook.Sheets("Source").Range("A1:A3").Value2, _
ThisWorkbook.Sheets("Source").Range("B1:B2").Value2, _
ThisWorkbook.Sheets("Source").Range("C1:C5").Value2)
oListMan.Initialise vLists
Dim vSorted As Variant
vSorted = oListMan.WeaveSort
Dim lTotal As Long
ThisWorkbook.Sheets("Dest").Range("A1").Resize(UBound(vSorted, 1)).Value2 = vSorted
End Sub
Finally, the test data was in A1:A3 B1:B2 C1:C5
You should note I have abstracted away any Excel reading/writing logic and the pure weavesort logic is not cluttered.
Feel free to reject outright. Object orientation can be quite controversial and we think differently. :)
I am developing a routine to calculate the proper futures contract front month
If i have a array of integers denoting month numbers ie, "1,4,7,10,12"
and I have a variable integer that is 2.
How do i test the variable against the array and change the variable to the next highest available in the array if the variable itself wasn't in the array? ie in this case the variable's value of 2 would become 4.
I've tried various ways but am stuck now
If datenum >= (targetdayofmonth + adjdays) Then
currentmonth = currentmonth + 1
Dim currmonthname As String = MonthName(currentmonth, True)
For x As Integer = 0 To contractmonths.Count - 1
If GetMonthNumberfromShortMonthName(contractmonths(x)) = currentmonth Then
currmonthname = currmonthname
Else
End If
Next
Else
Dim currmonthname As String = MonthName(currentmonth, True)
End If
So based on Tim's comments I've updated the code to;
Dim contractmonthNos As New List(Of Int32)
For Each childnode As XmlNode In From childnode1 As XmlNode In root Where childnode1.SelectSingleNode("futures/symbol/Code").InnerText = commodcode
'get the available contract months for this contract
Dim contractmonthnodes As XmlNode = childnode.SelectSingleNode("ContractMonths")
contractmonthNos.AddRange(From subnode As XmlNode In contractmonthnodes Select GetMonthNumberfromShortMonthName(subnode.Name))
Next
If datenum >= (targetdayofmonth + adjdays) Then
currentmonth = currentmonth + 1
Dim currmonthname As String = MonthName(currentmonth, True)
Else
Dim nextmonth = From month As Integer In contractmonthNos Where month > currentmonth
If nextmonth.Any() Then
currentmonth = nextmonth.First()
End If
Dim currmonthname As String = MonthName(currentmonth, True)
End If
but I am getting a VS2012 squiggly under nextmonth in the If Then Else warning of "Possible multiple enumeration of IEnumerable"
I think this is what you want:
Dim intVar = 2
Dim months = { 1,4,7,10,12 }
Dim higherMonths = months.Where(Function(month) month > intVar).ToArray()
If higherMonths.Any() Then
intVar = higherMonths.First()
End If
If you don't want the next available month in the array but the nearest you have to sort before:
Dim higherMonths = months.Where(Function(m) m> intVar).
OrderBy(Function(m) m).
ToArray()
If higherMonths.Any() Then
intVar = higherMonths.First()
End If
Something like
Module Module1
Sub Main()
' N.B. this needs to the array to be sorted.
Dim a() As Integer = {1, 4, 7, 10, 12}
Dim toFind As Integer = 2
Dim foundAt As Integer = -1
For i = 0 To a.Length() - 1
If a(i) >= toFind Then
foundAt = i
Exit For
End If
Next
If foundAt >= 0 Then
Console.WriteLine(String.Format("Looked for {0}, found {1}.", toFind, a(foundAt)))
Else
Console.WriteLine(String.Format("Did not find {0} or higher.", toFind))
End If
Console.ReadLine()
End Sub
End Module
Or you might want to look at using the Array.BinarySearch Method.
I am using VBA to scan MAPIFolders for Items created before a certain date in order to move them to an archive PST. Normally Item.CreationDate is a good hook to scan for "old" Outlook items, but for calendar entries the "creation date" can be way before the "start date" so for calendar entries I rather want to use the latter.
My problem is with type MeetingItem which can be
an appointment where .GetAssociatedAppointment(False) seems to work fine
an acceptance msg to a received Appointment where .GetAssociatedAppointment(False) crashes
Any idea how to distinguish between the above cases to use the correct underlying object type in the Set statement?
Note: trying to inspect E in the debugger after it's been Set always results in "Outlook has encountered a problem and needs to close ..."
Private Function TimeOf(I As Object) As Date
Dim A As AppointmentItem
Dim M As MailItem
Dim E As MeetingItem
Dim T As TaskItem
Dim C As TaskRequestAcceptItem
Dim D As TaskRequestDeclineItem
Dim Q As TaskRequestItem
Dim U As TaskRequestUpdateItem
Select Case TypeName(I)
Case "AppointmentItem"
Set A = I
TimeOf = A.Start
Set A = Nothing
Case "MailItem"
Set M = I
TimeOf = M.ReceivedTime
Set M = Nothing
Case "MeetingItem"
Set E = I
Set A = E.GetAssociatedAppointment(False) ' doesn't work if item is a
' response to an Appointment received
TimeOf = A.Start ' <-- ERROR: Object variable ... not set
Set E = Nothing
Set A = Nothing
Case "TaskItem"
Set T = I
TimeOf = T.Start
Set T = Nothing
Case "TaskRequestAcceptItem"
Set C = I
TimeOf = C.Start
Set C = Nothing
Case "TaskRequestDeclineItem"
Set D = I
TimeOf = D.Start
Set D = Nothing
Case "TaskRequestItem"
Set Q = I
TimeOf = Q.Start
Set Q = Nothing
Case "TaskRequestUpdateItem"
Set U = I
TimeOf = U.Start
Set U = Nothing
Case Else
TimeOf = I.CreationTime
End Select
End Function
A request-type MeetingItem has a MessageClass of "IPM.Schedule.Meeting.Request". An acceptance-type of MeetingItem has a MessageClass of "IPM.Schedule.Meeting.Resp.Pos". Please refer here for more details on other MessageClass on Outlook 2003. I tested the following code in my Outlook 2007. It's working fine.
Private Function TimeOf(I As Object) As Date
Dim A As AppointmentItem
Dim M As MailItem
Dim E As MeetingItem
Dim T As TaskItem
Dim C As TaskRequestAcceptItem
Dim D As TaskRequestDeclineItem
Dim Q As TaskRequestItem
Dim U As TaskRequestUpdateItem
Select Case TypeName(I)
Case "AppointmentItem"
Set A = I
TimeOf = A.Start
Set A = Nothing
Case "MailItem"
Set M = I
TimeOf = M.ReceivedTime
Set M = Nothing
Case "MeetingItem"
Set E = I
If (E.MessageClass = "IPM.Schedule.Meeting.Request") Then
' Meeting Request
Set A = E.GetAssociatedAppointment(False)
TimeOf = A.Start
Set A = Nothing
Else
' Other MeetingItem
TimeOf = E.ReceivedTime
End If
Set E = Nothing
Case "TaskItem"
Set T = I
TimeOf = T.Start
Set T = Nothing
Case "TaskRequestAcceptItem"
Set C = I
TimeOf = C.Start
Set C = Nothing
Case "TaskRequestDeclineItem"
Set D = I
TimeOf = D.Start
Set D = Nothing
Case "TaskRequestItem"
Set Q = I
TimeOf = Q.Start
Set Q = Nothing
Case "TaskRequestUpdateItem"
Set U = I
TimeOf = U.Start
Set U = Nothing
Case Else
TimeOf = I.CreationTime
End Select
End Function