Return to Question

I thought this question made a good excuse for some basic OOP code, so I whipped up a little bit of code to demonstrate it in VBA; the idea is to have tutorial-grade code, to show how interfaces and default instances can be used to implement immutable types and factory methods to simulate constructors in VBA.

I thought this question made a good excuse for some basic OOP code, so I whipped up a little bit of code to demonstrate it in VBA; the idea is to have tutorial-grade code, to show how interfaces and default instances can be used to implement immutable types and factory methods to simulate constructors in VBA.

Option Explicit
Private Type TRule
 RuleInfo As IPricingRuleInfo
 Amount As Currency
End Type
Private this As TRule
Implements IPricingRule
Private Property Get IPricingRule_RuleInfo() As IPricingRuleInfo
 Set IPricingRule_RuleInfo = this.RuleInfo
End Property
Private Function IPricingRule_Evaluate(ByVal info As IPricingRuleInfo) As Currency
 IPricingRule_Evaluate = this.Amount
End Function
Public Property Get RuleInfo() As IPricingRuleInfo
 Set RuleInfo = this.RuleInfo
End Property
Public Property Set RuleInfo(ByVal value As IPricingRuleInfo)
 Set this.RuleInfo = value
End Property
Public Property Get Amount() As Currency
 Amount = this.Amount
End Property
Public Property Let Amount(ByVal value As Currency)
 this.Amount = value
End Property
Public Property Get Self() As IPricingRule
 Set Self = Me
End Property
Public Function Create(ByVal info As IPricingRuleInfo, ByVal value As Currency) As IPricingRule
 With New FixedAmountPricingRule
 Set .RuleInfo = info
 .Amount = value
 Set Create = .Self
 End With
End Function

Option Explicit
Private Type TRule
 RuleInfo As IPricingRuleInfo
 Amount As Currency
End Type
Private this As TRule
Implements IPricingRule
Private Property Get IPricingRule_RuleInfo() As IPricingRuleInfo
 Set IPricingRule_RuleInfo = this.RuleInfo
End Property
Private Function IPricingRule_Evaluate(Optional ByVal info As IPricingRuleInfo = Nothing) As Currency
 IPricingRule_Evaluate = this.Amount
End Function
Public Property Get RuleInfo() As IPricingRuleInfo
 Set RuleInfo = this.RuleInfo
End Property
Public Property Set RuleInfo(ByVal value As IPricingRuleInfo)
 Set this.RuleInfo = value
End Property
Public Property Get Amount() As Currency
 Amount = this.Amount
End Property
Public Property Let Amount(ByVal value As Currency)
 this.Amount = value
End Property
Public Property Get Self() As IPricingRule
 Set Self = Me
End Property
Public Function Create(ByVal info As IPricingRuleInfo, ByVal value As Currency) As IPricingRule
 With New FixedAmountPricingRule
 Set .RuleInfo = info
 .Amount = value
 Set Create = .Self
 End With
End Function

I thought this question made a good excuse for some basic OOP code, so I whipped up a little bit of code to demonstrate it in VBA, however I'm not happy with how it turned out. How should I refactor it to be more flexible, OOP-style? The idea is to end up with tutorial-grade code.. and despite the fact that it works, I'm pretty sure this isn't it.

Option Explicit
Public Function FindCheapestHotel(ByVal fromDate As Date, ByVal toDate As Date, ByVal custType As CustomerType) As String
 
 Dim hotels As Collection
 Set hotels = InitializeHotels
  
 Dim prices As Dictionary
 Set prices = New Dictionary
 
 Dim place As Hotel
 Dim checkedDate As Date

 For Each place In hotels
 prices.Add place.Name, place.GetPrice(fromDate, toDate, custType)
 Debug.Print place.Name, Format(prices(place.Name), "$#,##0.00") Next
 Dim cheapestAmount As Currency
 cheapestAmount = prices.Items(1)
  
 Dim cheapestKey As String
  cheapestKey = prices.Keys(1)
  
 Dim key As Variant
  For Each key In prices.Keys
 If prices(key) < cheapestAmount Then
 cheapestKey = key
 cheapestAmount = prices(key)
  ElseIf prices(key) = cheapestAmount Then
 If hotels.item(key).Rating > hotels(cheapestKey).Rating Then
 cheapestKey = key
 End If
 End If
 Next
 FindCheapestHotel = cheapestKey
 End Function
