mborrowedcode.bas

枕善居汉化的stockchart股软 描 述：实时股票图表曲线示例 Ver 1.0 网 站：http://www.mndsoft.com/ e-mail ：[e-mail] 最新的

'For i = LBound(ab) To UBound(ab)
'Debug.Print Chr$(ab(i))
'Next

End Sub
' Convert an ANSI string in a byte array to a VB Unicode string
Function BytesToStr(ab() As Byte) As String
    BytesToStr = StrConv(ab, vbUnicode)
End Function
' Strip junk at end from null-terminated string
Function StrZToStr(s As String) As String
    StrZToStr = Left$(s, lstrlen(s))
End Function
' Test file existence with error trapping
Public Function ExistFile(sSpec As String) As Boolean
    On Error Resume Next
    Call FileLen(sSpec)
    ExistFile = (Err = 0)
End Function
' Fix provided by Torsten Rendelmann
Function IsArrayEmpty(va As Variant) As Boolean
    Dim i As Long
    On Error Resume Next
    i = LBound(va, 1)
    IsArrayEmpty = (Err <> 0)
    Err = 0
End Function
Private Function FilterLookup(ByVal sFilters As String, ByVal iCur As Long) As String
    Dim iStart As Long, iEnd As Long, s As String
    iStart = 1
    If sFilters = sEmpty Then Exit Function
    Do
        ' Cut out both parts marked by null character
        iEnd = InStr(iStart, sFilters, vbNullChar)
        If iEnd = 0 Then Exit Function
        iEnd = InStr(iEnd + 1, sFilters, vbNullChar)
        If iEnd Then
            s = Mid$(sFilters, iStart, iEnd - iStart)
        Else
            s = Mid$(sFilters, iStart)
        End If
        iStart = iEnd + 1
        If iCur = 1 Then
            FilterLookup = s
            Exit Function
        End If
        iCur = iCur - 1
    Loop While iCur
End Function
' New GetQToken uses faster StrSpn and StrCSpn from SHLWAPI.DLL
Public Function GetQToken(sTarget As String, sSeps As String) As String
    ' GetQToken = sEmpty
    If fNoShlWapi Then
        GetQToken = GetQTokenO(sTarget, sSeps)
        Exit Function
    End If
    
    ' Note that sSave, pSave, pCur, and cSave must be static between calls
    Static sSave As String, pSave As Long, pCur As Long, cSave As Long
    ' First time through save start and length of string
    If sTarget <> sEmpty Then
        ' Save in case sTarget is moveable string (Command$)
        sSave = sTarget
        pSave = StrPtr(sSave)
        pCur = pSave
        cSave = Len(sSave)
    Else
        ' Quit if past end (also catches null or empty target)
        If pCur >= pSave + (cSave * 2) Then Exit Function
    End If
    ' Make sure separators includes quote
    Dim sSepsNew As String, pSeps As Long
    sSepsNew = sSeps & sQuote2
    pSeps = StrPtr(sSepsNew)

    ' Get current character
    Dim pNew As Long, c As Long
    ' Find start of next token
    c = StrSpn(pCur, pSeps)
    ' Set position to start of token
    If c Then pCur = pCur + (c * 2)
    
    Dim ch As Integer
    Const chQuote = 34  ' Asc("""")
    CopyMemory ch, ByVal pCur - 2, 2
    ' Check first character for quote, then find end of token
    If ch = chQuote Then
        c = StrCSpn(pCur, StrPtr(sQuote2))
    Else
        c = StrCSpn(pCur, pSeps)
    End If
    ' If token length is zero, we're at end
    If c = 0 Then Exit Function
    
    ' Cut token out of target string
    GetQToken = String$(c, 0)
    CopyMemory ByVal StrPtr(GetQToken), ByVal pCur, c * 2
    ' Set new starting position
    pCur = pCur + (c * 2)

End Function
' GetQTokenO uses our StrSpan and StrBreak
Private Function GetQTokenO(sTarget As String, sSeps As String) As String
    ' GetQTokenO = sEmpty

    ' Note that sSave and iStart must be static from call to call
    ' If first call, make copy of string
    Static sSave As String, iStart As Integer, cSave As Integer
    Dim iNew As Integer, fQuote As Integer
    If sTarget <> sEmpty Then
        iStart = 1
        sSave = sTarget
        cSave = Len(sSave)
    Else
        If sSave = sEmpty Then Exit Function
    End If
    ' Make sure separators includes quote
    sSeps = sSeps & sQuote2

    ' Find start of next token
    iNew = StrSpan(sSave, iStart, sSeps)
    If iNew Then
        ' Set position to start of token
        iStart = iNew
    Else
        ' If no new token, return empty string
        sSave = sEmpty
        Exit Function
    End If
    
    ' Find end of token
    If iStart = 1 Then
        iNew = StrBreak(sSave, iStart, sSeps)
    ElseIf Mid$(sSave, iStart - 1, 1) = sQuote2 Then
        iNew = StrBreak(sSave, iStart, sQuote2)
    Else
        iNew = StrBreak(sSave, iStart, sSeps)
    End If

    If iNew = 0 Then
        ' If no end of token, set to end of string
        iNew = cSave + 1
    End If
    ' Cut token out of sTarget string
    GetQTokenO = Mid$(sSave, iStart, iNew - iStart)
    
    ' Set new starting position
    iStart = iNew

