Attribute VB_Name = "VB6Compatibility"
' VB6 Compatibility Module
' These are the "new" VB6 functions, supposedly worth $200 :).
' Module compiled by
'          Brian W. Bosh
'          bbosh2200@yahoo.com
'          www.altint.com
'          I DID NOT write any of this code. I've found it all. Other
'          then changing lines with _ ending to put on one line (personal
'          preference) I've left them exactly the way they were found.
'
' Some of the functions are dependent on other [private] functions contained within
' this module. Also, both code size and execution speed were considered. No functions
' requiring a TLB were included. This is larger then I would like, but the speed
' advantage is just to great!
          

'This declare is for INSTRREV
Private Declare Sub PokeLng Lib "kernel32" Alias "RtlMoveMemory" (ByVal Addr As Long, Value As Long, Optional ByVal Bytes As Long = 4)

' These are for JOIN
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDst As Any, pSrc As Any, ByVal ByteLen As Long)
Private Declare Function SysAllocStringByteLen Lib "oleaut32.dll" (ByVal lpstr As Long, ByVal ByteLen As Long) As Long
' This is for SPLI
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (dst As Any, ByVal iLen&)



Public Function Split(Expression As String, Optional Delimiter As String = " ", Optional Count As Long = -1, Optional Compare As VbCompareMethod = vbBinaryCompare)

' by G.Beckmann, G.Beckmann@NikoCity.de

    Const ARR_CHUNK& = 1024

    Dim pArr&, pResult&, asResult$()
    Dim iLen&, cHits&, iLast&, iCur&

    If Count <> 0 Then
        iLen = Len(Delimiter)
        ReDim asResult(ARR_CHUNK)
        If iLen <> 0 Then
            iLast = 1
            iCur = InStr(iLast, Expression, Delimiter, Compare)
            Do While iCur
                If cHits + 1 = Count Then Exit Do

                asResult(cHits) = Mid$(Expression, iLast, iCur - iLast)
                iLast = iCur + iLen: cHits = cHits + 1
                iCur = InStr(iLast, Expression, Delimiter, Compare)

                If cHits > UBound(asResult) Then
                    ReDim Preserve asResult(cHits + ARR_CHUNK - 1)
                End If
            Loop
            asResult(cHits) = Mid$(Expression, iLast)
        Else
            asResult(0) = Expression
        End If
    End If
    ReDim Preserve asResult(cHits)              ' shrink to actual size

    '/ delivery an array without duplication
    pResult = VarPtr(Split02)
    CopyMemory ByVal pResult, &H2008, 2         ' initialize (Variant/String())
    pArr = StrArrPtr(asResult)                  ' get array-pointer
    CopyMemory ByVal pResult + 8, ByVal pArr, 4 ' copy safearray-pointer
    ZeroMemory ByVal pArr, 4                    ' delete safearray-pointer
End Function