Private Function InitializeHotels() As Collection
 Static hotels As Collection
 If hotels Is Nothing Then
 Set hotels = New Collection
  With hotels
 .Add HotelFactory.Create("Green Valley", 3, 900, 1100, 800, 800), "Green Valley"
 .Add HotelFactory.Create("Red River", 4, 600, 1600, 500, 1100), "Red River"
 .Add HotelFactory.Create("Blue Hills", 5, 1500, 2200, 400, 1000), "Blue Hills"
 End With
 End If
 Set InitializeHotels = hotels
End Function

?FindCheapestHotel(Now, Now+7, Regular)
Green Valley 8ドル,400.00
Red River 10ドル,800.00
Blue Hills 16ドル,200.00
Green Valley

I started by defining an IPricingStrategy interface:

'@Interface
'@Folder("Abstract")
Option Explicit
Public Enum CustomerType
 Regular
 Premium
End Enum
Public Function CalculatePricing(ByVal checkin As Date, ByVal custType As CustomerType) As Currency
End Function

And then I implemented it in a generic way that I could use to generate data off of an input file if I had to; that way I could handle finding the cheapest stay among 3,500 hotels, for example. Here is the GenericPricingStrategy class:

'@Folder("Concrete")
Option Explicit
Public Enum PricingError
 Undefined = vbObjectError + 512
 InvalidCustomerTypeError
End Enum
Private Const InvalidCustomerTypeMessage As String = "Specified customer type is not supported."
Private Type TPricingData
 RegularWkDayPrice As Currency
 regularWkEndPrice As Currency
 premiumWkDayPrice As Currency
 premiumWkEndPrice As Currency
End Type
Private this As TPricingData
Implements IPricingStrategy
Public Property Get WeekdayPrice(ByVal custType As CustomerType) As Currency
 Select Case custType
  Case CustomerType.Premium
 WeekdayPrice = this.premiumWkDayPrice
 
 Case CustomerType.Regular
  WeekdayPrice = this.RegularWkDayPrice
 
 Case Else
 OnInvalidCustomerType "WeekdayPrice (Get)"
 
 End Select
End Property
Friend Property Let WeekdayPrice(ByVal custType As CustomerType, ByVal value As Currency)
 Select Case custType
  Case CustomerType.Premium
 this.premiumWkDayPrice = value
 
 Case CustomerType.Regular
  this.RegularWkDayPrice = value
 
 Case Else
 OnInvalidCustomerType "WeekdayPrice (Let)"
 
 End Select
End Property
Public Property Get WeekendPrice(ByVal custType As CustomerType) As Currency
 Select Case custType
  Case CustomerType.Premium
 WeekendPrice = this.premiumWkEndPrice
 
 Case CustomerType.Regular
 WeekendPrice = this.regularWkEndPrice
 
 Case Else
 OnInvalidCustomerType "WeekendPrice (Get)"
 
 End Select
End Property
Friend Property Let WeekendPrice(ByVal custType As CustomerType, ByVal value As Currency)
 Select Case custType
 Case CustomerType.Premium
 this.premiumWkEndPrice = value
 
 Case CustomerType.Regular
 this.regularWkEndPrice = value
 
 Case Else
 OnInvalidCustomerType "WeekendPrice (Let)"
  End Select
End Property
Private Function IPricingStrategy_CalculatePricing(ByVal checkin As Date, ByVal custType As CustomerType) As Currency
 
 Dim wkDay As Integer
 wkDay = Weekday(checkin, vbMonday)
 Dim isWeekendPricing As Boolean
 isWeekendPricing = (wkDay > 5)
 
 Dim result As Currency
  Select Case custType
 Case CustomerType.Regular
  result = IIf(isWeekendPricing, this.regularWkEndPrice, this.RegularWkDayPrice)
 
 Case CustomerType.Premium
 result = IIf(isWeekendPricing, this.premiumWkEndPrice, this.premiumWkDayPrice)
 
 Case Else
 OnInvalidCustomerType "CalculatePricing"
 End Select
 
 IPricingStrategy_CalculatePricing = result
  