End Function
' StrBreak and StrSpan are used by GetTokenO, but can be called by clients
Function StrBreak(sTarget As String, ByVal iStart As Integer, _
                  sSeps As String) As Integer
    
    Dim cTarget As Integer
    cTarget = Len(sTarget)
   
    ' Look for end of token (first character that is a separator)
    Do While InStr(sSeps, Mid$(sTarget, iStart, 1)) = 0
        If iStart > cTarget Then
            StrBreak = 0
            Exit Function
        Else
            iStart = iStart + 1
        End If
    Loop
    StrBreak = iStart

End Function
Function StrSpan(sTarget As String, ByVal iStart As Integer, _
                 sSeps As String) As Integer
    
    Dim cTarget As Integer
    cTarget = Len(sTarget)
    ' Look for start of token (character that isn't a separator)
    Do While InStr(sSeps, Mid$(sTarget, iStart, 1))
        If iStart > cTarget Then
            StrSpan = 0
            Exit Function
        Else
            iStart = iStart + 1
        End If
    Loop
    StrSpan = iStart

End Function

Public Function GetFileBaseExt(sFile As String) As String
    Dim iBase As Long, s As String
    If sFile = sEmpty Then Exit Function
    s = GetFullPath(sFile, iBase)
    GetFileBaseExt = Mid$(s, iBase)
End Function
Public Function GetFullPath(sFileName As String, _
                     Optional FilePart As Long, _
                     Optional ExtPart As Long, _
                     Optional DirPart As Long) As String

    Dim c As Long, p As Long, sRet As String
    If sFileName = sEmpty Then Exit Function
    
    ' Get the path size, then create string of that size
    sRet = String(cMaxPath, 0)
    c = GetFullPathName(sFileName, cMaxPath, sRet, p)
    If c = 0 Then ApiRaise Err.LastDllError
    Debug.Assert c <= cMaxPath
    sRet = Left$(sRet, c)

    ' Get the directory, file, and extension positions
    GetDirExt sRet, FilePart, DirPart, ExtPart
    GetFullPath = sRet
    
End Function

Private Sub GetDirExt(sFull As String, iFilePart As Long, _
                      iDirPart As Long, iExtPart As Long)

    Dim iDrv As Long, i As Long, cMax As Long
    cMax = Len(sFull)

    iDrv = Asc(UCase$(Left$(sFull, 1)))

    ' If in format d:\path\name.ext, return 3
    If iDrv <= 90 Then                          ' Less than Z
        If iDrv >= 65 Then                      ' Greater than A
            If Mid$(sFull, 2, 1) = ":" Then     ' Second character is :
                If Mid$(sFull, 3, 1) = "\" Then ' Third character is \
                    iDirPart = 3
                End If
            End If
        End If
    Else

        ' If in format \\machine\share\path\name.ext, return position of \path
        ' First and second character must be \
        If Mid$(sFull, 1, 2) <> "\\" Then ApiRaise ERROR_BAD_PATHNAME

        Dim fFirst As Boolean
        i = 3
        Do
            If Mid$(sFull, i, 1) = "\" Then
                If Not fFirst Then
                    fFirst = True
                Else
                    iDirPart = i
                    Exit Do
                End If
            End If
            i = i + 1
        Loop Until i = cMax
    End If

    ' Start from end and find extension
    iExtPart = cMax + 1       ' Assume no extension
    fFirst = False
    Dim sChar As String
    For i = cMax To iDirPart Step -1
        sChar = Mid$(sFull, i, 1)
        If Not fFirst Then
            If sChar = "." Then
                iExtPart = i
                fFirst = True
            End If
        End If
        If sChar = "\" Then
            iFilePart = i + 1
            Exit For
        End If
    Next
    Exit Sub
FailGetDirExt:
    iFilePart = 0
    iDirPart = 0
    iExtPart = 0
End Sub

Sub ApiRaise(ByVal e As Long)
    Err.Raise vbObjectError + 29000 + e, _
              App.EXEName & ".Windows", ApiError(e)
End Sub

Function ApiError(ByVal e As Long) As String
    Dim s As String, c As Long
    s = String(256, 0)
    c = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or _
                      FORMAT_MESSAGE_IGNORE_INSERTS, _
                      pNull, e, 0&, s, Len(s), ByVal pNull)
    If c Then ApiError = Left$(s, c)
End Function

' Work around limitation of AddressOf
'    Call like this: procVar = GetProc(AddressOf ProcName)
Function GetProc(proc As Long) As Long
    GetProc = proc
End Function
Function StringToPointer(s As String) As Long
    If UnicodeTypeLib Then
        StringToPointer = VarPtr(s)
    Else
        StringToPointer = StrPtr(s)
    End If
End Function
' Make sure path ends in a backslash
Function NormalizePath(sPath As String) As String
    If Right$(sPath, 1) <> sBSlash Then
        NormalizePath = sPath & sBSlash
    Else
        NormalizePath = sPath
    End If
End Function


'***End HardCore VB code********************************************


'following code plucked from "FormShaper" by Mel Grubb II
'Resource region file also made with FormShaper
'I modified it... added the region handle argument
'***Begin*****************************************
Public Sub RegionFromResource(m_lngRegion As Long, ResID As Integer, ResType As String)
    Dim abytRegion() As Byte

    ' Pull the region data from the resource
    abytRegion = LoadResData(ResID, ResType)
    If UBound(abytRegion) > 0 Then