An MSForms Treeview

If you have ever used the Treeview control from the “Additional controls” section, then you know what a versatile control this is to show hierarchically organized data.

There are a couple of problems with this Treeview control:

  1. Compile errors due to a difference in how the control libraries are registered in 32 bits Windows’ System32 and 64 bit Windows’ SysWOW32 folders. If you distribute a file that was saved in 64 bit Windows, containing one of the “Microsoft Windows Common Controls 6.0” (The Treeview control is one of them) and with the reference set to “mscomctl.ocx”, people using 32 bit Windows will almost certainly have problems. At best it could entail removing both the control and the reference and replacing both, but at worst the user’s Excel can crash when trying to load the file and run the app.
  2. The standard Treeview control, like all non built-in ActiveX controls, cannot be used in 64 bit versions of Office.

Especially the second point convinced me it is time to develop a custom-made Treeview “control”, that only uses the native Office forms controls. I started building this a couple of weeks ago and after some time I tricked Peter Thornton into helping me with it :-)

The screenshot below shows both our new Treeview (left) and the Windows one (right) side-by-side:

Not bad, right?

Both Treeviews allow for checkboxes:

And both allow icons (windows Treeview not shown here):

You can also edit a node:

And expand and collapse nodes and navigate the tree using your arrow keys.

We built the custom Treeview using just two class modules. Using it in your project will require nothing more than copying the two classes and adding a bit of plumbing to your userform: some code and an empty frame which will hold the Treeview and possibly a frame with pictures for the icons.

We’re currently doing some cleaning up (like removing obsolete debugging stuff, adding comments and the like), so the “control” is not quite ready to be released to the outside world. Keep an eye on this blog, once we’re done we’ll post here.

Well, what do you think, is this useful or what? What functionality would be critical for you? Let us know!

Regards,

Jan Karel Pieterse

Retrieving Lost Comments

I’ve restored a few posts in the last few months that were lost. I didn’t restore any of the comments. Honestly, I should have but I didn’t even think about it. But when I went to restore the In Cell Charting post, I noticed there were 85 comments. That seemed worth my while.

First I set a reference to Microsoft XML, v6.0 and Microsoft HTML Object Library. Here’s the main procedure.

Public Sub CreateCommentSQL()

Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument
Dim hOLComments As MSHTML.HTMLOListElement
Dim hLIComments As MSHTML.IHTMLElementCollection
Dim hLIComment As MSHTML.HTMLLIElement
Dim clsComments As CComments
Dim clsComment As CComment

'Go get the lost comments from the wayback machine
Set xHttp = New MSXML2.XMLHTTP
xHttp.Open "GET", "http://web.archive.org/web/20100418043617/http://www.dailydoseofexcel.com/archives/2006/02/05/in-cell-charting/"
xHttp.send

'Wait until the page loads
Do: DoEvents: Loop Until xHttp.readyState = 4

Set clsComments = New CComments

'Load the document
Set hDoc = New MSHTML.HTMLDocument
hDoc.body.innerHTML = xHttp.responseText

'The ordered list has an id of "comments"
Set hOLComments = hDoc.getElementsByName("comments")(0)
'Get all the listindex elements
Set hLIComments = hOLComments.getElementsByTagName("li")

For Each hLIComment In hLIComments
Set clsComment = New CComment
With clsComment
.AddNameFromCite hLIComment.getElementsByTagName("cite")(0)
.AddDate hLIComment.getElementsByClassName("comment-meta commentmetadata")(0)
.AddContent hLIComment.getElementsByTagName("p")
End With
clsComments.Add clsComment
Next hLIComment

clsComments.CreateSQLFile

End Sub

I looked at the source for the web page to figure out how it was laid out and how to get at the data I needed. The CComment and CComments classes store the data as I loop through the list index items in the comment list. The first CComment method is AddNameFromCite. I didn’t even know there was a Cite tag in HTML (but you could fill a warehouse with what I don’t know about HTML).

Public Sub AddNameFromCite(ByVal hCite As MSHTML.HTMLPhraseElement)

Dim hAnchor As MSHTML.HTMLAnchorElement

Me.Author = hCite.innerText

Set hAnchor = hCite.getElementsByTagName("a")(0)

If Not hAnchor Is Nothing Then
Me.AuthorLink = Mid$(hAnchor.href, InStr(2, hAnchor.href, "http://"), Len(hAnchor.href))
End If