End Function
Private Sub OnInvalidCustomerType(ByVal source As String)
 Err.Raise PricingError.InvalidCustomerTypeError, TypeName(Me) & "." & source, InvalidCustomerTypeMessage
End Sub

And this is where I believe I erred - the HotelFactory class:

'@Folder("Concrete")
Option Explicit
Public Function Create(ByVal hotelName As String, _
 ByVal hotelRating As Byte, _
 ByVal regWkEndPrice As Currency, _
  ByVal regWkDayPrice As Currency, _
 ByVal premiumWkEndPrice As Currency, _
 ByVal premiumWkDayPrice As Currency) As Hotel
  
 Dim strategy As GenericPricingStrategy
 Set strategy = New GenericPricingStrategy
 With strategy
 .WeekdayPrice(Regular) = regWkDayPrice
  .WeekendPrice(Regular) = regWkEndPrice
  .WeekdayPrice(Premium) = premiumWkDayPrice
 .WeekendPrice(Premium) = premiumWkEndPrice
 End With
 
 Dim result As New Hotel
  result.Name = hotelName
 result.Rating = hotelRating
 Set result.PricingStrategy = strategy
 Set Create = result
 
End Function

Here is the Hotel class, which I believe would have to be implementing IPricingStrategy itself:

'@Folder("Concrete")
Option Explicit
Private Type THotel
 Pricing As IPricingStrategy
 Name As String
 Rating As Byte
End Type
Private Enum HotelError
  Undefined = vbObjectError + 1024
 InvalidDateRange
End Enum
Private Const InvalidDateRangeMessage As String = "Specified date range is not valid."
Private this As THotel
Public Property Get Name() As String
 Name = this.Name
End Property
Friend Property Let Name(ByVal value As String)
 this.Name = value
End Property
Public Property Get Rating() As Byte
 Rating = this.Rating
End Property
Friend Property Let Rating(ByVal value As Byte)
 this.Rating = value
End Property
Friend Property Set PricingStrategy(ByVal value As IPricingStrategy)
 Set this.Pricing = value
End Property
Public Function GetPrice(ByVal checkin As Date, ByVal checkout As Date, ByVal custType As CustomerType) As Currency
 If checkin > checkout Then OnInvalidDateRange "GetPrice"
  
 Dim result As Currency
 Dim checkedDay As Date
 For checkedDay = checkin To checkout
 result = result + this.Pricing.CalculatePricing(checkedDay, custType)
 Next
 GetPrice = result
 End Function
Private Sub OnInvalidDateRange(ByVal source As String)
 Err.Raise HotelError.InvalidDateRange, TypeName(Me) & "." & source, InvalidDateRangeMessage
End Sub

I'm pretty sure I went overboard. How do I make this right? As always, I'm open to any & all suggestions and comments.

I thought this question made a good excuse for some basic OOP code, so I whipped up a little bit of code to demonstrate it in VBA; the idea is to have tutorial-grade code, to show how interfaces and default instances can be used to implement immutable types and factory methods to simulate constructors in VBA.

Option Explicit
Public Sub Test(ByVal checkin As Date, ByVal checkout As Date, ByVal custType As CustomerType)
 Dim finder As New HotelFinder
 InitializeHotels finder
 Debug.Print finder.FindCheapestHotel(checkin, checkout, custType)
End Sub
Private Sub InitializeHotels(ByVal finder As HotelFinder)
 With StandardHotel.Create("Green Valley", 3)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Premium), 800)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Premium), 800)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Regular), 1100)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Regular), 900)
 finder.Hotels.Add .Self
 End With
 
 With StandardHotel.Create("Red River", 4)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Premium), 1100)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Premium), 500)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Regular), 1600)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Regular), 600)
 finder.Hotels.Add .Self
 End With
 
 With StandardHotel.Create("Blue Hills", 5)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Premium), 1000)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Premium), 400)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkDay, Regular), 2200)
 .AddPricingRule FixedAmountPricingRule.Create(PricingRuleInfo.Create(WkEnd, Regular), 1500)
 finder.Hotels.Add .Self
 End With
 
End Sub

