vbAccelerator - Contents of code file: cStringPointer.cls

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "cStringPointer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Private Declare Function LocalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal
 wBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function LocalUnlock Lib "kernel32" (ByVal hMem As Long) As Long

Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_FIXED = &H0
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
    lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)

Private Declare Function lstrlenA Lib "kernel32" (ByVal lpString As Long) As
 Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As
 Long

Private Declare Function GetVersion Lib "kernel32" () As Long

Private m_hMem As Long
Private m_lBufSize As Long
Private m_lPtr As Long

Public Sub SetString(ByVal sString As String)
   Dispose
   If (Len(sString) > 0) Then
      Dim b() As Byte
      If IsNt Then
         b = sString
      Else
         b = StrConv(sString, vbFromUnicode)
      End If
      ReDim Preserve b(0 To UBound(b) + 1) As Byte
      m_hMem = LocalAlloc(GPTR, UBound(b) + 1)
      m_lPtr = LocalLock(m_hMem)
      CopyMemory ByVal m_lPtr, b(0), UBound(b) + 1
   Else
      m_hMem = LocalAlloc(GPTR, 1)
      m_lPtr = LocalLock(m_hMem)
   End If

End Sub
Public Function GetString() As String
   
   Dim sRet As String
   If Not (m_lPtr = 0) Then
      Dim b() As Byte
      Dim lLen As Long
      If IsNt Then
         lLen = lstrlenW(m_lPtr) * 2
      Else
         lLen = lstrlenA(m_lPtr)
      End If
      If (lLen > 0) Then
         ReDim b(0 To lLen) As Byte
         CopyMemory b(0), ByVal m_lPtr, lLen
         If IsNt Then
            sRet = b
         Else
            sRet = StrConv(b, vbUnicode)
         End If
         Dim iPos As Long
         iPos = InStr(sRet, vbNullChar)
         If (iPos > 1) Then
            GetString = Left(sRet, iPos - 1)
         Else
            GetString = sRet
         End If
      End If
   End If

End Function
Public Property Get Ptr() As Long
   Ptr = m_lPtr
End Property
Public Property Let Ptr(ByVal lPtr As Long)
   Dispose
   ' This is pointer must be owned elsewhere
   ' so we have no hMem.  No attempt to free
   ' this pointer will (or can) be made by
   ' this class
   m_lPtr = lPtr
End Property

Private Function IsNt() As Boolean
Dim lVer As Long
   lVer = GetVersion()
   IsNt = ((lVer And &H80000000) = 0)
End Function

Public Sub Dispose()
   If Not (m_hMem = 0) Then
      If Not (m_lPtr = 0) Then
         LocalUnlock m_lPtr
         m_lPtr = 0
      End If
      LocalFree m_hMem
      m_hMem = 0
   End If
End Sub

Private Sub Class_Terminate()
   Dispose
End Sub