Code-a-holic: May 2009

Tuesday, May 19, 2009

[VB6] MAXDOUBLE, MINDOUBLE, +INFINITY, -INFINITY and NaN

VB6 doesn't seem to be able to specify that a Double contains MAXDOUBLE, MINDOUBLE, +INFINITY, -INFINITY or NaN. (I could be wrong on that as there may be some undocumented feature hiding in there somewhere.)

Anyway, I came up with a way of storing these values into Doubles so that they could be used in a Complex Numbers library I've been writing.

Essentially, I create an 8 byte array, load it up with the relevant values, and then, using API calls and the VarPtr function, store the contents of the array into the storage used by the Double.

Here's the code. First the declarations.

Public MaxDouble As Double
Public MinDouble As Double
Public NegInfinity As Double
Public PosInfinity As Double
Public QuietNAN As Double

Private Declare Sub CopyMemory Lib "kernel32" _
    Alias "RtlMoveMemory" (Destination As Any, _
    source As Any, ByVal Length As Long)
Private Declare Function GetProcessHeap Lib "kernel32" () As Long
Private Declare Function HeapAlloc Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, _
     ByVal dwBytes As Long) As Long
Private Declare Function HeapFree Lib "kernel32" _
    (ByVal hHeap As Long, ByVal dwFlags As Long, lpMem As Any) As Long
Private Declare Sub CopyMemoryWrite Lib "kernel32" Alias _
    "RtlMoveMemory" (ByVal Destination As Long, _
    source As Any, ByVal Length As Long)
Private Declare Sub CopyMemoryRead Lib "kernel32" Alias _
    "RtlMoveMemory" (Destination As Any, _
    ByVal source As Long, ByVal Length As Long)

Then the routine that does the work.

Public Sub Init()
    Dim ptrToDouble As Long
    Dim byteArray(7) As Byte
    Dim i As Integer
    
    byteArray(7) = &H7F 'maxdbl
    byteArray(6) = &HEF
    For i = 0 To 5
        byteArray(i) = &HFF
    Next
    ptrToDouble = VarPtr(MaxDouble)
    CopyMemoryWrite ptrToDouble, byteArray(0), 8

    byteArray(7) = &HFF 'mindbl
    byteArray(6) = &HEF
    For i = 0 To 5
        byteArray(i) = &HFF
    Next
    ptrToDouble = VarPtr(MinDouble)
    CopyMemoryWrite ptrToDouble, byteArray(0), 8
    
    byteArray(7) = &H7F '+inf
    byteArray(6) = &HF0
    For i = 0 To 5
        byteArray(i) = 0
    Next
    ptrToDouble = VarPtr(PosInfinity)
    CopyMemoryWrite ptrToDouble, byteArray(0), 8

    byteArray(7) = &HFF '-inf
    byteArray(6) = &HF0
    For i = 0 To 5
        byteArray(i) = 0
    Next
    ptrToDouble = VarPtr(NegInfinity)
    CopyMemoryWrite ptrToDouble, byteArray(0), 8

    byteArray(7) = &H7F 'quiet NAN
    byteArray(6) = &HF0
    For i = 0 To 5
        byteArray(i) = &HFF
    Next
    ptrToDouble = VarPtr(QuietNAN)
    CopyMemoryWrite ptrToDouble, byteArray(0), 8

End Sub

Finally, a slice out of the Complex Numbers project demonstrating the use of some of these declarations.

Public Function IsInfinity(c As Variant) As Boolean
    Dim bRes As Boolean
    bRes = False
    If TypeName(c) = "ComplexNumber" Then
        If c.Real = PosInfinity And c.Imag = PosInfinity Then bRes = True
        If c.Real = NegInfinity And c.Imag = NegInfinity Then bRes = True
    Else
        If c = PosInfinity Then bRes = True
        If c = NegInfinity Then bRes = True
    End If
    IsInfinity = bRes
End Function

Enjoy!

© Copyright Bruce M. Axtens, 2009

Thursday, May 14, 2009

[VB6]Searching an ActiveX/COM object for a method

This article was first posted by me on StackOverflow in response to my own question, "How do I search an ActiveX/COM object for a method?". This article is an edited version of the original.

"After Googling around not quite finding what I wanted, I remembered the Edanmo site which got me thinking about TLBINF32.DLL, downloading Microsoft's TLBINF32.CHM and reading up on GetMembersWithSubStringEx.

Below is the implementation of it (done in VB6 with a reference to TLBINF32.DLL), some demo VBScript and output, and the wrapping of that functionality in some VBA.

Public Function SearchTLIMethodsAndProperties(sTypelib As Variant, sSymbol As Variant) As Variant
    Dim SI As SearchItem
    Dim aResults As Variant
    Dim bFound as boolean
    Dim Groups(1) As InvokeKinds
    Groups(0) = INVOKE_FUNC Or INVOKE_PROPERTYGET Or _
     INVOKE_PROPERTYPUT Or INVOKE_PROPERTYPUTREF
    ReDim aResults(0)
    bFound = False
    With TypeLibInfoFromFile(sTypelib)
 .SearchDefault = tliStClasses Or tliStEvents
 For Each SI In .GetMembersWithSubStringEx(sSymbol, Groups)
     bFound = True
     arr.AAdd_PostIncrement aResults, SI.Name
 Next
    End With
    if bFound then 
 ReDim Preserve aResults(UBound(aResults) - 1)
    end if
    SearchTLIMethodsAndProperties = aResults
End Function

VBScript demo. The above code was included in my StdLib DLL in the Registry coclass.

Dim O, R
Set O = CreateObject("Std.Registry")
Set R = CreateObject("Std.Arrays")
WScript.Echo R.ShowStructure( O.SearchTLIMethodsAndProperties( "MSSCRIPT.OCX",""))

Output from the demo (script was run in SciTE).

>cscript "C:\foo\foo.vbs"
{Add,AddCode,AddObject,AllowUI,Clear,CodeObject,Column,Count,Description,Error,Eval,ExecuteStatement,HasReturnValue,HelpContext,HelpFile,Item,Language,Line,Modules,Name,NumArgs,Number,Procedures,Reset,Run,SitehWnd,Source,State,Text,Timeout,UseSafeSubset}
>Exit code: 0

Finally, the VBA code. A cell has a symbol in it and this routine finds it or returns an error string. (reg. in this case refers to the Registry coclass in the StdLib.DLL)

Public Function LookupSymbol(sLib As String, sSym As String) As String
    Dim aRes As Variant
    aRes = reg.SearchTLIMethodsAndProperties(sLib, sSym)
    Dim i As Integer
    LookupSymbol = "!!NotFound!!"
    For i = 0 To UBound(aRes)
 If LCase$(aRes(i)) = LCase$(sSym) Then
     LookupSymbol = sSym
     Exit For
 End If
    Next
End Function