P
PeteCresswell
Typed into a cell, this works:
=MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
But I want to invoke the calc from afar (specifically MS Access VBA).
I can instantiate a copy of Excel, and invoke other routines like
"MIN", but am not having any luck with "MDURATION" and, indeed, it
does not appear in the code completion dropdown for
WorksheetFunction.mDuration
Sounds like I'm out of luck.
Or am I?
For the maschocistically inclined, here's the offending code (which
looks it's best rendered in a monospaced font) - but all I really want
to know is whether or not I can call MDURATION from VBA code and, if
so, what the syntax would be....
--------------------------------------------------------------------------------------------------
Public Function MDURATION_Excel(ByVal theValues As String) As Variant
8000 debugStackPush mModuleName & ": MDURATION_Excel"
8001 On Error GoTo MDURATION_Excel_err
' PURPOSE: To invoke MS Excel's "MDURATION" (Modified McCauley
duration) function"
' ACCEPTS: A list of values as a string delimintated by commas
' The values are:
' - Settlement Date
' - Maturity Date
' - Coupon percent
' - Yield percent
' - Payment Frequency
' 0 = 3./360
' 1 = Actual/Actual
' 2 = Actual/360
' 3 = Actual/365
' 4 = European 30/360
' RETURNS: Result of Excel.MDURATION calculation
'
' SAMPLE:
' -----------------------------------------
' MS Excel's Help e.g.
' =MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
' 5.73567
' translated to call syntax for this routine:
' ?MDURATION_Excel("1/1/2008, 1/1/2016, .08, .09, 2, 1")
8002 Dim myArray() As String
Dim i As Long
Dim myResult As Double
8003 If Len(theValues) > 0 Then
8010 If Excel_Start(gExcelApp) = True Then
8011 ParseToArrayOfString theValues, ",",
myArray 'Put values in format acceptable to Excel
8912 myResult = gExcelApp.WorksheetFunction.mDuration(myArray)
8913 MDURATION_Excel = myResult
8919 End If
8990 Else
8991 MDURATION_Excel = "na"
8999 End If
MDURATION_Excel_xit:
DebugStackPop
On Error Resume Next
Exit Function
MDURATION_Excel_err:
BugAlert True, ""
Resume MDURATION_Excel_xit
End Function
Public Function ParseToArrayOfString(ByVal theStringToBeParsed As
String, ByVal theDelimiter As String, ByRef theArray() As String) As
Long
1000 debugStackPush mModuleName & ": ParseToArrayOfString"
1001 On Error GoTo ParseToArrayOfString_err
' PURPOSE: To parse a Delimited string into an array
' ACCEPTS: - String to be parsed
' - Delimiter between items in the string
' - Address of the array that results will be delivered to
' RETURNS: The number of items copied to the array or -1
' SETS: The contents of the array specified
'
' CALLING CONVENTION:
' ReDim Items(20)
' ItemCount = ParseToArrayOfString("this, is, a string,
delimited, by, commas",Items(),",")
1003 Dim P As Integer
Dim i As Integer
Dim newSize As Integer
Const textComparison = 1
1010 If Len(theStringToBeParsed & "") > 0 Then
1020 If theDelimiter = ""
Then 'Check for valid
theDelimiteriter
1030 ParseToArrayOfString = -1
1040 Else
1041 If Len(theStringToBeParsed) < 1 Then
1042 ParseToArrayOfString = -1
1043 Else
1050 i = 0
1060 P = InStr(1, theStringToBeParsed, theDelimiter,
textComparison)
1061 If P = 0
Then 'Oops! Only
one item, no delimiter
1062 i = 1
1063 ReDim Preserve theArray(i)
1064 theArray(0) = theStringToBeParsed
1065 Else
1070 Do While P >
0 'Copy all items
except last
1080 newSize = i + 1
1090 ReDim Preserve theArray(newSize)
1100 theArray(LBound(theArray) + i) = Left$
(theStringToBeParsed, P - 1)
1110 i = i + 1
1120 theStringToBeParsed = Mid$(theStringToBeParsed, P
+ 1)
1130 P = InStr(1, theStringToBeParsed, theDelimiter,
textComparison)
1140 Loop
1150 theArray(LBound(theArray) + i) =
theStringToBeParsed 'Copy Last Item
1160 i = i + 1
1165 End If
1170 ParseToArrayOfString = i
1997 End If
1998 End If
1999 End If
ParseToArrayOfString_xit:
DebugStackPop
On Error Resume Next
Exit Function
ParseToArrayOfString_err:
ParseToArrayOfString = -1
BugAlert True, ""
Resume ParseToArrayOfString_xit
End Function
Public Function Excel_Start(ByRef theSS As Excel.Application) As
Boolean
3000 debugStackPush mModuleName & ": Excel_Start: "
3001 On Error GoTo Excel_Start_err
' PURPOSE: - Start an instance of MS Excel or use an existing
instance
' - Leave "theSS" pointing to the Excel Basic engine
' behind the newly-opened document
' ACCEPTS: - Pointer to the spreadsheet TB used by calling routine
' RETURNS: True/False depending on success
'
' NOTES: 1) We do not want to keep opening up new instances of
Excel every time this routine
' is called, so we do the "= Nothing" check to see if
theSS has already been set.
' OTHO the user may have closed that instance of Excel,
leaving theSS pointing to
' Neverneverland. Experimentation shows that an error
2753 is generated in this case.
' Hence the error trap and the "userClosedExcel"
switch.
'
'SAMPLE:
' ?SpreadSheetOpenExisting("D:\Dev\SEI\DataSource
\BuySell.xls", gExcelApp)
3002 Dim userClosedExcel As Long
Dim serverNotExist As Long
Dim okToProceed As Boolean
Const oleError = 2753
Const rpcServerUnavailable = -2147023174
Const remoteServerNotExist = 462
Const docAlreadyOpen = 1004
Excel_Start_loop:
' ---------------------------------------------------
' Create an instance of Excel
3010 If (theSS Is Nothing) Or (userClosedExcel = 1) Then
3011 Set theSS = CreateObject("Excel.Application")
'3012 With theSs
'3013 .Workbooks.Add
'3014 .ScreenUpdating = True
'3015 .Visible = True
'3016 End With
3019 End If
' ---------------------------------------------------
' Open up the spreadsheet
3999 Excel_Start = True
Excel_Start_xit:
DebugStackPop
On Error Resume Next
Exit Function
Excel_Start_err:
Select Case Err
Case 2772
MsgBox "Unable to locate Microsoft Excel program. Please
notify your administrator", 16, "Cannot Open MS Excel"
Resume Excel_Start_xit
Case oleError, rpcServerUnavailable
If userClosedExcel = 0 Then
userClosedExcel = userClosedExcel + 1
Resume Excel_Start_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect user
may have closed existing instance."
Resume Excel_Start_xit
End If
Case remoteServerNotExist
If serverNotExist = 0 Then
serverNotExist = serverNotExist + 1
Set theSS = Nothing
Resume Excel_Start_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect user
may have closed existing instance."
Resume Excel_Start_xit
End If
Case docAlreadyOpen
BugAlert True, ""
Case Else
BugAlert True, ""
Resume Excel_Start_xit
End Select
Resume Excel_Start_xit 'Shouldn't be needed, but just in
case.....
End Function
--------------------------------------------------------------------------------------------------
=MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
But I want to invoke the calc from afar (specifically MS Access VBA).
I can instantiate a copy of Excel, and invoke other routines like
"MIN", but am not having any luck with "MDURATION" and, indeed, it
does not appear in the code completion dropdown for
WorksheetFunction.mDuration
Sounds like I'm out of luck.
Or am I?
For the maschocistically inclined, here's the offending code (which
looks it's best rendered in a monospaced font) - but all I really want
to know is whether or not I can call MDURATION from VBA code and, if
so, what the syntax would be....
--------------------------------------------------------------------------------------------------
Public Function MDURATION_Excel(ByVal theValues As String) As Variant
8000 debugStackPush mModuleName & ": MDURATION_Excel"
8001 On Error GoTo MDURATION_Excel_err
' PURPOSE: To invoke MS Excel's "MDURATION" (Modified McCauley
duration) function"
' ACCEPTS: A list of values as a string delimintated by commas
' The values are:
' - Settlement Date
' - Maturity Date
' - Coupon percent
' - Yield percent
' - Payment Frequency
' 0 = 3./360
' 1 = Actual/Actual
' 2 = Actual/360
' 3 = Actual/365
' 4 = European 30/360
' RETURNS: Result of Excel.MDURATION calculation
'
' SAMPLE:
' -----------------------------------------
' MS Excel's Help e.g.
' =MDURATION("1/1/2008", "1/1/2016", ".08", ".09", "2", "1")
' 5.73567
' translated to call syntax for this routine:
' ?MDURATION_Excel("1/1/2008, 1/1/2016, .08, .09, 2, 1")
8002 Dim myArray() As String
Dim i As Long
Dim myResult As Double
8003 If Len(theValues) > 0 Then
8010 If Excel_Start(gExcelApp) = True Then
8011 ParseToArrayOfString theValues, ",",
myArray 'Put values in format acceptable to Excel
8912 myResult = gExcelApp.WorksheetFunction.mDuration(myArray)
8913 MDURATION_Excel = myResult
8919 End If
8990 Else
8991 MDURATION_Excel = "na"
8999 End If
MDURATION_Excel_xit:
DebugStackPop
On Error Resume Next
Exit Function
MDURATION_Excel_err:
BugAlert True, ""
Resume MDURATION_Excel_xit
End Function
Public Function ParseToArrayOfString(ByVal theStringToBeParsed As
String, ByVal theDelimiter As String, ByRef theArray() As String) As
Long
1000 debugStackPush mModuleName & ": ParseToArrayOfString"
1001 On Error GoTo ParseToArrayOfString_err
' PURPOSE: To parse a Delimited string into an array
' ACCEPTS: - String to be parsed
' - Delimiter between items in the string
' - Address of the array that results will be delivered to
' RETURNS: The number of items copied to the array or -1
' SETS: The contents of the array specified
'
' CALLING CONVENTION:
' ReDim Items(20)
' ItemCount = ParseToArrayOfString("this, is, a string,
delimited, by, commas",Items(),",")
1003 Dim P As Integer
Dim i As Integer
Dim newSize As Integer
Const textComparison = 1
1010 If Len(theStringToBeParsed & "") > 0 Then
1020 If theDelimiter = ""
Then 'Check for valid
theDelimiteriter
1030 ParseToArrayOfString = -1
1040 Else
1041 If Len(theStringToBeParsed) < 1 Then
1042 ParseToArrayOfString = -1
1043 Else
1050 i = 0
1060 P = InStr(1, theStringToBeParsed, theDelimiter,
textComparison)
1061 If P = 0
Then 'Oops! Only
one item, no delimiter
1062 i = 1
1063 ReDim Preserve theArray(i)
1064 theArray(0) = theStringToBeParsed
1065 Else
1070 Do While P >
0 'Copy all items
except last
1080 newSize = i + 1
1090 ReDim Preserve theArray(newSize)
1100 theArray(LBound(theArray) + i) = Left$
(theStringToBeParsed, P - 1)
1110 i = i + 1
1120 theStringToBeParsed = Mid$(theStringToBeParsed, P
+ 1)
1130 P = InStr(1, theStringToBeParsed, theDelimiter,
textComparison)
1140 Loop
1150 theArray(LBound(theArray) + i) =
theStringToBeParsed 'Copy Last Item
1160 i = i + 1
1165 End If
1170 ParseToArrayOfString = i
1997 End If
1998 End If
1999 End If
ParseToArrayOfString_xit:
DebugStackPop
On Error Resume Next
Exit Function
ParseToArrayOfString_err:
ParseToArrayOfString = -1
BugAlert True, ""
Resume ParseToArrayOfString_xit
End Function
Public Function Excel_Start(ByRef theSS As Excel.Application) As
Boolean
3000 debugStackPush mModuleName & ": Excel_Start: "
3001 On Error GoTo Excel_Start_err
' PURPOSE: - Start an instance of MS Excel or use an existing
instance
' - Leave "theSS" pointing to the Excel Basic engine
' behind the newly-opened document
' ACCEPTS: - Pointer to the spreadsheet TB used by calling routine
' RETURNS: True/False depending on success
'
' NOTES: 1) We do not want to keep opening up new instances of
Excel every time this routine
' is called, so we do the "= Nothing" check to see if
theSS has already been set.
' OTHO the user may have closed that instance of Excel,
leaving theSS pointing to
' Neverneverland. Experimentation shows that an error
2753 is generated in this case.
' Hence the error trap and the "userClosedExcel"
switch.
'
'SAMPLE:
' ?SpreadSheetOpenExisting("D:\Dev\SEI\DataSource
\BuySell.xls", gExcelApp)
3002 Dim userClosedExcel As Long
Dim serverNotExist As Long
Dim okToProceed As Boolean
Const oleError = 2753
Const rpcServerUnavailable = -2147023174
Const remoteServerNotExist = 462
Const docAlreadyOpen = 1004
Excel_Start_loop:
' ---------------------------------------------------
' Create an instance of Excel
3010 If (theSS Is Nothing) Or (userClosedExcel = 1) Then
3011 Set theSS = CreateObject("Excel.Application")
'3012 With theSs
'3013 .Workbooks.Add
'3014 .ScreenUpdating = True
'3015 .Visible = True
'3016 End With
3019 End If
' ---------------------------------------------------
' Open up the spreadsheet
3999 Excel_Start = True
Excel_Start_xit:
DebugStackPop
On Error Resume Next
Exit Function
Excel_Start_err:
Select Case Err
Case 2772
MsgBox "Unable to locate Microsoft Excel program. Please
notify your administrator", 16, "Cannot Open MS Excel"
Resume Excel_Start_xit
Case oleError, rpcServerUnavailable
If userClosedExcel = 0 Then
userClosedExcel = userClosedExcel + 1
Resume Excel_Start_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect user
may have closed existing instance."
Resume Excel_Start_xit
End If
Case remoteServerNotExist
If serverNotExist = 0 Then
serverNotExist = serverNotExist + 1
Set theSS = Nothing
Resume Excel_Start_loop
Else
BugAlert True, "Unable to open MS Excel. Suspect user
may have closed existing instance."
Resume Excel_Start_xit
End If
Case docAlreadyOpen
BugAlert True, ""
Case Else
BugAlert True, ""
Resume Excel_Start_xit
End Select
Resume Excel_Start_xit 'Shouldn't be needed, but just in
case.....
End Function
--------------------------------------------------------------------------------------------------