End Sub

I made this a method because I generally reserve properties to getting/setting values. If I change more than one property or do any extensive manipulation, I go with a method instead of a property. I’m not uber-consistent about it though. The comment author’s name is the innertext of the PhraseElement (that’s what a Cite is, at least according to the TypeName function). To get the AuthorLink, I need to find the anchor and get the href attribute. Because the wayback machine put its own URL in from of other URLs, I had to find the second instance of “http://” to get the real link. Next the AddDate method.

Public Sub AddDate(ByVal hDiv As MSHTML.HTMLDivElement)

Dim sDate As String
Dim vaDate As Variant

sDate = hDiv.innerText
vaDate = Split(sDate, " at ")

Me.CommentDate = DateValue(vaDate(0)) + TimeValue(vaDate(1))

End Sub

This really should have been a property instead of a method, but oh well. The innertext of the DivElement is something like “January 1, 2010 at 6:16 am”. I split that string on the “at” and used DateValue and TimeValue to build a date. Finally the content of the comment.

Public Sub AddContent(ByVal hParas As MSHTML.IHTMLElementCollection)

Dim hPara As MSHTML.HTMLParaElement
Dim sContent As String

For Each hPara In hParas
sContent = sContent & hPara.innerText
Next hPara

Me.Content = sContent

End Sub

I passed in a collection of elements that are ParaElements (tag=p=paragraph). Then I looped through them and concatenated a string for the content. By looping through just the p elements, I skip all the comment meta crap that is auto-generated by WordPress and just get to the text.

At this point I have 85 CComment objects and I’m ready to build the SQL string.

Public Sub CreateSQLFile()

Dim sFile As String, lFile As Long
Dim clsComment As CComment
Dim sSql As String
Dim aSql() As String
Dim lCnt As Long

ReDim aSql(1 To Me.Count)

'Build the first part of the sql string with the column names
sSql = "INSERT INTO wp_comments (comment_post_ID, comment_author, comment_author_email, comment_author_url,"
sSql = sSql & Space(1) & "comment_author_IP, comment_date, comment_date_gmt, comment_content, comment_karma,"
sSql = sSql & Space(1) & "comment_approved, comment_agent, comment_type, comment_parent, user_id) VALUES" & vbNewLine

'Put all the comment values in an array
For Each clsComment In Me
lCnt = lCnt + 1
aSql(lCnt) = clsComment.SQLInsert
Next clsComment

'put it all together
sSql = sSql & Join(aSql, ", " & vbNewLine) & ";"

'write it to a sql file
sFile = ThisWorkbook.Path & Application.PathSeparator & "wp_incellcomments.sql"
lFile = FreeFile

Open sFile For Output As lFile
Print #lFile, sSql

Close lFile

End Sub

Just a bunch string building and putting in a file that I can import into PHPMyAdmin. In the CComment class, the values are put together like this

Public Property Get SQLInsert() As String

Dim sReturn As String
Dim aReturn(1 To 14) As Variant

Const sNOVALUE As String = "''"
Const sSQ As String = "'"

aReturn(1) = "7534"
aReturn(2) = sSQ & EscSq(Me.Author) & sSQ
aReturn(3) = sNOVALUE
aReturn(4) = sSQ & EscSq(Me.AuthorLink) & sSQ
aReturn(5) = sNOVALUE
aReturn(6) = sSQ & Format(Me.CommentDate, "yyyy-mm-dd hh:mm:ss") & sSQ
aReturn(7) = aReturn(6)
aReturn(8) = sSQ & EscSq(Me.ContentScrubbed) & sSQ
aReturn(9) = 0
aReturn(10) = sSQ & "1" & sSQ
aReturn(11) = sNOVALUE
aReturn(12) = sNOVALUE
aReturn(13) = 0
aReturn(14) = 0

sReturn = "(" & Join(aReturn, ", ") & ")"

SQLInsert = sReturn

End Property

I really like this method of building a string – putting it into an array and using Join – so I think I’ll start using it. The EscSq function turns any single quotes into two single quotes. The ContentScrubbed property converts any vbNewLines into \r\n. I exported some existing comments from MySQL to see how all this stuff went together. In the end, I ended up with a file that looks like this.