Public Function Replace(ByRef Text As String, ByRef sOld As String, ByRef sNew As String, Optional ByVal Start As Long = 1, Optional ByVal Count As Long = 2147483647, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As String
' by Jost Schwider, jost@schwider.de, 20001218

  If LenB(sOld) Then

    If Compare = vbBinaryCompare Then
      Replace09Bin Replace09, Text, Text, _
          sOld, sNew, Start, Count
    Else
      Replace09Bin Replace09, Text, LCase$(Text), _
          LCase$(sOld), sNew, Start, Count
    End If

  Else 'Suchstring ist leer:
    Replace09 = Text
  End If
End Function

Private Static Sub Replace09Bin(ByRef result As String, ByRef Text As String, ByRef Search As String, ByRef sOld As String, ByRef sNew As String, ByVal Start As Long, ByVal Count As Long)
' by Jost Schwider, jost@schwider.de, 20001218
  Dim TextLen As Long
  Dim OldLen As Long
  Dim NewLen As Long
  Dim ReadPos As Long
  Dim WritePos As Long
  Dim CopyLen As Long
  Dim Buffer As String
  Dim BufferLen As Long
  Dim BufferPosNew As Long
  Dim BufferPosNext As Long
  
  'Ersten Treffer bestimmen:
  If Start < 2 Then
    Start = InStrB(Search, sOld)
  Else
    Start = InStrB(Start + Start - 1, Search, sOld)
  End If
  If Start Then
  
    OldLen = LenB(sOld)
    NewLen = LenB(sNew)
    Select Case NewLen
    Case OldLen 'einfaches Überschreiben:
    
      result = Text
      For Count = 1 To Count
        MidB$(result, Start) = sNew
        Start = InStrB(Start + OldLen, Search, sOld)
        If Start = 0 Then Exit Sub
      Next Count
      Exit Sub
    
    Case Is < OldLen 'Ergebnis wird kürzer:
    
      'Buffer initialisieren:
      TextLen = LenB(Text)
      If TextLen > BufferLen Then
        Buffer = Text
        BufferLen = TextLen
      End If
      
      'Ersetzen:
      ReadPos = 1
      WritePos = 1
      If NewLen Then
      
        'Einzufügenden Text beachten:
        For Count = 1 To Count
          CopyLen = Start - ReadPos
          If CopyLen Then
            BufferPosNew = WritePos + CopyLen
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
            MidB$(Buffer, BufferPosNew) = sNew
            WritePos = BufferPosNew + NewLen
          Else
            MidB$(Buffer, WritePos) = sNew
            WritePos = WritePos + NewLen
          End If
          ReadPos = Start + OldLen
          Start = InStrB(ReadPos, Search, sOld)
          If Start = 0 Then Exit For
        Next Count
      
      Else
      
        'Einzufügenden Text ignorieren (weil leer):
        For Count = 1 To Count
          CopyLen = Start - ReadPos
          If CopyLen Then
            MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
            WritePos = WritePos + CopyLen
          End If
          ReadPos = Start + OldLen
          Start = InStrB(ReadPos, Search, sOld)
          If Start = 0 Then Exit For
        Next Count
      
      End If
      
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        result = LeftB$(Buffer, WritePos - 1)
      Else
        MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
        result = LeftB$(Buffer, WritePos + LenB(Text) - ReadPos)
      End If
      Exit Sub
    
    Case Else 'Ergebnis wird länger:
    
      'Buffer initialisieren:
      TextLen = LenB(Text)
      BufferPosNew = TextLen + NewLen
      If BufferPosNew > BufferLen Then
        Buffer = Space$(BufferPosNew)
        BufferLen = LenB(Buffer)
      End If
      
      'Ersetzung:
      ReadPos = 1
      WritePos = 1
      For Count = 1 To Count
        CopyLen = Start - ReadPos
        If CopyLen Then
          'Positionen berechnen:
          BufferPosNew = WritePos + CopyLen
          BufferPosNext = BufferPosNew + NewLen
          
          'Ggf. Buffer vergrößern:
          If BufferPosNext > BufferLen Then
            Buffer = Buffer & Space$(BufferPosNext)
            BufferLen = LenB(Buffer)
          End If
          
          'String "patchen":
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos, CopyLen)
          MidB$(Buffer, BufferPosNew) = sNew
        Else
          'Position bestimmen:
          BufferPosNext = WritePos + NewLen
          
          'Ggf. Buffer vergrößern:
          If BufferPosNext > BufferLen Then
            Buffer = Buffer & Space$(BufferPosNext)
            BufferLen = LenB(Buffer)
          End If
          
          'String "patchen":
          MidB$(Buffer, WritePos) = sNew
        End If
        WritePos = BufferPosNext
        ReadPos = Start + OldLen
        Start = InStrB(ReadPos, Search, sOld)
        If Start = 0 Then Exit For
      Next Count
      
      'Ergebnis zusammenbauen:
      If ReadPos > TextLen Then
        result = LeftB$(Buffer, WritePos - 1)
      Else
        BufferPosNext = WritePos + TextLen - ReadPos
        If BufferPosNext < BufferLen Then
          MidB$(Buffer, WritePos) = MidB$(Text, ReadPos)
          result = LeftB$(Buffer, BufferPosNext)
        Else
          result = LeftB$(Buffer, WritePos - 1) & MidB$(Text, ReadPos)
        End If
      End If
      Exit Sub
    
    End Select
  
  Else 'Kein Treffer:
    result = Text
  End If
End Sub



Public Function StrReverse03(sExpression As String) As String
' by Donald, donald@xbeat.net, 20000913
  Dim i As Long
  Dim ubArr As Long
  Dim arrByte() As Byte
  Dim arrByteRev() As Byte
  
  If Len(sExpression) Then
    
    ' no need to ReDim
    arrByte = sExpression
    ubArr = UBound(arrByte)
    ReDim arrByteRev(ubArr)
    
    ' Step 2: it's Unicode
    For i = 0 To ubArr Step 2
      ' set double bytes pairwise
      ' eg. pos 01 = 67, 23 = 45, 45 = 23, 67 = 01
      arrByteRev(i) = arrByte(ubArr - i - 1)
      arrByteRev(i + 1) = arrByte(ubArr - i)
    Next
  
    StrReverse03 = arrByteRev
  
  End If
  