Test Now, Now + 3, Premium
Green Valley 3ドル,200.00
Red River 4ドル,400.00
Blue Hills 4ドル,000.00
Green Valley

I needed a type to encapsulate the variables that can influence a hotel's pricing. And because I want these values to be immutable, I exposed getters for them in this IPricingRuleInfo interface:

Option Explicit
Public Enum CustomerType
 Regular
 Premium
End Enum
Public Enum DateType
  WkDay
 WkEnd
End Enum
Public Property Get DateType() As DateType
End Property
Public Property Get CustomerType() As CustomerType
End Property
Public Function ToString() As String
End Function

The class that implements it has a VB_PredeclaredId attribute set to True, which makes a PricingRuleInfo object variable available to use the Create factory method. I added a Self getter that returns Me, so that I could use a neat With New syntax in the Create method:

Option Explicit
Private Type TInfo
 DateType As DateType
 CustomerType As CustomerType
End Type
Private this As TInfo
Implements IPricingRuleInfo
Public Property Get CustomerType() As CustomerType
 CustomerType = this.CustomerType
End Property
Public Property Let CustomerType(ByVal value As CustomerType)
 this.CustomerType = value
End Property
Public Property Get DateType() As DateType
 DateType = this.DateType
End Property
Public Property Let DateType(ByVal value As DateType)
 this.DateType = value
End Property
Public Property Get Self() As IPricingRuleInfo
 Set Self = Me
End Property
Public Function Create(ByVal dtType As DateType, ByVal custType As CustomerType) As IPricingRuleInfo
 With New PricingRuleInfo
 .DateType = dtType
 .CustomerType = custType
 Set Create = .Self
 End With
End Function
Private Property Get IPricingRuleInfo_CustomerType() As CustomerType
 IPricingRuleInfo_CustomerType = this.CustomerType
End Property
Private Property Get IPricingRuleInfo_DateType() As DateType
 IPricingRuleInfo_DateType = this.DateType
End Property
Private Function IPricingRuleInfo_ToString() As String
 IPricingRuleInfo_ToString = CStr(this.CustomerType) & ";" & CStr(this.DateType)
End Function

The IPricingRule interface exposes an Evaluate method that takes an IPricingRuleInfo object, so an IPricingRule implementation could evaluate a price based on parameters, or whatever is applicable, really:

Option Explicit
Public Property Get RuleInfo() As IPricingRuleInfo
End Property
Public Function Evaluate(Optional ByVal info As IPricingRuleInfo = Nothing) As Currency
End Function

To solve the original problem all I needed was a FixedAmountPricingRule, which returns a predetermined amount regardless of what parameter is passed to Evaluate - again this class has a VB_PredeclaredId attribute value set to True, and exposes a factory method:

Option Explicit
Private Type TRule
 RuleInfo As IPricingRuleInfo
 Amount As Currency
End Type
Private this As TRule

Implements IPricingRule
Private Property Get IPricingRule_RuleInfo() As IPricingRuleInfo
 Set IPricingRule_RuleInfo = this.RuleInfo
End Property
Private Function IPricingRule_Evaluate(ByVal info As IPricingRuleInfo) As Currency
 IPricingRule_Evaluate = this.Amount
End Function
Public Property Get RuleInfo() As IPricingRuleInfo
 Set RuleInfo = this.RuleInfo
End Property
Public Property Set RuleInfo(ByVal value As IPricingRuleInfo)
 Set this.RuleInfo = value
End Property
Public Property Get Amount() As Currency
 Amount = this.Amount
End Property
Public Property Let Amount(ByVal value As Currency)
 this.Amount = value
End Property
Public Property Get Self() As IPricingRule
 Set Self = Me
End Property
Public Function Create(ByVal info As IPricingRuleInfo, ByVal value As Currency) As IPricingRule
 With New FixedAmountPricingRule
 Set .RuleInfo = info
 .Amount = value
 Set Create = .Self
 End With
End Function

Next, the IHotel interface, which can map a Date to a DateType value, and calculate a price given an IPricingRuleInfo parameter; of course the interface also exposes the establishment's Name and Rating:

Option Explicit
Public Property Get Name() As String
End Property
Public Property Get Rating() As Byte
End Property
Public Function CalculatePricing(ByVal info As IPricingRuleInfo) As Currency
End Function
Public Function GetDateType(ByVal value As Date) As DateType
End Function