phpMyAdmin kept erroring out that the file was using too much memory. It’s 51kb, so I knew that wasn’t true. But the helpful people at HostGator imported it for me and set me up with console access so I can do it myself next time. I just need to learn the commandline stuff for importing.

I took a quick look through through the comments and they look alright. It’s hard to tell what I screwed up formatting-wise because some people use code tags and most don’t. But the info appears to be there and that’s the most important thing. I guess since I have this set up, I should go back and make sure any other lost posts get their comments too.

As always, if you see something that’s not right on the site, shoot me an email. I have a few hundred posts that still look like crap, but are readable and I’m fixing them as I see them.

Cloning Class Instances

I’m working on a project that requires me to make multiple copies of a custom object. That generally means I make a Duplicate method and assign each property of the source instance to the copy instance. It’s not terrible, but I just have to be careful that when I change the properties of the class that I update the Duplicate method. I decided that I would see what other options are available and I found this StackOverflow answer that I think is interesting. So I tried it.

Instead of declaring a bunch of private variables in the class and all the getters and setters for those variables, all of the property values will be in a user-defined type. The UDT variable will be private to the class, but the actual UDT has to be in a standard module because VBA won’t let you put types in a class module. Now when I want to clone that class instance, I can pass the whole UDT variable. Unlike a class that passes the reference, the UDT makes a copy of all of the values in memory so you end up with two separate structures in memory – just what I want for a clone.

I made a CContact class that will have a FirstName, LastName, and LastContact property. The poorly named LastContact property is the date last contacted. I wanted to put at least two different data types (String and Date) in the class for demonstration purposes. The declaration of CContact looks like this:

Private mlContactID As Long
Private mtContactMemento As ContactMemento

I only have two private variables; ContactID that never want to copy and a ContactMomento variable that contains all the data that I do want to copy. I keep the ContactID getter and setter the same as I normally would, but the mtContactMomento property statements are a little different. First, let’s look at the ContactMomento type. This is in my MGlobals standard module.

Public Type ContactMemento
FirstName As String
LastName As String
LastContact As Date
End Type

I named the type ObjectName + Memento. Memento is from the Memento pattern, which is typically used to store a previous state for Undo purposes, although we’re not really using it like that here. The UDT holds all of the properties that I want to copy to a new class instance. Back in the class, the typical getters and setters look like this:

Public Property Let FirstName(ByVal sFirstName As String)

mtContactMemento.FirstName = sFirstName

End Property

Public Property Get FirstName() As String

FirstName = mtContactMemento.FirstName

End Property

That’s pretty much the same as typical property statements except I’m pulling the data from my private ContactMemento variable instead of individual variables for each project. With that all set up, this works just like a class that I would create normally – not using a UDT. The last bit of setup that I need is property statements for the ContactMemento as a whole.

Public Property Let ContactMemento(tContactMemento As ContactMemento)

mtContactMemento = tContactMemento

End Property

Public Property Get ContactMemento() As ContactMemento

ContactMemento = mtContactMemento

End Property

And then I need a way to clone the class, so I create a Clone property.

Public Property Get Clone() As CContact

Dim clsReturn As CContact

Set clsReturn = New CContact
clsReturn.ContactMemento = Me.ContactMemento

Set Clone = clsReturn

End Property

By assigning the ContactMemento from the source instance to the class instance, all the properties I want to copy are done so in one shot rather than one at a time. If I add any properties to the class, I don’t have to adjust the Clone property, which means that I won’t forget and miss a property. Let’s test it out. If create one instance, then clone it and change the LastContact property just for some variety.

Sub FillClass()

Dim clsContact As CContact

Set gclsContacts = New CContacts

Set clsContact = New CContact
With clsContact
.FirstName = "Dick"
.LastName = "Kusleika"
.LastContact = Date
End With
gclsContacts.Add clsContact

End Sub

Sub CloneClass()

Dim clsClone As CContact
Dim clsSource As CContact
Dim clsContact As CContact

FillClass

Set clsSource = gclsContacts.Contact(1)
Set clsClone = clsSource.Clone
clsClone.LastContact = Date + 1
gclsContacts.Add clsClone

For Each clsContact In gclsContacts
With clsContact
Debug.Print .ContactID, .FirstName, .LastName, .LastContact
End With
Next clsContact

End Sub

That outputs:

I like a system that doesn’t rely on me being careful to update a Clone or Duplicate method. But there are some things I don’t like too. With this method, my class is not longer self-contained. The UDT declaration has to live in a standard module. If I copy my class module to another project, it won’t compile until I declare the UDT in the new project. I would also have to change all of my code generation stuff to use a UDT rather than individual private variables. In all the code I’ve written, I’ve probably only had to clone class instances about a half dozen times, so it’s probably not worth it.

You can download CloneClass.zip

Lunch Pairing Performance

A little history:
Lunch Pairing Objects
Populating Lunch Pairings
Lunch Pairing Constraints

To round out the Lunch Pairings series, I want to write about some of the design decisions and performance measurements.

Design

I’m not totally happy with the end result. This always happens when I have combinations and constraints. Combinations are fine. Constraints are fine. But combinations that must be constrained always make me loop more than I like. It just seems like there should be a better way. Maybe someday I’ll be smart enough to figure it out.

I started with a collection of contacts and I removed a contact from the collection when I added it to a lunch. I like this method of avoiding duplicates – make a list and remove the selected item from the list. The problem with this method is that it only serves one of my constraints – no lunch per contact per month. It doesn’t consider duplicates over two or ten months.

Another method I like to use when working with combinations is to make a list of every possible combination and choose randomly from the list. This works great with non-combination lists. There’s a lot of overhead with creating every possible combination and, when I had finished coding it, I realized that it’s a stupid idea. Rather than create every combination then test it, I could test it as I create it, which is what I ended up doing.

I’m still not supremely confident that the current method will procedure good results, particularly as the history of lunches grows. Time will tell, I guess.

Performance

My first iteration with the final design took 282 seconds to run. I never optimize code for speed until the end. Make it work, make it pretty, make it fast. In that order. Well, it was time to optimize and 282 seconds was not an acceptable run time.

Well it’s pretty obvious where to start. My AttendeeList property returned a delimited string of sorted contact names. Calling that 3.5 million times was costly, to say the least. Once a lunch was create, its contacts did not change. There was no need for me to keep calculating that property every time. I made the property a write-once, read-many property.

Public Property Get AttendeeList() As String

Dim aList() As String
Dim i As Long, j As Long
Dim sTemp As String
Dim sReturn As String
Dim lCnt As Long

If Len(msAttendeeList) = 0 Then
ReDim aList(1 To Me.Attendees.Count)
For i = 1 To Me.Attendees.Count
lCnt = lCnt + 1
aList(lCnt) = Me.Attendees.Contact(i).FullName
Next i

For i = LBound(aList) To UBound(aList) - 1
For j = i To UBound(aList)
If aList(i) > aList(j) Then
sTemp = aList(i)
aList(i) = aList(j)
aList(j) = sTemp
End If
Next j
Next i

For i = LBound(aList) To UBound(aList)
sReturn = sReturn & aList(i) & "|"
Next i

sReturn = Left$(sReturn, Len(sReturn) - 1)
msAttendeeList = sReturn
End If

AttendeeList = msAttendeeList

End Property

The first thing the property does is check for the existence of msAttendeeList, the module level variable. If it’s there, it simply returns it. If it’s not there, then it hasn’t been calculated yet. The string is created and stored so future calls don’t have to calculate. This got my run time down to 60 seconds.

The next lowest hanging fruit was checking to see if there are any matches. Here’s what that property looks like now – I cleaned it up for the previous posts.

Public Property Get AttendeeMatch(clsLunch As CLunch, lMatchMax As Long) As Boolean

Dim vaMe As Variant
Dim vaLunch As Variant
Dim i As Long, j As Long
Dim lCnt As Long
Dim clsMeAtt As CContact
Dim clsLunchAtt As CContact

' For Each clsMeAtt In Me.Attendees
' For Each clsLunchAtt In clsLunch.Attendees
' If clsMeAtt.ContactID = clsLunchAtt.ContactID Then
' lCnt = lCnt + 1
' If lCnt >= lMatchMax Then Exit For
' End If
' Next clsLunchAtt
' If lCnt >= lMatchMax Then Exit For
' Next clsMeAtt

vaMe = Split(Me.AttendeeList, "|")
vaLunch = Split(clsLunch.AttendeeList, "|")

For i = LBound(vaMe) To UBound(vaMe)
For j = LBound(vaLunch) To UBound(vaLunch)
If vaMe(i) = vaLunch(j) Then
lCnt = lCnt + 1
End If
Next j
Next i