End Function


Public Function InStrRev(ByRef sCheck As String, ByRef sMatch As String, Optional ByVal Start As Long, Optional ByVal Compare As VbCompareMethod = vbBinaryCompare) As Long
' by Jost Schwider, jost@schwider.de, 20001218
  Dim Stopp As Long
  Dim Index As Long
  Dim Pivot As Long
  Dim Length As Long
  Dim LengthPtr As Long
  Dim MatchLen As Long
  
  If Compare = vbBinaryCompare Then
    MatchLen = LenB(sMatch) - 1
    If MatchLen > -1 Then
    
      'Linke Grenze bestimmen:
      Stopp = InStrB(sCheck, sMatch)
      If Stopp = 0 Then Exit Function
      
      'Rechte Grenze bestimmen:
      Length = LenB(sCheck)
      If Start <= 0 Then
        Start = Length - MatchLen
        LengthPtr = StrPtr(sCheck) - 4
      Else
        Start = Start + Start - MatchLen
        If Stopp > Start Then Exit Function
        LengthPtr = StrPtr(sCheck) - 4
        PokeLng LengthPtr, Start + MatchLen
      End If
      
      'Ersten Treffer merken:
      InStrRev06 = Stopp
      Stopp = Stopp + 2
      
      'Binäre Suche / Intervall-Halbierungs-Verfahren:
      Do
        'Ab Mitte testen:
        Pivot = (Stopp + Start) \ 2
        Index = InStrB(Pivot, sCheck, sMatch)
        
        'Treffer?
        If Index Then
          InStrRev06 = Index
          If Index >= Start Then
            PokeLng LengthPtr, Length
            InStrRev06 = InStrRev06 \ 2 + 1
            Exit Function
          End If
          Stopp = Index + 2
        Else
          If Stopp + 8 >= Pivot Then Exit Do
          Start = Pivot - 1
          PokeLng LengthPtr, Start + MatchLen
        End If
      Loop
      
      'Konventionell weiter machen:
      Index = InStrB(Stopp, sCheck, sMatch)
      Do While Index
        InStrRev06 = Index
        Index = InStrB(Index + 2, sCheck, sMatch)
      Loop
      InStrRev06 = InStrRev06 \ 2 + 1
      PokeLng LengthPtr, Length
    
    Else
      If Start <= Len(sCheck) Then InStrRev06 = Start
    End If
  Else
    InStrRev06 = InStrRev06(LCase$(sCheck), LCase$(sMatch), Start)
  End If
End Function

Public Function Filter(sSourceArray() As String, sMatch As String, sTargetArray() As String, Optional bInclude As Boolean = True, Optional lCompare As VbCompareMethod = vbBinaryCompare) As Long
 
' by Donald, donald@xbeat.net, 20000918
' Modified by Keith, kmatzen@ispchannel.com
' returns Ubound(sTargetArray), or -1 if sTargetArray is not bound (empty array)
    
   Dim lNdx      As Long
   Dim lLo       As Long
   Dim lHi       As Long
   Dim lLenMatch As Long
   
   lLenMatch = Len(sMatch)
   lLo = LBound(sSourceArray)
   lHi = UBound(sSourceArray)
   ReDim sTargetArray(lHi - lLo) 'make maximal space
   
   FilterB02 = -1
   
   If lLenMatch Then
      If bInclude Then              'Need a match
         For lNdx = lLo To lHi
            If Len(sSourceArray(lNdx)) >= lLenMatch Then
               If InStr(1, sSourceArray(lNdx), sMatch, lCompare) Then
                  FilterB02 = FilterB02 + 1
                  sTargetArray(FilterB02) = sSourceArray(lNdx)
               End If
            End If
         Next
      Else                          'Need a mismatch
         For lNdx = lLo To lHi
            Select Case Len(sSourceArray(lNdx))
               Case Is < lLenMatch 'Can't match
                  FilterB02 = FilterB02 + 1
                  sTargetArray(FilterB02) = sSourceArray(lNdx)
               Case Else
                  If InStr(1, sSourceArray(lNdx), sMatch, lCompare) = 0 Then
                     FilterB02 = FilterB02 + 1
                     sTargetArray(FilterB02) = sSourceArray(lNdx)
                  End If
            End Select
         Next
      End If
   ElseIf bInclude Then             'Include all
      For lNdx = lLo To lHi
         FilterB02 = FilterB02 + 1
         sTargetArray(FilterB02) = sSourceArray(lNdx)
      Next
   End If
   
   ' erase or shrink
   If FilterB02 = -1 Then
      Erase sTargetArray
   Else
      ReDim Preserve sTargetArray(FilterB02)
   End If
    