The StandardHotel class that implements this interface has a VB_PredeclaredId attribute set to True, and exposes a Create factory method and an AddPricingRule method to set up the hotel's pricing rules; because I wanted a way to ensure no two IPricingRuleInfo would collide and make the pricing potentially ambiguous, I decided to use a Scripting.Dictionary and used IPricingRuleInfo.ToString as a key. The GetDateType for a StandardHotel merely determines if a date is a WkDay or a WkEnd date - in time other implementations could return a Holiday value given date X or Y, but I didn't need to go there for now:

Option Explicit
Private Type THotel
 PricingRules As New Scripting.Dictionary
 Name As String
 Rating As Byte
End Type
Private this As THotel
Implements IHotel
Public Property Get Name() As String
 Name = this.Name
End Property
Public Property Let Name(ByVal value As String)
 this.Name = value
End Property
Public Property Get Rating() As Byte
 Rating = this.Rating
End Property
Public Property Let Rating(ByVal value As Byte)
 this.Rating = value
End Property
Public Property Get Self() As IHotel
 Set Self = Me
End Property
Public Function Create(ByVal hotelName As String, ByVal stars As Byte, Optional ByVal rules As Collection = Nothing) As StandardHotel
 
 Dim rule As IPricingRule
 With New StandardHotel
 
 .Name = hotelName
 .Rating = stars
 
 If Not rules Is Nothing Then
 For Each rule In rules
 .AddPricingRule rule
 Next
 End If
 
 Set Create = .Self
 
 End With
End Function
Public Sub AddPricingRule(ByVal rule As IPricingRule)
 this.PricingRules.Add rule.RuleInfo.ToString, rule
End Sub
Private Function IHotel_CalculatePricing(ByVal info As IPricingRuleInfo) As Currency
 Dim rule As IPricingRule
 Set rule = this.PricingRules(info.ToString)
 IHotel_CalculatePricing = rule.Evaluate(info)
End Function
Private Function IHotel_GetDateType(ByVal value As Date) As DateType
 IHotel_GetDateType = IIf(Weekday(value, vbMonday) <= 5, WkDay, WkEnd)
End Function
Private Property Get IHotel_Name() As String
 IHotel_Name = this.Name
End Property
Private Property Get IHotel_Rating() As Byte
 IHotel_Rating = this.Rating
End Property

Finally, the HotelFinder class implements the logic that iterates all hotels and finds the cheapest one:

Option Explicit
Private Type TFinder
 Hotels As Collection
End Type
Private this As TFinder
Public Property Get Hotels() As Collection
 Set Hotels = this.Hotels
End Property
Public Function FindCheapestHotel(ByVal fromDate As Date, ByVal toDate As Date, ByVal custType As CustomerType) As String
 Dim place As IHotel
 Dim checkedDate As Date
 Dim cheapestAmount As Currency
 Dim cheapestHotel As IHotel
 
 Dim hotelTotal As Currency
 For Each place In this.Hotels
 
 hotelTotal = 0
 For checkedDate = fromDate To toDate
 Dim info As IPricingRuleInfo
 Set info = PricingRuleInfo.Create(place.GetDateType(checkedDate), custType)
 hotelTotal = hotelTotal + place.CalculatePricing(info)
 Next
 
 If cheapestAmount = 0 Or hotelTotal < cheapestAmount Then
 cheapestAmount = hotelTotal
 Set cheapestHotel = place
 ElseIf hotelTotal = cheapestAmount And cheapestHotel.Rating > place.Rating Then
 'same price, but higher rating; higher rating gets precedence
 Set cheapestHotel = place
 End If
 
 Debug.Print place.Name, Format(hotelTotal, "$#,##0.00")
 Next
 
 FindCheapestHotel = cheapestHotel.Name
End Function
Private Sub Class_Initialize()
 Set this.Hotels = New Collection
End Sub
Private Sub Class_Terminate()
 Set this.Hotels = Nothing
End Sub

The Hotels collection is initialized in the InitializeHotels private procedure in Module1, so the code at the top of the call stack has a pretty high level of abstraction.