Option Compare Database Option Explicit 'use enum for column OptionType Public Enum ReturnValue ValueBS = 1 DeltaBS = 3 GammaBS = 5 ThetaBS = 6 RhoBS = 8 VegaBS = 10 End Enum 'use enum for column OptionType Public Enum OptionCalculation Call_BlackSchole = 1 Put_BlackSchole = 2 End Enum Private mOptionType As Long Private mStrikePrice As Double Private mSharePrice As Double Private mTimeToExpiry As Double Private mRiskFreeInterestRate As Double Private mSigma As Double Private mDividend As Double Private mlngID As Long Private Sub Class_Initialize() ' mOptionType = 0 ' mStrikePrice = 0 ' mSharePrice = 0 ' mTimeToExpiry = 0 ' mR = 0 ' mRiskFreeInterestRate = 0 ' mSigma = 0 End Sub Private Sub Class_Terminate() ''use? End Sub Public Property Get StrikePrice() As Double StrikePrice = mStrikePrice End Property Public Property Let StrikePrice(dblVal As Double) 'verifies rate is between 0 and 1 If dblVal <= 0 Then Err.Raise vbObjectError + 512, "European Option", "Strike price must be greater than 0" End If mStrikePrice = dblVal End Property Public Property Get OptionType() As OptionCalculation OptionType = mOptionType End Property Public Property Let OptionType(lngVal As OptionCalculation) 'verifies rate is between 0 and 1 If lngVal <> Call_BlackSchole And lngVal <> Put_BlackSchole Then Err.Raise vbObjectError + 512, "European Option", "Option type not valid." End If mOptionType = lngVal End Property Public Property Get SharePrice() As Double SharePrice = mSharePrice End Property Public Property Let SharePrice(dblVal As Double) 'verifies rate is between 0 and 1 If dblVal < 0.00001 Then Err.Raise vbObjectError + 512, "European Option", "Share price must be greater than 0.00001" End If mSharePrice = dblVal End Property Public Property Get TimeToExpiry() As Double ''mTimeToExpiry is in years, but converts back to days based on 365 daya calendar TimeToExpiry = mTimeToExpiry * 365 End Property Public Property Let TimeToExpiry(dblVal As Double) ''receives days, but converts to year based on 365 daya calendar ''requires value is greater than 0 'verifies rate is between 0 and 1 If dblVal <= 0 Then Err.Raise vbObjectError + 512, "European Option", "Expiry must be greater than 0" End If mTimeToExpiry = dblVal / 365 End Property Public Property Get RiskFreeInterestRate() As Double RiskFreeInterestRate = mRiskFreeInterestRate End Property Public Property Let RiskFreeInterestRate(dblVal As Double) ''requires decimal interest rate, not percent 'verifies rate is between 0 and 1 If dblVal < 0 Or dblVal > 1 Then Err.Raise vbObjectError + 512, "European Option", "Rate must be between 0 and 1, here 1 = 100%" End If mRiskFreeInterestRate = dblVal End Property Public Property Get Sigma() As Double Sigma = mSigma End Property Public Property Let Sigma(dblVal As Double) ''requires decimal standard deviation 'verifies rate is between 0 and 1 If dblVal < 0 Or dblVal > 1 Then Err.Raise vbObjectError + 512, "European Option", "Sigma (Standard Deviation) must be between 0 and 1" End If mSigma = dblVal End Property Public Property Get Dividend() As Double Dividend = mDividend End Property Public Property Let Dividend(dblVal As Double) 'verifies dividend is between 0 and 1 If dblVal < 0 Or dblVal > 1 Then Err.Raise vbObjectError + 512, "European Option", "Dividend must be between 0 and 1" End If mDividend = dblVal End Property Private Sub Verify() If mOptionType = 0 Then Err.Raise vbObjectError + 512, "European Option", "Option type must be defined." ElseIf mStrikePrice = 0 Then Err.Raise vbObjectError + 512, "European Option", "Strike Price must be defined." ElseIf mSharePrice = 0 Then Err.Raise vbObjectError + 512, "European Option", "Share Price must be defined." ElseIf mTimeToExpiry = 0 Then Err.Raise vbObjectError + 512, "European Option", "Time to Expiry must be defined." ElseIf mRiskFreeInterestRate = 0 Then Err.Raise vbObjectError + 512, "European Option", "Risk Free Interest Rate must be defined." ElseIf mSigma = 0 Then Err.Raise vbObjectError + 512, "European Option", "Sigma (Standard Deviation) must be defined." End If End Sub Public Function Calculate(ByVal Command As ReturnValue) As Double ' Calculates the value of an European Option (Black-Scholes) ' Typ -> Call or Put ' Command -> Price, Delta, Gamma, Theta, Vega, Rho Verify mTimeToExpiry = Excel.WorksheetFunction.Max(0.00001, mTimeToExpiry) Dim d1 As Double Dim d2 As Double Dim dblTempHolder As Double dblTempHolder = 0 If (mSigma * mStrikePrice * mTimeToExpiry > 0) Then d1 = Log(mSharePrice / mStrikePrice) + ((mRiskFreeInterestRate - mDividend) + 0.5 * mSigma * mSigma) * mTimeToExpiry d1 = d1 / (mSigma * Sqr(mTimeToExpiry)) d2 = d1 - mSigma * Sqr(mTimeToExpiry) End If Select Case Command Case ValueBS If mOptionType = Call_BlackSchole Then Calculate = (mSharePrice * Exp(-mDividend * mTimeToExpiry) * CumulativeDistributionFunction(d1)) - (Exp(-mRiskFreeInterestRate * mTimeToExpiry) * mStrikePrice * CumulativeDistributionFunction(d2)) ElseIf mOptionType = Put_BlackSchole Then Calculate = Exp(-mRiskFreeInterestRate * mTimeToExpiry) * mStrikePrice * CumulativeDistributionFunction(-d2) - mSharePrice * Exp(-mDividend * mTimeToExpiry) * CumulativeDistributionFunction(-d1) End If Case DeltaBS If mOptionType = Call_BlackSchole Then Calculate = Exp(-mDividend * mTimeToExpiry) * CumulativeDistributionFunction(d1) ElseIf mOptionType = Put_BlackSchole Then Calculate = Exp(-mDividend * mTimeToExpiry) * (CumulativeDistributionFunction(d1) - 1) End If Case GammaBS Calculate = nprime(d1) * Exp(-mDividend * mTimeToExpiry) / (mSharePrice * mSigma * Sqr(mTimeToExpiry)) Case ThetaBS If mOptionType = Call_BlackSchole Then dblTempHolder = -(mSharePrice * nprime(d1) * mSigma * Exp(-mDividend * mTimeToExpiry) / 2 / Sqr(mTimeToExpiry)) dblTempHolder = dblTempHolder + (mDividend * mSharePrice * CumulativeDistributionFunction(d1) * Exp(-mDividend * mTimeToExpiry)) dblTempHolder = dblTempHolder - (mRiskFreeInterestRate * mStrikePrice * Exp(-mRiskFreeInterestRate * mTimeToExpiry) * CumulativeDistributionFunction(d2)) Calculate = dblTempHolder / 100 ElseIf mOptionType = Put_BlackSchole Then dblTempHolder = -(mSharePrice * nprime(d1) * mSigma * Exp(-mDividend * mTimeToExpiry) / 2 / Sqr(mTimeToExpiry)) dblTempHolder = dblTempHolder - (mDividend * mSharePrice * CumulativeDistributionFunction(-d1) * Exp(-mDividend * mTimeToExpiry)) dblTempHolder = dblTempHolder + (mRiskFreeInterestRate * mStrikePrice * Exp(-mRiskFreeInterestRate * mTimeToExpiry) * CumulativeDistributionFunction(-d2)) Calculate = dblTempHolder / 100 End If dblTempHolder = 0 Case RhoBS If mOptionType = Call_BlackSchole Then Calculate = (mStrikePrice * mTimeToExpiry * Exp(-mRiskFreeInterestRate * mTimeToExpiry) * CumulativeDistributionFunction(d2)) / 100 ElseIf mOptionType = Put_BlackSchole Then Calculate = (-mStrikePrice * mTimeToExpiry * Exp(-mRiskFreeInterestRate * mTimeToExpiry) * CumulativeDistributionFunction(-d2)) / 100 End If Case VegaBS Calculate = (mSharePrice * Sqr(mTimeToExpiry / 3.1415926 / 2) * Exp(-0.5 * d1 * d1) * Exp(-mDividend * mTimeToExpiry)) / 100 Case Else Err.Raise vbObjectError + 512, "European Option", "Return value not valid." End Select End Function Public Function ValueArray() As Variant ValueArray = Array(OptionType, SharePrice, StrikePrice, Sigma, TimeToExpiry, RiskFreeInterestRate, Dividend, Calculate(ValueBS), Calculate(DeltaBS), Calculate(GammaBS), Calculate(ThetaBS), Calculate(VegaBS), Calculate(RhoBS)) End Function Private Function CumulativeDistributionFunction(x As Double) As Double Dim d As Double Dim a As Double Dim b As Double Dim c As Double d = 1 / (1 + 0.33267 * Abs(x)) a = 0.4361836 b = -0.1201676 c = 0.937298 CumulativeDistributionFunction = 1 - 1 / Sqr(2 * 3.1415926) * Exp(-0.5 * x * x) * (a * d + b * d * d + c * d * d * d) If x < 0 Then CumulativeDistributionFunction = 1 - CumulativeDistributionFunction End Function Private Function nprime(x As Double) As Double nprime = Exp(-0.5 * x * x) / Sqr(2 * 3.1415926) End Function