' For i = LBound(vaMe) To UBound(vaMe)
' If InStr(1, clsLunch.AttendeeList, vaMe(i)) > 0 Then
' lCnt = lCnt + 1
' End If
' Next i

AttendeeMatch = lCnt >= lMatchMax

End Property

I used the Split function on both lunch’s attendee lists and roll through the array looking for matches. First, I tried to use Instr instead of split (that’s the lower commented out area).

Nope, that’s worse. Next I try going to a For Each loop (the upper commented area).

Oh, that’s way worse. Back to my original Split way and my 60 second run time. Then I figured it out. Sometimes, often times, I get so hung up on the Total column that ignore the Count column. Once I worked on lowering the count, everything got a lot faster. How to lower the count of the match calls? Find matches sooner rather than later. Instead of For Each looping through the lunches, I looped through in reverse. I was far more likely to have a match on a lunch from the current month because the constraints are tighter. So by checking the most current lunches first, I reduce the overall number of calls. Here’s the IsRepeat property that loops through the lunches backward.

Public Property Get IsRepeat() As Boolean

Dim clsLunch As CLunch
Dim bReturn As Boolean
Dim i As Long

For i = gclsLunches.Count To 1 Step -1
Set clsLunch = gclsLunches.Lunch(i)

If clsLunch.LunchDate = Me.LunchDate Then
If clsLunch.AttendeeMatch(Me, 1) Then
bReturn = True
Exit For
End If
End If

If clsLunch.IsWithin(Me.LunchDate, 2) Then
If clsLunch.AttendeeMatch(Me, 2) Then
bReturn = True
Exit For
End If
End If

If clsLunch.IsWithin(Me.LunchDate, 10) Then
If clsLunch.AttendeeMatch(Me, 3) Then
bReturn = True
Exit For
End If
End If
Next i

IsRepeat = bReturn

End Property

That got me down to a manageable 13 seconds. That I can live with.

I need to get the code to PerfMon because there are two things I don’t like about it. First, it doesn’t respect my indented Exit Sub lines. Second, I would rather if it kept a history of output (append rather than output to a text file) and allowed me to comment on them. I’ve done that here by copying the results to the right and writing a comment before re-importing the sheet.

You can download LunchPairings.zip, which contains the workbook with the code and the workbook with the PerfMon results.

Checking Lunches Against Conditions

Lunch Pairings Classes
Populating Lunch Pairings

My method for creating proposed lunches is to add three random contacts to make a lunch, then see if that lunch meets the conditions. If it does, I add it to the lunches collection class. If not, I try another combination. The portion of the FillMonth method that does this looks like:

If Not clsLunch.IsRepeat Then
Me.Add clsLunch
bAdded = True
lCnt = lCnt + 1
End If

I’ve put all my previously mentioned conditions into one property called IsRepeat.

Public Property Get IsRepeat() As Boolean

Dim clsLunch As CLunch
Dim bReturn As Boolean
Dim i As Long

For i = gclsLunches.Count To 1 Step -1
Set clsLunch = gclsLunches.Lunch(i)

If clsLunch.LunchDate = Me.LunchDate Then
If clsLunch.AttendeeMatch(Me, 1) Then
bReturn = True
Exit For
End If
End If

If clsLunch.IsWithin(Me.LunchDate, 2) Then
If clsLunch.AttendeeMatch(Me, 2) Then
bReturn = True
Exit For
End If
End If

If clsLunch.IsWithin(Me.LunchDate, 10) Then
If clsLunch.AttendeeMatch(Me, 3) Then
bReturn = True
Exit For
End If
End If
Next i

IsRepeat = bReturn

End Property

I loop through all the existing lunches, from both past months and those from the month I’m working on. In the first test, I check to see if the lunch is in the same month as the proposed lunch. Then I check if any of the attendees match via the AttendeeMatch property.

Public Property Get AttendeeMatch(clsLunch As CLunch, lMatchMax As Long) As Boolean

Dim vaMe As Variant
Dim vaLunch As Variant
Dim i As Long, j As Long
Dim lCnt As Long
Dim clsMeAtt As CContact
Dim clsLunchAtt As CContact

vaMe = Split(Me.AttendeeList, "|")
vaLunch = Split(clsLunch.AttendeeList, "|")