End Function

Public Function Join(SourceArray() As String, Optional Delimiter As String = " ", Optional ByVal Count As Long = -1) As String

' by Matt Curland, mattcur@microsoft.com, www.PowerVB.com, 20001001
' [org. name Join7, slight adjustments to our definition by Donald]

' Works with VB- or typelib-declared CopyMemory (pass strings with StrPtr)
    Dim Lower As Long
    Dim Upper As Long
    Dim cbDelim As Long
    Dim cbTotal As Long
    Dim i As Long
    Dim pCurDest As Long
    Dim pDelim As Long
    Dim cbCur As Long
    
    Lower = LBound(SourceArray)
    If Count = -1 Then
        Upper = UBound(SourceArray)
    Else
        Upper = Lower + Count - 1
    End If
    For i = Lower To Upper
        cbTotal = cbTotal + LenB(SourceArray(i))
    Next i
    cbDelim = LenB(Delimiter)
    If cbDelim Then cbTotal = cbTotal + cbDelim * (Upper - Lower)
    
    'Use API to avoid useless initialization
    CopyMemory ByVal VarPtr(Join08), SysAllocStringByteLen(0, cbTotal), 4
    'Use this instead if APIs are typelib-declared:
    ''Join08 = SysAllocStringByteLen(0, cbTotal)
    
    'Now, split into two different paths
    'a) No delimiter
    'b) Delimiter
    pCurDest = StrPtr(Join08)
    If cbDelim = 0 Then
        For i = Lower To Upper
            cbCur = LenB(SourceArray(i))
            CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), cbCur
            pCurDest = pCurDest + cbCur
        Next i
    Else
        pDelim = StrPtr(Delimiter)
        For i = Lower To Upper - 1
            cbCur = LenB(SourceArray(i))
            CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), cbCur
            pCurDest = pCurDest + cbCur
            CopyMemory ByVal pCurDest, ByVal pDelim, cbDelim
            pCurDest = pCurDest + cbDelim
        Next i
        CopyMemory ByVal pCurDest, ByVal StrPtr(SourceArray(i)), LenB(SourceArray(i))
    End If
End Function

Public Static Function Round(dblNumber As Double, Optional ByVal numDecimalPlaces As Long) As Double
' by Donald, donald@xbeat.net, 20001018
  
  Dim fInit As Boolean
  Dim numDecimalPlacesPrev As Long
  Dim dFac As Double
  Dim dFacInv As Double
  Dim dTmp As Double
  
  ' calc factor once for this depth of rounding
  If Not fInit Or numDecimalPlacesPrev <> numDecimalPlaces Then
    dFac = 10 ^ numDecimalPlaces
    dFacInv = 10 ^ -numDecimalPlaces
    numDecimalPlacesPrev = numDecimalPlaces
    fInit = True
  End If
  
  If dblNumber >= 0 Then
    dTmp = dblNumber * dFac + 0.5
    Round10 = Int(dTmp) * dFacInv
  Else
    dTmp = -dblNumber * dFac + 0.5
    Round10 = -Int(dTmp) * dFacInv
  End If
  
End Function

Private Function StrArrPtr&(v)
    CopyMemory StrArrPtr, ByVal VarPtr(v) + 8, 4
End Function

Public Sub SplitB03(Expression$, ResultSplit$(), Optional Delimiter$ = " ")
' by G.Beckmann, G.Beckmann@NikoCity.de
 
    Dim c&, iLen&, iLast&, iCur&
    
    iLen = Len(Delimiter)
    
    If iLen Then
        
        '/ count delimiters
        iCur = InStr(Expression, Delimiter)
        Do While iCur
            iCur = InStr(iCur + iLen, Expression, Delimiter)
            c = c + 1
        Loop
        
        '/ initalization
        ReDim Preserve ResultSplit(0 To c)
        c = 0: iLast = 1
        
        '/ search again...
        iCur = InStr(Expression, Delimiter)
        Do While iCur
            ResultSplit(c) = Mid$(Expression, iLast, iCur - iLast)
            iLast = iCur + iLen
            iCur = InStr(iLast, Expression, Delimiter)
            c = c + 1
        Loop
        ResultSplit(c) = Mid$(Expression, iLast)
        
    Else
        ReDim Preserve ResultSplit(0 To 0)
        ResultSplit(0) = Expression
    End If
 
End Sub