mcommon.bas

用vb写的一个小程序。希望喜欢。 ＬＨＢＳＥＡＭＡＮ·１６３。ＣＯＭ

Attribute VB_Name = "mCommon"
Option Compare Binary
Option Explicit

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal numbytes As Long)

Public Const APPTITLE   As String = "WebCoder"
Public Const FLD        As String = "fld_"
Public Const TBL        As String = "tbl_"
Public Const QRY        As String = "qry_"
Public Const IDX        As String = "idx"

Public Const strUSERDB  As String = "\convert.mdb"
Public Const lngDBVER   As Long = dbVersion30

Public ActiveDB         As DAO.Database
Public ActiveWS         As DAO.Workspace

Public Function fcnGetDelimitedRecord(strLine As String, Optional strTextQualifier As String = """", Optional strDelimiter As String = ",") As Variant
  '***  function to get a line of a delimited text file into an array of strings
  '***  returns field # in array item 0
  '***  unquotes quoted fields and works well on long lines of text

  Dim lngPos           As Long
  Dim lngItemFound     As Long
  Dim lngLen           As Long
  Dim lngCounter       As Long
  Dim blnInQuotedField As Boolean
  Dim arrLineChars()   As Byte
  Dim bytQualifier     As Byte
  Dim bytDelimiter     As Byte
  Dim lngItemStart     As Long
  Dim lngItemEnd       As Long
  Dim arrItems()       As String

  '***  initialize array
  ReDim arrItems(0)

  If LenB(strLine) <> 0 Then

    bytQualifier = Asc(strTextQualifier)
    bytDelimiter = Asc(strDelimiter)
    arrLineChars = StrConv(strLine & strDelimiter, vbFromUnicode)
    lngLen = UBound(arrLineChars, 1)
    lngItemEnd = -1

    '***  find the right item
    For lngPos = 0 To lngLen

      Select Case arrLineChars(lngPos)

        Case 10
          If Not blnInQuotedField Then
            lngItemFound = lngItemFound + 1
            lngItemStart = lngItemEnd + 1
            lngItemEnd = lngPos
            Mid$(strLine, lngPos, 1) = Chr(32&)
          End If

        Case 13
          If Not blnInQuotedField Then
            Mid$(strLine, lngPos, 1) = Chr(32&)
          End If

        Case bytDelimiter
          If Not blnInQuotedField Then
            lngItemFound = lngItemFound + 1
            lngItemStart = lngItemEnd + 1
            lngItemEnd = lngPos
          End If

        Case bytQualifier
          blnInQuotedField = Not blnInQuotedField

      End Select

      If lngItemFound > UBound(arrItems, 1) Then
        ReDim Preserve arrItems(0 To lngItemFound) As String
        arrItems(lngItemFound) = Trim$(Mid$(strLine, lngItemStart + 1, lngItemEnd - lngItemStart))
      End If
    Next

    '***  unquote if quoted - double delimit to single
    For lngCounter = 1 To UBound(arrItems, 1)

      If Len(arrItems(lngCounter)) > 1 Then
        '***  item is long enough to be delimited

        If Asc(arrItems(lngCounter)) = bytQualifier And Asc(Right$(arrItems(lngCounter), 1)) = bytQualifier Then
          '***  remove the surrounding quotes
          arrItems(lngCounter) = Mid$(arrItems(lngCounter), 2, Len(arrItems(lngCounter)) - 2)
          '***  replace double quotes
          arrItems(lngCounter) = fcnReplaceB(arrItems(lngCounter), Chr$(bytQualifier) & Chr$(bytQualifier), Chr$(bytQualifier))
        End If

      End If

    Next

  End If

  arrItems(0) = Str$(lngItemFound)
  fcnGetDelimitedRecord = arrItems()
End Function

Function fcnReplaceB(ByRef strReplace As String, ByRef strOld As String, ByRef strNew As String) As String
  '***  use the appropriate replace function VB6 Replace is 60% slower
  If Len(strReplace) > 4000 Then

    '***  do not use the binary replace if there are no hits
    If InStr(1, strReplace, strOld, vbBinaryCompare) > 0 Then
      fcnReplaceB = fcnReplaceB1(strReplace, strOld, strNew)

    Else
      fcnReplaceB = strReplace
    End If

  Else

    fcnReplaceB = fcnReplaceB2(strReplace, strOld, strNew)

  End If

End Function

Function fcnReplaceB1(ByRef strReplace As String, ByRef strOld As String, ByRef strNew As String, Optional lngCount As Long) As String
  Dim arrReplace()     As Byte
  Dim arrOld()         As Byte
  Dim arrNew()         As Byte
  Dim arrReturn()      As Byte

  arrReplace() = StrConv(strReplace, vbFromUnicode)
  arrOld() = StrConv(strOld, vbFromUnicode)
  arrNew() = StrConv(strNew, vbFromUnicode)

  lngCount = fcnReplaceByteArray(arrReplace(), arrOld(), arrNew(), arrReturn())

  fcnReplaceB1 = StrConv(arrReturn(), vbUnicode)
End Function

Function fcnReplaceB2(ByRef strReplace As String, ByRef strOld As String, ByRef strNew As String) As String
  Dim lngPos           As Long
  lngPos = InStr(1, strReplace, strOld, vbBinaryCompare)
  If lngPos <> 0 Then
    fcnReplaceB2 = Left$(strReplace, lngPos - 1) & strNew & fcnReplaceB2(Mid$(strReplace, lngPos + Len(strOld)), strOld, strNew)
  Else
    fcnReplaceB2 = strReplace
  End If
End Function

Function fcnReplaceByteArray(ByRef arrSearch() As Byte, ByRef arrOld() As Byte, ByRef arrNew() As Byte, ByRef arrReplaced() As Byte) As Long
  '***  fast replace without string concatination
  '***  uses rtlcopymem function
  '***  !TODO: memory reservation is exorbitant when the new string is longer than the old one
  '***  should be easy to fix

  Dim lngPos           As Long
  Dim lngBaseOut       As Long
  Dim lngCount         As Long
  Dim lngReplaceCount  As Long
  Dim lngLenOld        As Long
  Dim lngLenNew        As Long
  Dim lngLenInput      As Long
  Dim lngBuffer        As Long
  Dim lngLenPart       As Long
  Dim lngMaxBuffer     As Long
  Dim lngNoBlocks      As Long
  Dim lngExtra         As Long
  Dim lngMain          As Long
  Dim lngLOF           As Long
  Dim lngBlockSize     As Long
  Dim lngPosition      As Long
  Dim lngNoHits        As Long
  Dim arrReplace()     As Byte
  Dim arrLeftOver()    As Byte
  Dim lngOver          As Long

  '***  important performance setting to avoid slow InStr() on long strings
  lngBlockSize = 1200

  lngLOF = UBound(arrSearch) + 1
  lngNoBlocks = lngLOF \ lngBlockSize
  lngExtra = lngLOF Mod lngBlockSize
  lngMain = (lngNoBlocks) * lngBlockSize
  lngBaseOut = -1
  ReDim arrLeftOver(-1 To -1)

  lngLenOld = UBound(arrOld) + 1
  lngLenNew = UBound(arrNew) + 1

  'Debug.Print "[" & lngLOF & "]";

  If lngLenOld = 0 Or lngLOF = 0 Then

    arrReplaced = arrSearch
    fcnReplaceByteArray = 0

  Else

    '***  block loop
    For lngCount = 0 To lngMain Step lngBlockSize

      '***  fill the replace string
      If lngCount < lngMain Then
        '***  all blocks use this copy
        ReDim arrReplace(lngBlockSize - 1 + UBound(arrLeftOver) + 1)
        CopyMemory arrReplace(UBound(arrLeftOver) + 1), arrSearch(lngCount), lngBlockSize
        If lngOver > 0 Then
          CopyMemory arrReplace(0), arrLeftOver(0), UBound(arrLeftOver) + 1
        End If
      ElseIf lngExtra > 0 Then
        '***  only the last block uses this copy
        ReDim arrReplace(lngExtra - 1 + UBound(arrLeftOver) + 1)
        CopyMemory arrReplace(UBound(arrLeftOver) + 1), arrSearch(lngCount), lngExtra
        If lngOver > 0 Then
          CopyMemory arrReplace(0), arrLeftOver(0), UBound(arrLeftOver) + 1
        End If
      ElseIf lngExtra = 0 Then
        '*** we'r finished - exit the for-next
        Exit For
      End If

      lngLenInput = UBound(arrReplace) + 1

      If lngLenNew = 0 Then
        ReDim arrNew(0)
      End If

      '***  memory reservation: create a buffer for the output
      If (lngLenNew - lngLenOld) <= 0 Then
        '***  the output will be smaller of equal in length
        lngBuffer = UBound(arrReplace)
      Else
        '***  the output may be longer than the input
        lngMaxBuffer = UBound(arrReplace) + (lngLenInput \ lngLenOld) * (lngLenNew - lngLenOld)
        lngBuffer = lngMaxBuffer
      End If

      ReDim Preserve arrReplaced(lngBaseOut + lngBuffer + 1)
      lngPosition = 1

      '***  replace loop
      Do

        lngPos = InStrB(lngPosition, arrReplace, arrOld, vbBinaryCompare)
        lngPos = lngPos - 1

        If lngPos < 0 Then
          '***  nothing found: add the rightmost part

          '***  lngNoHits: number of bytes without a hit in this block
          lngNoHits = lngLenInput - lngPosition + 1
          If lngNoHits < lngLenOld Then
            '***  do not re-check bytes that were replaced already
            arrLeftOver() = RightB(arrReplace, lngNoHits)
            lngOver = lngNoHits
          Else
            '***  re-check the last bytes. eg. searching for 'secret' --> the last bytes could be 'secre'
            '***  to check if the next block starts with 't', always copy lngLenOld - 1 bytes
            arrLeftOver() = RightB(arrReplace, lngLenOld - 1)
            lngOver = lngLenOld - 1
          End If

          If lngNoHits > 0 Then
            CopyMemory arrReplaced(lngBaseOut + 1), arrReplace(lngPosition - 1), lngNoHits - lngOver
          End If

          lngBaseOut = lngBaseOut + lngNoHits - lngOver
        Else
          '***  we've found it

          '***  set the string-part length
          lngLenPart = lngPos - lngPosition + 1

          '***  add the left part
          CopyMemory arrReplaced(lngBaseOut + 1), arrReplace(lngPosition - 1), lngLenPart

          '***  copy the new part if lngLenNew > 0
          CopyMemory arrReplaced(lngBaseOut + 1 + lngLenPart), arrNew(0), lngLenNew

          '***  set the new lngBaseOut value
          lngBaseOut = lngBaseOut + lngLenPart + lngLenNew

          '***  set the new position
          lngPosition = lngPos + 1 + lngLenOld

          lngReplaceCount = lngReplaceCount + 1
        End If

      Loop Until lngPos < 0
      '***  replace loop

    Next lngCount
    '***  block loop

    '***  clear extra bytes in the buffer and add leftover bytes
    ReDim Preserve arrReplaced(lngBaseOut + lngOver)
    If lngOver > 0 Then
      CopyMemory arrReplaced(lngBaseOut + 1), arrLeftOver(0), lngOver
    End If

    fcnReplaceByteArray = lngReplaceCount

  End If

End Function

Function fcnGetFile(strFileName As String) As String
  '***  returns a unicode string representation of the file
  Dim lngFile          As Long
  Dim strFile          As String

  lngFile = FreeFile
  Open strFileName For Binary Access Read As lngFile
  strFile = Space$(LOF(lngFile))
  Get #lngFile, 1, strFile
  Close lngFile
  fcnGetFile = strFile
End Function