For i = LBound(vaMe) To UBound(vaMe)
For j = LBound(vaLunch) To UBound(vaLunch)
If vaMe(i) = vaLunch(j) Then
lCnt = lCnt + 1
End If
Next j
Next i

AttendeeMatch = lCnt >= lMatchMax

End Property

This property is bit weird. There are some unused variables in there, for one. In a later post, I’ll talk about the performance problems I had and how I tried to reduce execution time. The AttendeeList property returns a string of contact names, pipe delimited, and sorted by first names. Now that I look at it, I don’t think those names need to be sorted, but I use that property later where they do, so it’s there.

I’m checking my condition that a contact only have one lunch per month. I passed in a “1” to lMatchMax so that if there was even one match, the lunch gets booted.

For my next condition, I test to make sure that no two contacts are in a lunch in the last two months. That starts by testing whether the lunch is within the last two months via the IsWithin property. Terrible name, I know.

Public Property Get IsWithin(dtLunch As Date, lMonths As Long) As Boolean

IsWithin = dtLunch > DateSerial(Year(Me.LunchDate), Month(Me.LunchDate) - lMonths, 0)

End Property

If it passes this test, I call AttendeeMatch again, but this time with a lMatchMax of 2.

The final condition is that no three contacts are in the same group in the last ten months. It’s the same as the previous condition except that IsWithin gets passed a 10 and AttendeeMatch gets passed a 3.

Finally, I write the lunches by month to a range. Back in the main calling procedure,

