Attribute VB_Name = "utility"
Option Explicit

Private Declare Function GetDesktopWindow Lib "user32" () As Long    'DEV_STRING
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long    'DEV_STRING

Private Const BITSPIXEL = 12&

Private MainSec As Currency, MainSecOut As Currency
Private Sec As Currency, SecOut As Currency, secFreq As Currency
Private SecPause As Currency, SecSubtract As Currency

Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hWnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, source As Any, ByVal Length As Long)
Private Declare Function lstrlenA Lib "kernel32.dll" (ByVal lpString As Long) As Long
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As String

Public Const WM_GETMINMAXINFO As Long = &H24

Private Type POINTAPI
    X As Long
    y As Long
End Type

Private Type MINMAXINFO
    ptReserved As POINTAPI
    ptMaxSize As POINTAPI
    ptMaxPosition As POINTAPI
    ptMinTrackSize As POINTAPI
    ptMaxTrackSize As POINTAPI
End Type

Private Function FormWndProc(ByVal hwndMsg As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'initialize form object for looping through array, and variable
'to use in returning/passing resize values to window procedures
    Dim frm As Form
    Dim MMI As MINMAXINFO

    'do not propagate errors back to caller
    On Error Resume Next
    'loop through form collection to find form
    For Each frm In Forms
        '...if found...
        If frm.hWnd = hwndMsg Then
            '...determine window message received
            Select Case uMsg
                '...if resize message
                Case WM_GETMINMAXINFO
                    '...capture MINMAXINFO
                    CopyMemory MMI, ByVal lParam, LenB(MMI)
                    '...reset MINMAXINFO values from array data
                    MMI.ptMinTrackSize.X = frm.WidthMin
                    MMI.ptMinTrackSize.y = frm.HeightMin
                    MMI.ptMaxTrackSize.X = frm.WidthMax
                    MMI.ptMaxTrackSize.y = frm.HeightMax
                    '...replace MINMAXINFO
                    CopyMemory ByVal lParam, MMI, LenB(MMI)
                    '...return 0 - message has been handled
                    FormWndProc = 0
                Case Else
                    'for all other window messages:
                    'pass to original message handler
                    FormWndProc = CallWindowProc(frm.OrigWndProc, hwndMsg, uMsg, wParam, lParam)
            End Select

            '...no need to loop through remaining forms
            Exit For

        End If

    Next

End Function

Public Sub SubClassForm(frm As Form)

'do not propagate any errors back to the caller

    On Error Resume Next

    'return function pointer of default window procedure,

    'and replace it with function pointer of custom window proc

    frm.OrigWndProc = SetWindowLong(frm.hWnd, GWL_WNDPROC, AddressOf FormWndProc)

End Sub

Public Sub UnSubclassForm(frm As Form)
'...make sure form is currently subclassed, if not
'Forms OrigWndProc will contain 0, else a function pointer
    If frm.OrigWndProc Then
        '...restore default window procedure - pass function pointer
        SetWindowLong frm.hWnd, GWL_WNDPROC, frm.OrigWndProc
        '...reset forms OrigWndProc to 0 to show form is no longer subclassed
        frm.OrigWndProc = 0
    End If

End Sub

Public Function GetColorDepth() As Long
'Returns the supported color depth in bits (e.g. - 8 means only 256 colors are supported)

    Dim hWnd As Long
    Dim hDC  As Long

    On Error Resume Next

    hWnd = GetDesktopWindow()
    hDC = GetDC(hWnd)
    GetColorDepth = GetDeviceCaps(hDC, BITSPIXEL)
    Call ReleaseDC(hWnd, hDC)
End Function

Public Sub FudgeFocus(ByRef objPropertyGridFUDGE As PropertyGrid, ByVal v_lngLeft As Long)
' DO NOT ASK ME WHY THIS MAKES THE FOCUS WORK
' It was a stroke of luck that I noticed it - but for now - who cares.

    Dim oGridContext As PropertyGridUpdateContext

    Set oGridContext = objPropertyGridFUDGE.BeginUpdate
    objPropertyGridFUDGE.Left = v_lngLeft - 100
    objPropertyGridFUDGE.Width = 50
    objPropertyGridFUDGE.Categories.Clear
    objPropertyGridFUDGE.Visible = True
    objPropertyGridFUDGE.EndUpdate oGridContext
    objPropertyGridFUDGE.Visible = False
End Sub

Public Function PointerToString(p As Long) As String
    If p = 0 Then
        PointerToString = SA_VB_EmptyString
        Exit Function
    End If

    Dim c As Long
    c = lstrlenptr(ByVal p)
    If c = 0 Then
        PointerToString = SA_VB_EmptyString
        Exit Function
    End If

    Dim ac() As Byte
    ReDim ac(c)
    CopyMem ac(0), ByVal p, c
    PointerToString = szTruncate(StrConv(ac, vbUnicode))

End Function

Public Function szTruncate(sz As String) As String
    Dim i As Long
    i = InStr(1, sz, Chr(0))
    If i <> 0 Then
        szTruncate = Left(sz, i - 1)
    Else
        szTruncate = sz
    End If
End Function

Public Function ProcAddress(address As Long) As Long
    ProcAddress = address
End Function

#If OBJECTHISTORYDEBUG Then
Public Sub LogObjectHistory(msg As String)
' FOR MENU DECOUPLE DEBUGGING - remove eventually
    If MainSec = 0 Then ProfileStart MainSec

    On Error Resume Next

    Open GetExePath() & "\ObjectHistory.log" For Append Access Write Shared As #1    ' DEV_STRING
    '    Print #1, Now & " elapsed:" & LogMainGetTimer & " Ver:" & VersionString & " - " & msg 'DEV_STRING
    Print #1, msg

    Close #1
    On Error GoTo 0
End Sub
#End If

#If TOOLDEBUGGING Then
Public Sub LogMessageTools(msg As String)
    Dim strPath As String

' FOR MENU DECOUPLE DEBUGGING - remove eventually
    If MainSec = 0 Then ProfileStart MainSec

    On Error Resume Next

    strPath = GetExePath()
    Open strPath & SAXRes.GetLocalString(IDS_uloc_____toolslog) For Append Access Write Shared As #1
    '    Print #1, Now & " elapsed:" & LogMainGetTimer & " Ver:" & VersionString & " - " & msg 'DEV_STRING
    Print #1, msg

    Close #1

    On Error GoTo 0
End Sub
#End If

#If DOCKDEBUGGING Then
Public Sub LogMessageDock(msg As String)
    Dim strPath As String

' FOR MENU DECOUPLE DEBUGGING - remove eventually
    If MainSec = 0 Then ProfileStart MainSec

    On Error Resume Next

    strPath = GetExePath()
    Open strPath & SAXRes.GetLocalString(IDS_uloc_____docklog) For Append Access Write Shared As #1
    '    Print #1, Now & " elapsed:" & LogMainGetTimer & " Ver:" & VersionString & " - " & msg 'DEV_STRING
    Print #1, msg

    Close #1
    On Error GoTo 0
End Sub
#End If

Public Sub WriteSALog(msg As String)
End Sub

Public Sub LogMessage(msg As String)
End Sub

Public Sub QALogMessage(msg As String)
End Sub

Public Function LogMainGetTimer() As String
    ProfileStop MainSec, MainSecOut

    LogMainGetTimer = Format(MainSecOut, SAXRes.GetLocalString(IDS_uloc_____00000))

End Function

Private Sub ProfileStart(secStart As Currency)
    If secFreq = 0 Then QueryPerformanceFrequency secFreq
    QueryPerformanceCounter secStart
End Sub

Private Sub ProfileStop(secStart As Currency, secTiming As Currency)
    QueryPerformanceCounter secTiming
    If secFreq = 0 Then
        secTiming = 0    ' Handle no high-resolution timer
    Else
        secTiming = (secTiming - secStart) / secFreq
    End If
End Sub



Public Sub LogStartTimer()
    QueryPerformanceCounter Sec
    SecSubtract = 0
End Sub

Public Sub LogStatusTimer(sPrefix As String)
    Static secTiming As Currency
    QueryPerformanceCounter secTiming
    If secFreq = 0 Then
        secTiming = 0    ' Handle no high-resolution timer
    Else
        secTiming = (secTiming - Sec) / secFreq
    End If
    secTiming = secTiming - SecSubtract

    If CmdLineTiming Then
        Do_SetStatusString 1, sPrefix & Format(secTiming, SAXRes.GetLocalString(IDS_uloc_____0000)) & SAXRes.GetLocalString(IDS_sa2001utilitybas_____sec)
    Else
        LogMessage sPrefix & Format(secTiming, SAXRes.GetLocalString(IDS_uloc_____0000)) & SAXRes.GetLocalString(IDS_sa2001utilitybas_____sec)
    End If

End Sub

Public Sub LogTimerPause(bPause As Boolean)
    If bPause Then
        QueryPerformanceCounter SecPause
    Else
        Static secTiming As Currency
        QueryPerformanceCounter secTiming
        If secFreq = 0 Then
            secTiming = 0    ' Handle no high-resolution timer
        Else
            secTiming = (secTiming - SecPause) / secFreq
        End If
        SecSubtract = SecSubtract + secTiming
    End If
End Sub

Public Sub LogTraceMessage(LogString As String, ByVal LogFlags As Long)
' this routine is the interface to the main SADesign logger

' LogFlags: 0x00000001 Menu operation
'           0x00000002 Browser operation
'           0x00000100 Entering operation
'           0x00000200 Leaving operation

End Sub

Public Function GetTrueParentWindowHandle(hWndChild As Long) As Long
    Dim hParent As Long
    Dim hTemp As Long
    Dim bFound As Boolean

    hTemp = 0
    hParent = hWndChild
    bFound = False
    ' Find the TRUE parent of that window
    While (hParent <> 0 And Not bFound)
        hTemp = hParent

        If (GetWindowLong(hTemp, GWL_STYLE) And WS_CHILD) = 0 Then
            ' If the window is not a child then stop looking
            bFound = True
        Else
            hParent = GetWindowLong(hParent, GWL_HWNDPARENT)  ' Get the parent of this window
        End If
    Wend

    GetTrueParentWindowHandle = hParent
End Function

Function GetValidFileName(sOrig As String, sRepChar As String) As String
    Dim l_s_InvChar(10) As String
    Dim l_l_Pos As Long
    Dim l_l_Start As Long
    Dim l_l_Cnt As Long
    Dim l_b_Found As Boolean

    On Error GoTo ErrGetValidFileName

    l_s_InvChar(0) = "\"    'DEV_STRING
    l_s_InvChar(1) = "/"    'DEV_STRING
    l_s_InvChar(2) = ":"    'DEV_STRING
    l_s_InvChar(3) = "*"    'DEV_STRING
    l_s_InvChar(4) = "?"    'DEV_STRING
    l_s_InvChar(5) = Chr(34)    'The quote mark
    l_s_InvChar(6) = "<"    'DEV_STRING
    l_s_InvChar(7) = ">"    'DEV_STRING
    l_s_InvChar(8) = "|"    'DEV_STRING
    l_s_InvChar(9) = Chr(13)    'DEV_STRING
    l_s_InvChar(10) = Chr(10)    'DEV_STRING

    For l_l_Cnt = LBound(l_s_InvChar()) To UBound(l_s_InvChar())
        l_b_Found = True
        l_l_Start = 1
        Do While l_b_Found
            l_l_Pos = InStr(l_l_Start, sOrig, l_s_InvChar(l_l_Cnt))
            If l_l_Pos > 0 Then
                ' including l_l_Cnt to try to keep filename unique
                sOrig = Left(sOrig, l_l_Pos - 1) & sRepChar & Format(l_l_Cnt) & Mid(sOrig, l_l_Pos + 1)
                l_l_Start = l_l_Pos + 1
            Else
                l_b_Found = False
            End If
        Loop
    Next

    GetValidFileName = sOrig

    Exit Function

ErrGetValidFileName:
    GetValidFileName = SA_VB_EmptyString
End Function

Public Function MetafileToPicture(ByVal hMeta As Long, _
                                  ByVal xExt As Integer, _
                                  ByVal yExt As Integer, _
                                  Optional fOld As Boolean = True) As IPicture
    If hMeta = hNull Then Exit Function
    Dim ipic As IPicture, picdes As PICTDESCMETA
    Dim IID_IDispatch As GUID
    Dim MFError As Long

    ' Fill in with IDispatch Interface ID.
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    ' Fill picture description (assume enhanced)
    picdes.cbSizeofstruct = Len(picdes)
    If fOld Then
        picdes.picType = vbPicTypeMetafile
    Else
        picdes.picType = vbPicTypeEMetafile
    End If
    picdes.hMeta = hMeta
    picdes.xExt = xExt
    picdes.yExt = yExt

    ' Create picture from icon handle
    MFError = OleCreatePictureIndirectMeta(picdes, IID_IDispatch, True, ipic)
    If MFError <> 0 Then
        Set ipic = Nothing
    End If

    ' Result will be valid Picture or Nothing--either way set it
    Set MetafileToPicture = ipic
End Function

Public Function BitmapToPicture(ByVal hBitmap As Long, _
                                ByVal hPallette As Long) As IPicture
    If hBitmap = hNull Then Exit Function
    Dim ipic As IPicture, picdes As PICTDESCBMP
    Dim IID_IDispatch As GUID
    Dim MFError As Long

    ' Fill in with IDispatch Interface ID.
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    ' Fill picture description (assume enhanced)
    picdes.cbSizeofstruct = Len(picdes)
    picdes.picType = vbPicTypeBitmap
    picdes.hBitmap = hBitmap
    picdes.hPal = hPallette

    ' Create picture from icon handle
    MFError = OleCreatePictureIndirectBmp(picdes, IID_IDispatch, True, ipic)
    If MFError <> 0 Then
        Set ipic = Nothing
    End If

    ' Result will be valid Picture or Nothing--either way set it
    Set BitmapToPicture = ipic
End Function

Public Sub LogToolUse(ByVal strTool As String)

'Used by CEP to track how often a tool is used

    Dim lCount As Long

    On Error GoTo ErrorHandler

    If fMainForm.CEPDisabled Then
        Exit Sub
    End If

    lCount = CLng(GetSetting(SAXRes.GetLocalString(IDS_uloc_____sa__), "ToolUsage", strTool, 0))    'DEV_STRING
    lCount = lCount + 1
    SaveSetting SAXRes.GetLocalString(IDS_uloc_____sa__), "ToolUsage", strTool, Format$(lCount)    'DEV_STRING

    Exit Sub

ErrorHandler:

End Sub

Public Function CStr_English(ByVal v_varIn As Variant) As String
    If VarType(v_varIn) = vbBoolean Then
        If v_varIn Then
            CStr_English = "True"    'DEV_STRING
        Else
            CStr_English = "False"    'DEV_STRING
        End If
    Else
        CStr_English = CStr(v_varIn)
    End If
End Function

Public Function CBool_English(ByVal v_varIn As Variant) As Boolean
    If VarType(v_varIn) = vbString Then
        If LCase(v_varIn) = "true" Then    'DEV_STRING
            CBool_English = True
        Else
            CBool_English = False
        End If
    Else
        CBool_English = CBool(v_varIn)
    End If
End Function

' RE CR25578 - Val was being used on C symbol field values returned as '0x...'
' Val will cope with '&H...'
Public Function ConvertCHexStringToVB(ByVal v_str As String) As String
    Dim strRet As String

    If LCase$(Left$(v_str, 2)) = "0x" Then    ' DEV_STRING
        strRet = "&H" & Mid$(v_str, 3)
    Else
        If UCase$(Left$(v_str, 2)) <> "&H" Then
            ' We've been passed a string with no C style marker or VB style one - so slap a VB style one on
            strRet = "&H" & v_str
        Else
            ' Already VB format
            strRet = v_str
        End If
    End If

    ConvertCHexStringToVB = strRet
End Function

Public Function ConvertVBHexStringToC(ByVal v_str As String) As String
    Dim strRet As String

    If UCase$(Left$(v_str, 2)) = "&H" Then    ' DEV_STRING
        strRet = "0x" & Mid$(v_str, 3)
    Else
        If LCase$(Left$(v_str, 2)) <> "0x" Then
            ' We've been passed a string with no VB style marker or C style one - so slap a C style one on
            strRet = "0x" & v_str
        Else
            ' Already C format
            strRet = v_str
        End If
    End If

    ConvertVBHexStringToC = strRet
End Function

#If DRAGCHECK Then
Public Sub LogMessageDragCheck(msg As String)

    On Error Resume Next

    Open GetExePath() & "\DragCheck.log" For Append Access Write Shared As #1
    Print #1, msg

    Close #1
    On Error GoTo 0
End Sub
#End If

Public Function OpenEmail(ByVal strEmailAddress As String, Optional ByVal strSubject As String, Optional ByVal strBody As String) As Boolean

'Creates a new email using the default email app

    Dim lWindow As Long
    Dim lRet As Long
    Dim strParams As String

    On Error GoTo ErrorHandler

    strParams = strEmailAddress
    If LCase$(Left(strParams, 7)) <> "mailto:" Then    'DEV_STRING
        strParams = "mailto:" & strParams    'DEV_STRING
    End If

    If strSubject <> vbNullString Then
        strParams = strParams & "?subject=" & strSubject    'DEV_STRING
    End If

    If strBody <> vbNullString Then
        strParams = strParams & IIf(strSubject = vbNullString, "?", "&")    'DEV_STRING
        strParams = strParams & "body=" & strBody    'DEV_STRING
    End If

    lRet = ShellExecute(lWindow, "open", strParams, vbNullString, vbNullString, SW_SHOWNORMAL)  'DEV_STRING

    'If shell execute fails the return code will be 32 or lower
    OpenEmail = (lRet > 32)

    Exit Function

ErrorHandler:
    MsgBox Err.Description & vbCrLf & vbCrLf & SAXRes.GetLocalString(IDS_sa2001frmfeedbackfrm_____code) & Err.Number, vbExclamation, SAXRes.GetLocalString(IDSProductName)

End Function

Public Function OpenLocation(ByVal strURL As String) As Boolean

'Open a web page using the default web browser

    Dim lWindow As Long
    Dim lRet As Long

    On Error GoTo ErrorHandler

    lRet = ShellExecute(lWindow, "open", strURL, vbNullString, vbNullString, SW_SHOWNORMAL)    'DEV_STRING

    'If shell execute fails the return code will be 32 or lower
    OpenLocation = (lRet > 32)

    Exit Function

ErrorHandler:
    MsgBox Err.Description & vbCrLf & vbCrLf & SAXRes.GetLocalString(IDS_sa2001frmfeedbackfrm_____code) & Err.Number, vbExclamation, SAXRes.GetLocalString(IDSProductName)

End Function

Public Function MajorType(ByVal lngClass As Long) As String
    Select Case lngClass
        Case 1
            MajorType = SAXRes.GetLocalString(IDS_sa2001utilitybas_____diagram)
        Case 2
            MajorType = SAXRes.GetLocalString(IDS_sa2001utilitybas_____symbol)
        Case 3
            MajorType = SAXRes.GetLocalString(IDS_sa2001utilitybas_____definition)
    End Select
End Function

Public Function MajorTypeID(ByVal strClass As String) As Long
    Select Case strClass
        Case SAXRes.GetLocalString(IDS_sa2001utilitybas_____diagram)
            MajorTypeID = 1
        Case SAXRes.GetLocalString(IDS_sa2001utilitybas_____symbol)
            MajorTypeID = 2
        Case SAXRes.GetLocalString(IDS_sa2001utilitybas_____definition)
            MajorTypeID = 3
    End Select
End Function

Public Function SALoadResPicture(ByVal v_lngID As Long, ByVal v_lngResType As Long) As IPictureDisp
    Dim strResID As String

    If strIconBaseName = "ORG" Then    'DEV_STRING
        On Error Resume Next
        Set SALoadResPicture = LoadResPicture(v_lngID, v_lngResType)
    Else
        strResID = strIconBaseName & CStr(v_lngID)
        On Error Resume Next
        Set SALoadResPicture = LoadResPicture(strResID, v_lngResType)
        If SALoadResPicture Is Nothing Then
            ' Failed to load an alternative, use the original
            Set SALoadResPicture = LoadResPicture(v_lngID, v_lngResType)
        End If
    End If
End Function

Public Sub RefreshBrowserInternal()
End Sub

Public Sub CheckEnableWorkspaceTools()
End Sub

Private Function ParentNodeCount(ByRef r_objNode As IXMLDOMNode) As Long
    Dim objNode As IXMLDOMNode
    Dim lngParentCount As Long

    Set objNode = r_objNode
    lngParentCount = 0

    While Not objNode.parentNode Is Nothing
        Set objNode = objNode.parentNode
        lngParentCount = lngParentCount + 1
    Wend

    ParentNodeCount = lngParentCount
End Function

Public Function FindCommonWorkspaceParent(ByRef dom As DOMDocument, ByVal v_strSourceWS As String, ByVal v_strTargetWS As String) As String
    Dim objSourceNode As IXMLDOMNode
    Dim objTargetNode As IXMLDOMNode
    Dim lngSourceAncestors As Long
    Dim lngTargetAncestors As Long

    On Error GoTo ErrHandler
    Set objSourceNode = dom.selectSingleNode("//Workspace[@ID='" & v_strSourceWS & "']")    ' DEV_STRING
    Set objTargetNode = dom.selectSingleNode("//Workspace[@ID='" & v_strTargetWS & "']")    ' DEV_STRING

    lngSourceAncestors = ParentNodeCount(objSourceNode)
    lngTargetAncestors = ParentNodeCount(objTargetNode)

    ' only executed if target depth greater
    While lngTargetAncestors > lngSourceAncestors
        Set objTargetNode = objTargetNode.parentNode
        lngTargetAncestors = lngTargetAncestors - 1
    Wend

    ' only executed if source depth greater
    While lngSourceAncestors > lngTargetAncestors
        Set objSourceNode = objSourceNode.parentNode
        lngSourceAncestors = lngSourceAncestors - 1
    Wend

    While Not objSourceNode Is objTargetNode
        Set objSourceNode = objSourceNode.parentNode
        Set objTargetNode = objTargetNode.parentNode
    Wend

    FindCommonWorkspaceParent = objSourceNode.Attributes.getNamedItem("ID").Text

    Exit Function
ErrHandler:
    FindCommonWorkspaceParent = ""
End Function

Public Function WorkspaceNameFromID(ByRef r_dom As DOMDocument, ByVal v_lngID As Long) As String
End Function


' Needed because of code shared with saadoiovb2
Public Sub setTimeouts(ByRef r_con As Connection)
    ' Do nothing
End Sub


' Returns a copy of a null-terminated ANSI string (LPSTR/LPCSTR) from the given pointer
Public Function GetStrFromPtrA(ByVal Ptr As Long) As String
    GetStrFromPtrA = SysAllocStringByteLen(Ptr, lstrlenA(Ptr))
    ' .. and you don't need to worry about freeing it
    ' ref https://www.vbforums.com/showthread.php?817423-BSTR2LPSTR-and-LPSTR2BSTR-conversions-for-VB6
End Function

Public Sub BSTR2LPSTR(ByVal BSTR As String, ByVal LPSTR As Long)
    Dim str() As Byte
    str() = StrConv(BSTR & vbNullChar, vbFromUnicode)
    CopyMemory ByVal LPSTR, str(0), UBound(str) + 1
    ' ref https://www.vbforums.com/showthread.php?817423-BSTR2LPSTR-and-LPSTR2BSTR-conversions-for-VB6
End Sub

''' Testing GetStrFromPtrA and BSTR2LPSTR
    ' ref https://www.vbforums.com/showthread.php?817423-BSTR2LPSTR-and-LPSTR2BSTR-conversions-for-VB6
'Sub Main()
'    Dim a As String
'    Dim b() As Byte
'    Dim ptrb As Long
'    Dim c As String
'    Dim n As Long
'
'    ReDim b(255)
'    ptrb = VarPtr(b(0))
'
'    a = "This is a test."
'
'    BSTR2LPSTR a, ptrb
'    c = GetStrFromPtrA(ptrb) ' LPSTR2BSTR(ptrb)
'
'    Debug.Print a
'    For n = 0 To 255
'        If b(n) = 0 Then Exit For
'        Debug.Print Chr$(b(n));
'    Next n
'    Debug.Print ""
'    Debug.Print c
'    Debug.Print Len(a)
'    Debug.Print UBound(b) + 1
'    Debug.Print Len(c)
'End Sub
'''

' Assumes both are open, reads input from current position, writes to current position in output
Public Function ADODBStreamAppendFromFile(ByRef StrmIn As ADODB.Stream, ByRef StrmOut As ADODB.Stream) As Integer
    If StrmIn Is Nothing Or StrmOut Is Nothing Then
        Exit Function
    End If
    
    Dim str As String
    
    While Not StrmIn.EOS
        str = StrmIn.ReadText(10000)
        StrmOut.WriteText str
    Wend
End Function
