' by Donald, donald@xbeat.net, 20011209
' needs BStrApi.tlb (BStrAPI - Guido's VB-Speed API-Interface)

Option Explicit

' VB5 -> msvbvm50.dll
Private Declare Function ArrPtr& Lib "msvbvm60.dll" Alias "VarPtr" (ptr() As Any)
Private Declare Sub RtlMoveMemory Lib "kernel32" (dst As Any, src As Any, ByVal nBytes&)
Private Declare Sub RtlZeroMemory Lib "kernel32" (dst As Any, ByVal nBytes&)

' under Win95/98 the code for CharLowerBuffW/CharUpperBuffW is stubbed out
' if you got NT/2000 tell me whether it works!
Private Declare Function CharLowerBuffW& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CharUpperBuffW& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CharLowerBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)
Private Declare Function CharUpperBuffA& Lib "user32" (lpsz As Any, ByVal cchLength&)

Private aSrc() As Integer, saSrc As BStrAPI.SafeArray1D
Private aDst() As Integer, saDst As BStrAPI.SafeArray1D
Private aLChars(&H8000 To &H7FFF) As Integer
Private aUChars(&H8000 To &H7FFF) As Integer
    
Private Sub Class_Initialize()
  Dim c As Long
  Dim ret As Long
  
  saSrc.cDims = 1
  saSrc.cbElements = 2
  saSrc.cElements1D = &H7FFFFFFF
                 RtlMoveMemory ByVal ArrPtr(aSrc), VarPtr(saSrc), 4
  saDst = saSrc: RtlMoveMemory ByVal ArrPtr(aDst), VarPtr(saDst), 4
  
  ' init LCase LUT
  For c = -32768 To 32767: aLChars(c) = c: Next
  If CharLowerBuffW(aLChars(-32768), &H10000) = 0 Then
    ' for 0 to 255 CharUpperBuffA <=> Asc(UCase$(Chr$(c)))
    ret = CharLowerBuffA(aLChars(0), 256 * 2)  '2 bytes/char
  End If
  ' patch the stooges
  '  138/352    154/353
  '  140/338    156/339
  '  142/381    158/382
  '  159/376    255/255
  aLChars(352) = 353
  aLChars(338) = 339
  aLChars(381) = 382
  aLChars(376) = 255
  
  ' init UCase LUT
  For c = -32768 To 32767: aUChars(c) = c: Next
  If CharUpperBuffW(aUChars(-32768), &H10000) = 0 Then
    ' if W-API does not work let's go for the ANSI set
    ' for 0 to 255 CharUpperBuffA <=> Asc(UCase$(Chr$(c)))
    ret = CharUpperBuffA(aUChars(0), 256 * 2)  '2 bytes/char
  End If
  ' patch the stooges
  '  154/353    138/352
  '  156/339    140/338
  '  158/382    142/381
  '  255/255    159/376
  aUChars(353) = 352
  aUChars(339) = 338
  aUChars(382) = 381
  aUChars(255) = 376
End Sub

Private Sub Class_Terminate()
  ' clear the fake array pointers before VB does
  RtlZeroMemory ByVal ArrPtr(aSrc), 4
  RtlZeroMemory ByVal ArrPtr(aDst), 4
End Sub

Friend Function UCase04(ByRef sString As String) As String
' by Donald, donald@xbeat.net, 20011209
  Dim c As Long
  Dim lLen As Long
  
  lLen = Len(sString)
  UCase04 = BStrAPI.SysAllocStringLenPtr(ByVal 0&, lLen)
  
  saSrc.pvData = StrPtr(sString)
  saDst.pvData = StrPtr(UCase04)
  
  For c = 0 To lLen - 1
    aDst(c) = aUChars(aSrc(c))
  Next
    
End Function

Friend Function LCase04(ByRef sString As String) As String
' by Donald, donald@xbeat.net, 20011209
  Dim c As Long
  Dim lLen As Long
  
  lLen = Len(sString)
  LCase04 = BStrAPI.SysAllocStringLenPtr(ByVal 0&, lLen)
  
  saSrc.pvData = StrPtr(sString)
  saDst.pvData = StrPtr(LCase04)
  
  For c = 0 To lLen - 1
    aDst(c) = aLChars(aSrc(c))
  Next
  
End Function

Friend Function LCase05(ByRef sString As String) As String
' by Paul, wpsjr1@syix.com, 20011209
  Dim lLen As Long
  
  lLen = Len(sString)
  LCase05 = FastString.SysAllocStringLenBstr(sString, lLen)
  saDst.pvData = StrPtr(LCase05)

  Do While lLen
    lLen = lLen - 1
    aDst(lLen) = aLChars(aDst(lLen))
  Loop
End Function

Friend Function UCase05(ByRef sString As String) As String
' by Paul, wpsjr1@syix.com, 20011209
  Dim lLen As Long
  
  lLen = Len(sString)
  UCase05 = FastString.SysAllocStringLenBstr(sString, lLen)
  saDst.pvData = StrPtr(UCase05)
  
  Do While lLen
    lLen = lLen - 1
    aDst(lLen) = aUChars(aDst(lLen))
  Loop
End Function