home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 7_2009-2012.ISO / data / zips / A_Customiz220561632011.psc / cBuildStr.cls < prev    next >
Text File  |  2011-01-23  |  7KB  |  179 lines
  1. VERSION 1.0 CLASS
  2. BEGIN
  3.   MultiUse = -1  'True
  4.   Persistable = 0  'NotPersistable
  5.   DataBindingBehavior = 0  'vbNone
  6.   DataSourceBehavior  = 0  'vbNone
  7.   MTSTransactionMode  = 0  'NotAnMTSObject
  8. END
  9. Attribute VB_Name = "cBuildStr"
  10. Attribute VB_GlobalNameSpace = False
  11. Attribute VB_Creatable = True
  12. Attribute VB_PredeclaredId = False
  13. Attribute VB_Exposed = False
  14.  
  15. ' Declare some RtlMoveMemory Alias's (thanks Bruce :)
  16. Private Declare Sub CopyMemByV Lib "kernel32" Alias "RtlMoveMemory" (ByVal lpDest As Long, ByVal lpSrc As Long, ByVal lByteLen As Long)
  17. Private Declare Sub CopyMemByR Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal lByteLen As Long)
  18. Private Declare Function AllocStrBPtr Lib "oleaut32" Alias "SysAllocStringByteLen" (ByVal lAddrPtr As Long, ByVal lCount As Long) As Long
  19.  
  20. Private Const lChunk As Long = &H2000
  21. Private Const lZero As Long = &H0
  22.  
  23. Private lTotal As Long
  24. Private lUBound As Long
  25. Private aBuffer() As Byte
  26.  
  27. ' +++++++++++++++++++++++++++++++++++++++++++++++++++++++
  28.  
  29. Public Property Get Value(Optional ByVal lStart As Long, Optional ByVal lLength As Long) As String
  30.     Dim lCount As Long
  31.     lStart = ValidStartPos(lStart)
  32.     lCount = lTotal - lStart
  33.     If Not (lCount > lZero) Then Exit Property
  34.     lCount = ValidByteLength(lLength, lCount)
  35.     CopyMemByR ByVal VarPtr(Value), AllocStrBPtr(VarPtr(aBuffer(lZero)) + lStart, lCount), 4&
  36. End Property
  37.  
  38. Public Sub Append(sSubStr As String, Optional ByVal lLength As Long)
  39.     Dim lCount As Long, lSeek As Long
  40.     lCount = ValidByteLength(lLength, LenB(sSubStr))
  41.     If (lCount = lZero) Then Exit Sub
  42.     lSeek = lTotal
  43.     lTotal = lSeek + lCount
  44.     If lTotal > lUBound Then
  45.         lUBound = lTotal + lChunk
  46.         ReDim Preserve aBuffer(lUBound) As Byte
  47.     End If
  48.     ' Preserve Unicode by passing StrPtr and byte count
  49.     CopyMemByV VarPtr(aBuffer(lSeek)), StrPtr(sSubStr), lCount
  50. End Sub
  51.  
  52. '----------------------------------------------------------
  53. ' Optionally specify the delimiter character(s) to insert
  54. ' between the appended substrings. It will work correctly
  55. ' when arguments are omitted or passed empty:
  56. '    Appends "s1",,, "s2", "", "", "s3",, vbCrLf
  57. '    Appends "", "", "s4",,, "s5",, "", vbCrLf
  58. '    Appends "",, "s6", "", "", "",, "s7" vbCrLf
  59. '----------------------------------------------------------
  60.  
  61. Public Sub Appends(sSubStr As String, Optional sSubStr2 As String, Optional sSubStr3 As String, Optional sSubStr4 As String, Optional sSubStr5 As String, Optional sSubStr6 As String, Optional sSubStr7 As String, Optional sSubStr8 As String, Optional sDelim As String)
  62.     Dim lDelim As Long, cDelim As Long
  63.     Dim Len1 As Long, Len2 As Long
  64.     Dim Len3 As Long, Len4 As Long
  65.     Dim Len5 As Long, Len6 As Long
  66.     Dim Len7 As Long, Len8 As Long
  67.     Dim lBytes As Long
  68.  
  69.     Len1 = LenB(sSubStr):  Len2 = LenB(sSubStr2)
  70.     Len3 = LenB(sSubStr3): Len4 = LenB(sSubStr4)
  71.     Len5 = LenB(sSubStr5): Len6 = LenB(sSubStr6)
  72.     Len7 = LenB(sSubStr7): Len8 = LenB(sSubStr8)
  73.     lDelim = LenB(sDelim)
  74.  
  75.     If (lDelim) Then
  76.         If (lTotal = lZero) Then cDelim = -lDelim
  77.         If (Len1) Then cDelim = cDelim + lDelim
  78.         If (Len2) Then cDelim = cDelim + lDelim
  79.         If (Len3) Then cDelim = cDelim + lDelim
  80.         If (Len4) Then cDelim = cDelim + lDelim
  81.         If (Len5) Then cDelim = cDelim + lDelim
  82.         If (Len6) Then cDelim = cDelim + lDelim
  83.         If (Len7) Then cDelim = cDelim + lDelim
  84.         If (Len8) Then cDelim = cDelim + lDelim
  85.     End If
  86.  
  87.     lBytes = Len1 + Len2 + Len3 + Len4 + Len5 + Len6 + Len7 + Len8 + cDelim
  88.  
  89.     If lBytes + lTotal > lUBound Then
  90.         lUBound = lBytes + lTotal + lChunk
  91.         ReDim Preserve aBuffer(lUBound) As Byte
  92.     End If
  93.  
  94.     ' Preserve Unicode by passing StrPtr and byte count
  95.     If (Len1) Then
  96.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  97.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr), Len1
  98.         lTotal = lTotal + Len1
  99.     End If
  100.     If (Len2) Then
  101.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  102.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr2), Len2
  103.         lTotal = lTotal + Len2
  104.     End If
  105.     If (Len3) Then
  106.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  107.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr3), Len3
  108.         lTotal = lTotal + Len3
  109.     End If
  110.     If (Len4) Then
  111.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  112.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr4), Len4
  113.         lTotal = lTotal + Len4
  114.     End If
  115.     If (Len5) Then
  116.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  117.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr5), Len5
  118.         lTotal = lTotal + Len5
  119.     End If
  120.     If (Len6) Then
  121.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  122.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr6), Len6
  123.         lTotal = lTotal + Len6
  124.     End If
  125.     If (Len7) Then
  126.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  127.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr7), Len7
  128.         lTotal = lTotal + Len7
  129.     End If
  130.     If (Len8) Then
  131.         If (lDelim) Then If (lTotal) Then GoSub InsDelim
  132.         CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sSubStr8), Len8
  133.         lTotal = lTotal + Len8
  134.     End If
  135.     Exit Sub
  136.  
  137. InsDelim:
  138.     CopyMemByV VarPtr(aBuffer(lTotal)), StrPtr(sDelim), lDelim
  139.     lTotal = lTotal + lDelim
  140.     Return
  141. End Sub
  142.  
  143. Public Property Get Length() As Long
  144.     Length = lTotal \ 2&
  145. End Property
  146.  
  147. Public Sub Reset(Optional ByVal FreeMemory As Boolean)
  148.     lTotal = lZero
  149.     If FreeMemory Then
  150.         lUBound = lChunk
  151.         ReDim aBuffer(lUBound) As Byte
  152.     End If
  153. End Sub
  154.  
  155. ' +++++++++++++++++++++++++++++++++++++++++++++++++++++++
  156.  
  157. Private Sub Class_Initialize()
  158.     Call Reset(True)
  159. End Sub
  160.  
  161. Private Function ValidStartPos(ByVal lStart As Long) As Long
  162.     If (lStart > lZero) Then
  163.        ValidStartPos = (lStart + lStart) - 2 ' Byte count, zero based
  164.        If Not (ValidStartPos < lTotal) Then ValidStartPos = lTotal
  165.     End If
  166. End Function
  167.  
  168. Private Function ValidByteLength(ByVal lLength As Long, ByVal LenB_SubStr As Long) As Long
  169.     ValidByteLength = LenB_SubStr
  170.     If (lLength > lZero) Then
  171.        lLength = lLength + lLength ' Unicode byte count
  172.        If Not (lLength > LenB_SubStr) Then ValidByteLength = lLength
  173.     End If
  174. End Function
  175.  
  176. ' +++++++++++++++++++++++++++++++++++++++++++++++++++++++
  177.  
  178. ' Rd - crYptic but cRaZy!
  179.