mborrowedcode.bas

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

Attribute VB_Name = "MBorrowedCode"
'****************************************************************************
' ：） 人人为我，我为人人 ：）
'枕善居汉化收藏整理
'发布日期：06/06/26
'描    述：实时股票图表曲线示例 Ver 1.0
'网    站：http://www.mndsoft.com/
'e-mail  ：[e-mail]   最新的邮箱,如果您有新的好的代码别忘记给枕善居哦
'OICQ    ：88382850
'****************************************************************************
Option Explicit


Public Declare Function recv Lib "WSOCK32.DLL" (ByVal s As Long, ByVal buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long

'Following code from Bruce McKinney's Hardcore VisualBasic
'***Begin******************************************************

Public Const sEmpty As String = ""  'type lib doesn't like this one
Public Const sQuote2 = """"   'or this one
Public Const sBSlash = "\"

Private Declare Function StrSpn Lib "SHLWAPI" Alias "StrSpnW" ( _
        ByVal psz As Long, ByVal pszSet As Long) As Long
Private Declare Function StrCSpn Lib "SHLWAPI" Alias "StrCSpnW" ( _
        ByVal LPSTR As Long, ByVal lpSet As Long) As Long
        

Private Declare Function GetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "COMDLG32" _
    Alias "GetSaveFileNameA" (File As OPENFILENAME) As Long

'need this private copymem declare here because fontname won't copy to dlg without it
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

' In standard module fNoShlWapi is a Property Get that checks for DLL
Private fNotFirstTime As Boolean, fNoShlWapiI As Boolean ' = False
' Array of custom colors lasts for life of app
Private alCustom(0 To 15) As Long, fNotFirst As Boolean
Public Sock As Integer, WSAStartedUp As Boolean     'Flag to keep track of whether winsock WSAStartup wascalled
Private m_CurrentDirectory As String



Private Property Get fNoShlWapi() As Boolean
    If fNotFirstTime = False Then
        fNotFirstTime = True
        On Error GoTo Fail
        Call StrSpn(StrPtr("a"), StrPtr("a"))
    End If
    Exit Property
Fail:
    fNoShlWapiI = True
End Property

Public Function VBGetOpenFileName(FileName As String, _
                           Optional FileTitle As String, _
                           Optional FileMustExist As Boolean = True, _
                           Optional MultiSelect As Boolean = False, _
                           Optional ReadOnly As Boolean = False, _
                           Optional HideReadOnly As Boolean = False, _
                           Optional filter As String = "All (*.*)| *.*", _
                           Optional FilterIndex As Long = 1, _
                           Optional InitDir As String, _
                           Optional DlgTitle As String, _
                           Optional DefaultExt As String, _
                           Optional owner As Long = -1, _
                           Optional flags As Long = 0) As Boolean

    Dim opfile As OPENFILENAME, s As String, afFlags As Long
    With opfile
        .lStructSize = Len(opfile)
        
        ' Add in specific flags and strip out non-VB flags
        .flags = (-FileMustExist * OFN_FILEMUSTEXIST) Or _
                 (-MultiSelect * OFN_ALLOWMULTISELECT) Or _
                 (-ReadOnly * OFN_READONLY) Or _
                 (-HideReadOnly * OFN_HIDEREADONLY) Or _
                 (flags And CLng(Not (OFN_ENABLEHOOK Or _
                                      OFN_ENABLETEMPLATE)))
        ' Owner can take handle of owning window
        If owner <> -1 Then .hwndOwner = owner
        ' InitDir can take initial directory string
        .lpstrInitialDir = InitDir
        ' DefaultExt can take default extension
        .lpstrDefExt = DefaultExt
        ' DlgTitle can take dialog box title
        .lpstrTitle = DlgTitle

        ' To make Windows-style filter, replace | and : with nulls
        Dim ch As String, i As Long
        For i = 1 To Len(filter)
            ch = Mid$(filter, i, 1)
            If ch = "|" Or ch = ":" Then
                s = s & vbNullChar
            Else
                s = s & ch
            End If
        Next
        ' Put double null at end
        s = s & vbNullChar & vbNullChar
        .lpstrFilter = s
        .nFilterIndex = FilterIndex
    
        ' Pad file and file title buffers to maximum path
        s = FileName & String$(cMaxPath - Len(FileName), 0)
        .lpstrFile = s
        .nMaxFile = cMaxPath
        s = FileTitle '& String$(cMaxFile - Len(FileTitle), 0)
        .lpstrFileTitle = s
        .nMaxFileTitle = cMaxFile
        ' All other fields set to zero

        If GetOpenFileName(opfile) Then
            VBGetOpenFileName = True
            FileName = StrZToStr(.lpstrFile)
            FileTitle = StrZToStr(.lpstrFileTitle)
            flags = .flags
            ' Return the filter index
            FilterIndex = .nFilterIndex
            ' Look up the filter the user selected and return that
            filter = FilterLookup(.lpstrFilter, FilterIndex)
            If (.flags And OFN_READONLY) Then ReadOnly = True
        Else
            VBGetOpenFileName = False
            FileName = sEmpty
            FileTitle = sEmpty
            flags = 0
            FilterIndex = -1
            filter = sEmpty
        End If
    End With
End Function
' ChooseColor wrapper
Function VBChooseColor(Color As Long, _
                       Optional AnyColor As Boolean = True, _
                       Optional FullOpen As Boolean = False, _
                       Optional DisableFullOpen As Boolean = False, _
                       Optional owner As Long = -1, _
                       Optional flags As Long) As Boolean

    Dim chclr As TCHOOSECOLOR
    chclr.lStructSize = Len(chclr)
    
    ' Color must get reference variable to receive result
    ' Flags can get reference variable or constant with bit flags
    ' Owner can take handle of owning window
    If owner <> -1 Then chclr.hwndOwner = owner

    ' Assign color (default uninitialized value of zero is good default)
    chclr.rgbResult = Color

    ' Mask out unwanted bits
    Dim afMask As Long
    afMask = CLng(Not (CC_ENABLEHOOK Or _
                       CC_ENABLETEMPLATE))
    ' Pass in flags
    chclr.flags = afMask And (CC_RGBINIT Or _
                  IIf(AnyColor, CC_ANYCOLOR, CC_SOLIDCOLOR) Or _
                  (-FullOpen * CC_FULLOPEN) Or _
                  (-DisableFullOpen * CC_PREVENTFULLOPEN))

    ' If first time, initialize to white
    If fNotFirst = False Then InitColors

    chclr.lpCustColors = VarPtr(alCustom(0))
    ' All other fields zero
    
    If ChooseColor(chclr) Then
        VBChooseColor = True
        Color = chclr.rgbResult
    Else
        VBChooseColor = False
        Color = -1
    End If

End Function

Private Sub InitColors()
    Dim i As Long
    ' Initialize with first 16 system interface colors
    For i = 0 To 15
        alCustom(i) = GetSysColor(i)
    Next
    fNotFirst = True
End Sub

' Property to read or modify custom colors (use to save colors in registry)
Public Property Get CustomColor(i As Integer) As Long
    ' If first time, initialize to white
    If fNotFirst = False Then InitColors
    If i >= 0 And i <= 15 Then
        CustomColor = alCustom(i)
    Else
        CustomColor = -1
    End If
End Property

Public Property Let CustomColor(i As Integer, iValue As Long)
    ' If first time, initialize to system colors
    If fNotFirst = False Then InitColors
    If i >= 0 And i <= 15 Then
        alCustom(i) = iValue
    End If
End Property

' ChooseFont wrapper   **** modified from original which works of in a dll but
'would not default the original fontname into the dlg as a module function.....
Function VBChooseFont(CurFont As Font, _
                      Optional PrinterDC As Long = -1, _
                      Optional owner As Long = -1, _
                      Optional Color As Long = vbBlack, _
                      Optional MinSize As Long = 0, _
                      Optional MaxSize As Long = 0, _
                      Optional flags As Long = 0) As Boolean

    Dim hMem As Long, pMem As Long, RetVal As Long   ' handle and pointer to memory buffer

    ' Unwanted Flags bits
    Const CF_FontNotSupported = CF_APPLY Or CF_ENABLEHOOK Or CF_ENABLETEMPLATE 'Or CF_NOFACESEL

    ' Flags can get reference variable or constant with bit flags
    ' PrinterDC can take printer DC
    If PrinterDC = -1 Then
        PrinterDC = 0
        If flags And CF_PRINTERFONTS Then PrinterDC = Printer.hDC
    Else
        flags = flags Or CF_PRINTERFONTS
    End If
    ' Must have some fonts
    If (flags And CF_PRINTERFONTS) = 0 Then flags = flags Or CF_SCREENFONTS
    ' Color can take initial color, receive chosen color
    If Color <> vbBlack Then flags = flags Or CF_EFFECTS
    ' MinSize can be minimum size accepted
    If MinSize Then flags = flags Or CF_LIMITSIZE
    ' MaxSize can be maximum size accepted
    If MaxSize Then flags = flags Or CF_LIMITSIZE

    ' Put in required internal flags and remove unsupported
    flags = (flags Or CF_INITTOLOGFONTSTRUCT) And Not CF_FontNotSupported

    ' Initialize LOGFONT variable
    Dim fnt As LOGFONT
    Const PointsPerTwip = 1440 / 72
    fnt.lfHeight = -(CurFont.Size * (PointsPerTwip / Screen.TwipsPerPixelY))
    fnt.lfWeight = CurFont.Weight
    fnt.lfItalic = CurFont.Italic
    fnt.lfUnderline = CurFont.Underline
    fnt.lfStrikeOut = CurFont.Strikethrough

    ' Other fields zero
'''    StrToBytes fnt.lfFaceName, CurFont.Name & vbNullChar  'tLib use
    fnt.lfFaceName = CurFont.Name & vbNullChar

    'added
    ' Create the memory block which will act as the LOGFONT structure buffer.
    hMem = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(fnt))
    pMem = GlobalLock(hMem)  ' lock and get pointer
    CopyMemory ByVal pMem, fnt, ByVal Len(fnt)  ' copy structure's contents into block


    ' Initialize TCHOOSEFONT variable
    Dim cf As TCHOOSEFONT
    cf.lStructSize = Len(cf)
    If owner <> -1 Then cf.hwndOwner = owner
    cf.hDC = PrinterDC
    cf.lpLogFont = pMem      'VarPtr(fnt)
    cf.iPointSize = CurFont.Size * 10
    cf.flags = flags
    cf.rgbColors = Color
    cf.nSizeMin = MinSize
    cf.nSizeMax = MaxSize
    ' All other fields zero

    If ChooseFont(cf) Then
        VBChooseFont = True
        'added
        CopyMemory fnt, ByVal pMem, ByVal Len(fnt)  ' copy memory back

        flags = cf.flags
        Color = cf.rgbColors
        CurFont.Bold = cf.nFontType And BOLD_FONTTYPE
        'CurFont.Italic = cf.nFontType And ITALIC_FONTTYPE
        CurFont.Italic = fnt.lfItalic
        CurFont.Strikethrough = fnt.lfStrikeOut
        CurFont.Underline = fnt.lfUnderline
        CurFont.Weight = fnt.lfWeight
        CurFont.Size = cf.iPointSize / 10
'''        CurFont.Name = BytesToStr(fnt.lfFaceName)  'typeLib use
        ' Now make the fixed-length string holding the font name into a "normal" string.
        CurFont.Name = Left(fnt.lfFaceName, InStr(fnt.lfFaceName, vbNullChar) - 1)
'Debug.Print CurFont.Name
    Else
        VBChooseFont = False
    End If
    'added  ' Deallocate the memory block we created earlier.  Note that this must
    ' be done whether the function succeeded or not.
    RetVal = GlobalUnlock(hMem)  ' destroy pointer, unlock block
    RetVal = GlobalFree(hMem)  ' free the allocated memory
End Function


Public Sub StrToBytes(ab() As Byte, s As String, Optional bForceUniCode As Boolean = False)
    If IsArrayEmpty(ab) Then
        ' Assign to empty array
        ab = StrConv(s, vbFromUnicode)
Debug.Print "empty ab()"
    Else
        Dim cab As Long
        ' Copy to existing array, padding or truncating if necessary
        cab = UBound(ab) - LBound(ab) + 1
        If Len(s) < cab Then s = s & String$(cab - Len(s), 0)
        If UnicodeTypeLib Or bForceUniCode Then
            Dim st As String
            st = StrConv(s, vbFromUnicode)
            'CopyMemoryStr ab(LBound(ab)), st, ByVal cab
CopyMemory ab(LBound(ab)), st, ByVal cab
        Else
            'CopyMemoryStr ab(LBound(ab)), s, ByVal cab
CopyMemory ab(LBound(ab)), s, ByVal cab
        End If
    End If
    
'Dim i As Integer