For lMonth = lFIRST To lLAST
vaWrite = gclsLunches.LunchesByMonth(lMonth).RangeOutput
wshLunch.Cells(wshLunch.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
Next lMonth

The RangeOutput property returns a two-dimensional array

Public Property Get RangeOutput() As Variant

Dim aReturn() As String
Dim clsLunch As CLunch
Dim lCnt As Long
Dim i As Long
Dim lAttCnt As Long

ReDim aReturn(1 To Me.Count, 1 To 5)

For Each clsLunch In Me
lCnt = lCnt + 1
lAttCnt = 0
aReturn(lCnt, 1) = clsLunch.LunchMonth
aReturn(lCnt, 2) = clsLunch.Attendees.Contact(clsLunch.Facilitator).FullName
aReturn(lCnt, 5) = clsLunch.AttendeeList
For i = 1 To clsLunch.Attendees.Count
If i <> clsLunch.Facilitator Then
lAttCnt = lAttCnt + 1
aReturn(lCnt, 2 + lAttCnt) = clsLunch.Attendees(i).FullName
End If
Next i
Next clsLunch

RangeOutput = aReturn

End Property

The Facilitator is listed first, then the other two attendees. I also spit out the sorted AttendeeList so I can do a countif and make sure I didn’t screw anything up. And I screwed up plenty.

Next up, I’ll discuss some of the performance problems I had and how I solved them.

Populating Lunch Pairings

Yesterday I set up Contact objects and Lunch objects. Now I want to create new Lunch objects that meet the conditions that I defined. From my main LunchTrios procedure:

For lMonth = lFIRST To lLAST
gclsLunches.FillMonth lMonth
Next lMonth

Ah, the brevity that class modules provide is a beautiful thing. I need FillMonth to:

  1. Get a list of active contacts
  2. Create a lunch with three of those contacts
  3. See if that lunch meets my conditions
  4. Keep the lunch if it passes, try another combination if it doesn’t

Public Sub FillMonth(lMonth As Long)

Dim clsLunch As CLunch
Dim dtLunch As Date
Dim i As Long, j As Long, k As Long
Dim bAdded As Boolean
Dim lCnt As Long
Dim clsActive As CContacts

Set clsActive = gclsContacts.Active
dtLunch = DateSerial(Year(Date), lMonth + 1, 0)

For i = 1 To clsActive.Count
bAdded = False
For j = 1 To clsActive.Count
If i <> j Then
For k = 1 To clsActive.Count
If i <> k And j <> k Then
Set clsLunch = New CLunch
clsLunch.LunchDate = dtLunch
clsLunch.Attendees.Add clsActive(i)
clsLunch.Attendees.Add clsActive(j)
clsLunch.Attendees.Add clsActive(k)
clsLunch.Facilitator = CLng((Rnd * (clsLunch.Attendees.Count - 1)) + 1)

If Not clsLunch.IsRepeat Then
Me.Add clsLunch
bAdded = True
lCnt = lCnt + 1
End If
End If
If bAdded Then Exit For
Next k
End If
If bAdded Then Exit For
Next j
If lCnt >= clsActive.Count \ 3 Then Exit For
Next i

End Sub

My first step is to get a list of active participants. I create a new instance of CContacts and store it in the variable called clsActive. Then I create a Property of the CContacts class to return an instance only containing active contacts. My main list of contacts is sorted by first name. I also have 29 active contacts, so two people every month won’t have a lunch. If I keep my contacts sorted, people like Wyatt James are always going to be left out because of his first name. I will have filled up my lunches by the time I get down to him. I need to test lunches in a somewhat random order so that the two people who get left out aren’t the same every month. To do this, I sort clsActive randomly. But I don’t really like sorting right after I populate a class. I have to loop through the contacts to populate the class, then again to sort it. It just seems wasteful. So I do it all in one fell swoop.

Public Property Get Active() As CContacts

Dim clsReturn As CContacts
Dim clsContact As CContact
Dim lRand As Long

Set clsReturn = New CContacts

For Each clsContact In Me
If clsContact.Active Then

lRand = CLng((Rnd * clsReturn.Count) + 1)

If clsReturn.Count = 0 Or lRand > clsReturn.Count Then
clsReturn.Add clsContact
Else
clsReturn.Add clsContact, lRand
End If
End If
Next clsContact

Set Active = clsReturn

End Property

As I added qualified contacts to the collection class, I insert the new contact before a random existing contact. This has the effect of giving me a randomly sorted list of contacts in clsActive.

Now that I have my list of active contacts, I loop through them three times creating a proposed lunch. I check if that lunch meets my conditions with IsRepeat and if so, add it to my Lunches collection class. I have a lot of code in there to skip out of the For loop when it’s found a match because looping takes forever. I also skip out when I have enough lunches for the month.

Next up, I’ll go through the IsRepeat property that checks to see if a lunch meets the conditions.

Lunch Pairings

I have a list of 32 people, 29 of whom are “Active”. Every quarter, I need to generate a lunch schedule with certain conditions. A partial list of people looks like this:

The conditions are:

  • Three people to a lunch
  • The facilitator is chosen at random
  • Each person has one lunch per month at most
  • Two person combinations (different third person) can repeat after two months
  • Three person combinations can repeat after 10 months

It’s to the benefit of the attendees to not have lunch with the same person too often, so the conditions are set to minimize repeated pairings in certain time frames. If I have lunch with Joe this month, there’s no value in having lunch with him next month, even with a different third person, because not enough will have changed with regard to our lunch topic.

My first step is to identify the nouns in my scenario. The nouns are Contact and Lunch so I create a CContact class and a CLunch class and their respective collection classes CContacts and CLunches.

My main procedure is called LunchTrios and looks like this

Public Sub LunchTrios()

Dim lMonth As Long
Dim vaWrite As Variant

Const lFIRST As Long = 7
Const lLAST As Long = 9

FillClasses
Set gclsLunches = New CLunches
If Not IsEmpty(wshLunch.Range("A4").Value) Then
gclsLunches.FillFromRange wshLunch.Range("A4", wshLunch.Cells(wshLunch.Rows.Count, 1).End(xlUp)).Cells
End If

For lMonth = lFIRST To lLAST
gclsLunches.FillMonth lMonth
Next lMonth

For lMonth = lFIRST To lLAST
vaWrite = gclsLunches.LunchesByMonth(lMonth).RangeOutput
wshLunch.Cells(wshLunch.Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(vaWrite, 1), UBound(vaWrite, 2)).Value = vaWrite
Next lMonth

End Sub

The FillClasses procedure reads the contact information from a range and creates a bunch of CContact objects. If wshLunch.Range(“A4”) isn’t empty, that means there are existing lunches and I need to read those in. Existing lunches look like this:

The code to populate existing lunches lives in the CLunches collection class.

Public Sub FillFromRange(rRng As Range)

Dim rCell As Range
Dim clsLunch As CLunch
Dim clsContact As CContact

For Each rCell In rRng.Columns(1).Cells
Set clsLunch = New CLunch
With clsLunch
.LunchDate = rCell.Offset(0, 0).Value
Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 1).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
.Facilitator = 1
Set clsContact = Nothing
End If

Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 2).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
Set clsContact = Nothing
End If

Set clsContact = gclsContacts.ContactByFullName(rCell.Offset(0, 3).Value)
If Not clsContact Is Nothing Then
.Attendees.Add clsContact
Set clsContact = Nothing
End If

End With
Me.Add clsLunch
Next rCell

End Sub

As people come and go from the group, sometimes an attendee from a past lunch won’t exist in the contact list anymore. I check to make sure that they exist before I add them to the Attendees property. I also set the Facilitator property to 1 as the facilitator is the first attendee listed. For this code to work, I’m going to need an Attendee property and a Facilitator property in my CLunch class.

'The class level variables
Private mlLunchID As Long
Private mdtLunchDate As Date
Private mclsAttendees As CContacts
Private mlFacilitator As Long

'the getters and setters
Public Property Let Facilitator(ByVal lFacilitator As Long): mlFacilitator = lFacilitator: End Property
Public Property Get Facilitator() As Long: Facilitator = mlFacilitator: End Property
Public Property Let LunchID(ByVal lLunchID As Long): mlLunchID = lLunchID: End Property
Public Property Get LunchID() As Long: LunchID = mlLunchID: End Property
Public Property Let LunchDate(ByVal dtLunchDate As Date): mdtLunchDate = dtLunchDate: End Property
Public Property Get LunchDate() As Date: LunchDate = mdtLunchDate: End Property

'set up and tear down of the Attendees property
Private Sub Class_Initialize()
Set mclsAttendees = New CContacts
End Sub

Private Sub Class_Terminate()
Set mclsAttendees = Nothing
End Sub

Public Property Get Attendees() As CContacts
Set Attendees = mclsAttendees
End Property

I have a CContacts class that holds a bunch of CContact instances. One instance of CContacts is held in a global variable called gclsContacts and that one holds all of the contacts on the wshContacts sheet. Each of my CLunch instances also has a CContacts instance to hold the three attendees. I don’t need a separate Attendees class because it would look just like CContacts. The CContacts class module is a template that defines the characteristics of a Contacts object. The instances that are created from that template are separate animals. They are defined by the same properties, but the values of those properties are different for each instance. For example, every cow has a height and a gender, but not every cow has the same height and gender. Height and gender define a cow (a little simplistically), but each instance of a cow is defined by three things: that it was created from a cow template, its specific height, and its specific gender.

The instance of CContacts that I store in gclsContacts has a Count property just like the instance of CContacts that I store in gclsLunches.Lunch(1).Attendees. But the first instance has a Count value of 32 and the second instance has a Count value of 3.

So far I have gclsContacts that’s holding all my Contact objects and gclsLunches that’s holding all my existing Lunch objects. Each Lunch instance also has up to three Contact objects related to it via its Attendees property. Tomorrow, I’ll loop through the months I want to populate new Lunch objects that meet my conditions. No more farm animal analogies, I promise.

In an userform list all available fonts

The motivation for this tip was to share how to

1) dynamically add controls to a userform
2) respond to events for these controls, and
3) specifically respond to events using a callback procedure that is located in another class module!

Since this may come across as a fairly technical topic, this tip utilizes the above capabilities to provide a functional solution:

1) list in an userform the names of all available fonts with each name shown using that font,
2) hover over the option button associated with a font to see a sample of every English keyboard character in that font,
3) click on the option button to select the font, and, finally,
4) use this capability to programmatically get the user’s selection, if any.

Below is an example of the font selector in action. Each OptionButton shows the name of one available font using the font itself. At the same time, the control tool tip shows the font name in English (see the Wide Latin tip). A sample of how every keyboard character will look in that font appears below the font selector frame.

The motivation for this example was a Daily Dose of Excel blog post by Michael (http://www.dailydoseofexcel.com/archives/2012/03/14/getting-a-font-list-to-a-combo-box-2/). He used a combo box to list the fonts available to Excel leveraging a technique shown in a tip by John Walkenbach (http://www.j-walk.com/ss/excel/tips/tip79.htm).

For a version in a page by itself (i.e., not in a scrollable iframe as below) visit http://www.tushar-mehta.com/publish_train/xl_vba_cases/1054%20show%20fonts%20in%20userform.shtml

Tushar Mehta