mborrowedcode.bas

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

        If m_lngRegion <> 0 Then DeleteObject m_lngRegion
        m_lngRegion = ExtCreateRegion(ByVal 0&, UBound(abytRegion) + 1, abytRegion(0))
    End If
End Sub
Public Sub Apply(ByVal hWnd As Long, ByVal m_lngRegion As Long)
    SetWindowRgn hWnd, m_lngRegion, True
End Sub

'***End FormShaper code********************************************

'********Begin*****************************
    
Public Sub GetAndSaveSnapShot()  'sub renamed
    'KPD-Team 2000
    'URL: http://www.allapi.net/
    'E-Mail: [e-mail]
    '-> Compile this code for better performance
    Dim bi24BitInfo As BITMAPINFO, bBytes() As Byte, Cnt As Long
    Dim iDC As Long, iBitmap As Long, iHPicDC As Long, iHBitmapOld As Long
    
    With bi24BitInfo.bmiHeader
        .biBitCount = 24
        .biCompression = BI_RGB
        .biPlanes = 1
        .biSize = Len(bi24BitInfo.bmiHeader)
        .biWidth = (frmMain.ScaleWidth) \ Screen.TwipsPerPixelX  '- frmMain.tbLeft.Width
        .biHeight = frmMain.ScaleHeight \ Screen.TwipsPerPixelY + GetSystemMetrics(SM_CYCAPTION)
        .biSizeImage = ((.biWidth * 3 + 3) And &HFFFFFFFC) * .biHeight
    End With
    ReDim bBytes(1 To bi24BitInfo.bmiHeader.biWidth * _
        bi24BitInfo.bmiHeader.biHeight * 3) As Byte
    'iDC = CreateCompatibleDC(0)
    frmMain.Picture = frmMain.Image  'added... speeds up the procedure greatly
    iDC = CreateCompatibleDC(frmMain.hDC)
    iBitmap = CreateDIBSection(iDC, bi24BitInfo, _
        DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&)
    iHBitmapOld = SelectObject(iDC, iBitmap)
    iHPicDC = GetWindowDC(frmMain.hWnd)
    'StretchBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, _
        bi24BitInfo.bmiHeader.biHeight, GetDC(0), 0, 0, _
            bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, vbSrcCopy
    StretchBlt iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, _
        bi24BitInfo.bmiHeader.biHeight, iHPicDC, 0, 0, _
            bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, vbSrcCopy
    GetDIBits iDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, bBytes(1), _
        bi24BitInfo, DIB_RGB_COLORS
    
    'not using pb for saving...
    'SetDIBitsToDevice frmMain.picSnap.hdc, 0, 0, _
        bi24BitInfo.bmiHeader.biWidth, _
        bi24BitInfo.bmiHeader.biHeight, 0, 0, 0, _
        bi24BitInfo.bmiHeader.biHeight, bBytes(1), bi24BitInfo, DIB_RGB_COLORS
    Call SelectObject(iDC, iHBitmapOld)
    DeleteDC iDC
    DeleteObject iBitmap
    Call ReleaseDC(frmMain.hWnd, iHPicDC)
    '***** Added code
    Call SaveBmp2File(bi24BitInfo, bBytes())
End Sub
'**************End *************************

'************Begin code*****************
Public Function RotateText(inObj As Object, x As Single, y As Single, inText As String, _
        Optional inFontName As String = "Arial", Optional inBold As Boolean = False, _
        Optional inItalic As Boolean = False, Optional inFontSize As Integer = 12, _
        Optional iAngle As Long = 0, Optional iOriention As Long = 0, _
        Optional iColor As Long = vbBlack, Optional iROP As Long = vbCopyPen, _
        Optional fDoIndividualChars As Boolean = False, _
        Optional rDoIndDelay As Single = 0) As Boolean
    On Error GoTo errHandler
' TextEffect.frm
'
' By Herman Liu

    'I deleted code that wasn't needed, modified parts of it and added others
    RotateText = False

    Dim L As LOGFONT, HFont As Long, oldROP As Long, wTextParams As DRAWTEXTPARAMS
    Dim mPrevFont As Long, i As Integer, origMode As Integer, sFontName As String
    Dim tmpX As Single, tmpY As Single, iTC As Long, iBG As Long
    Dim mresult As Long, ReturnSL As SIZEL, RC As RECT

     ' For Windows NT to work
    mresult = SetGraphicsMode(inObj.hDC, GM_ADVANCED)

    origMode = inObj.ScaleMode
    inObj.ScaleMode = vbPixels

    If inBold = True And inItalic = True Then
        'L.lfFaceName = inFontName & Space(1) & "Bold" & Space(1) & "Italic" & Chr(0)    ' Must be null terminated
        sFontName$ = inFontName$ & Space(1) & "Bold" & Space(1) & "Italic" & Chr(0)
    ElseIf inBold = True And inItalic = False Then
        'L.lfFaceName = inFontName & Space(1) & "Bold" + Chr$(0)
        sFontName$ = inFontName$ & Space(1) & "Bold" + Chr$(0)
    ElseIf inBold = False And inItalic = True Then
        'L.lfFaceName = inFontName & Space(1) & "Italic" + Chr$(0)
        sFontName$ = inFontName$ & Space(1) & "Italic" + Chr$(0)
    Else
        'L.lfFaceName = inFontName & Chr$(0)
        sFontName$ = inFontName$ & Chr$(0)
    End If
    'Call StrToBytes(L.lfFaceName, sFontName$)
    L.lfFaceName = sFontName$
    
    L.lfOutPrecision = OUT_TT_PRECIS
    L.lfQuality = ANTIALIASED_QUALITY   ' PROOF_QUALITY
    L.lfOrientation = iOriention * 10
    L.lfEscapement = iAngle * 10
    L.lfHeight = inFontSize * -20 / Screen.TwipsPerPixelY

    HFont = CreateFontIndirect(L)
    mPrevFont = SelectObject(inObj.hDC, HFont)
    
    oldROP = SetROP2(inObj.hDC, iROP)
    iTC = SetTextColor(inObj.hDC, iColor)
    iBG = SetBkMode(inObj.hDC, TRANSPARENT)
    wTextParams.cbSize = Len(wTextParams)
    
    'added the following to draw individual chars of a string... js
    'couldn't get the lfEscapement to work with single chars so
    'improvised with some trig and the string width
    If fDoIndividualChars Then
        Dim s As String, sL As String, iCharWidth As Long, iWTotal As Long, rOffset As Single
        For i = 1 To Len(inText)
            s$ = Mid$(inText, i, 1) 'current char to draw
            sL$ = Left$(inText, i)  'string up to the current char-need for rect
            Call GetCharWidth32(inObj.hDC, Asc(s$), Asc(s$), iCharWidth) 'current char width
            iWTotal = iWTotal + iCharWidth  'width total
            rOffset = Tan((PI / 180) * -iAngle) * iWTotal  'char y offset
'Debug.Print s$; " "; iCharWidth; "  "; rOffset
            Call GetTextExtentPoint32(inObj.hDC, sL$, Len(sL$), ReturnSL) 'total extent to current char
            With RC
                .Left = x
                .Top = y + rOffset  ''(i * 1) \ 2 '-iAngle ' 2
                .Right = x + ReturnSL.cx
                .Bottom = y + ReturnSL.cy + rOffset  ''(i * 1) \ 2  '-iAngle ' 2
            End With
            Call DrawTextEx(inObj.hDC, s$, Len(s$), RC, DT_RIGHT Or DT_NOCLIP Or DT_WORDBREAK, wTextParams)   'Or DT_VCENTER  'DT_RIGHT
            If rDoIndDelay <> 0 Then 'add a delay to simulate actual typing
                inObj.Refresh
                Delay rDoIndDelay
            End If
        Next
        'inObj.Refresh
    Else
        Call GetTextExtentPoint32(inObj.hDC, inText, Len(inText), ReturnSL)
        With RC
            .Left = x
            .Top = y
            .Right = x + ReturnSL.cx
            .Bottom = y + ReturnSL.cy
        End With
        'wTextParams.cbSize = Len(wTextParams)
        'TextHeightRet = ReturnSL.cy
        'TextWidthRet = ReturnSL.cx
        Call DrawTextEx(inObj.hDC, inText, Len(inText), RC, DT_CENTER Or DT_NOCLIP Or DT_VCENTER Or DT_WORDBREAK, wTextParams)
    End If
    
    mresult = SelectObject(inObj.hDC, mPrevFont)
    mresult = DeleteObject(HFont)
    inObj.ScaleMode = origMode
    Call SetTextColor(inObj.hDC, iTC)
    Call SetBkMode(inObj.hDC, iBG)
    Call SetROP2(inObj.hDC, oldROP)
    RotateText = True
    Exit Function

errHandler:
    inObj.ScaleMode = origMode
    MsgBox "RotateText Function Error"
End Function
'********************end code********************

'********************Begin Code*******************
'I have modified parts of the following code...js
'Removed proxy stuff, added undeclared variables, converted to function,
'removed the async and callback to textbox mouseUp event...
'save to a temp string variable and return it with the fuction


'********************
'Modifications and improvements by Luis Cantero (2002)
'Modifications: ListenForConnect, Ping, GetMXName, GetDNSInfo, MyIP, SendData, etc.
'http://LCenterprises.net
'********************

'Visual Basic 6.0 Winsock "Header"
'   Alot of the information contained inside this file was originally
'   obtained from ALT.WINSOCK.PROGRAMMING and most of it has since been
'   modified in some way.
'
'Disclaimer: This file is public domain, updated periodically by
'   Topaz, [e-mail], Use it at your own risk.
'   Neither myself(Topaz) or anyone related to alt.programming.winsock
'   may be held liable for its use, or misuse.
'
'Declare check Aug 27, 1996. (Topaz, [e-mail])
'   All 16 bit declarations appear correct, even the odd ones that
'   pass longs inplace of in_addr and char buffers. 32 bit functions
'   also appear correct. Some are declared to return integers instead of
'   longs (breaking MS's rules.) however after testing these functions I
'   have come to the conclusion that they do not work properly when declared
'   following MS's rules.
Public Function GetFromInet(strURL As String) As String

  Dim SocketBuffer As SOCKADDR, strPath As String, strHost As String, intPort As Long
  Dim IpAddr As Long, iSlashPos As Long, RC As Long, i As Long
  Dim tmpHost As String, strMsg As String, sStart As String
    
    'Remove leading http or https
    If StrComp(Left$(strURL$, 4), "http", vbTextCompare) = 0 Then
        iSlashPos = InStr(5, strURL$, "/")
        strURL$ = Mid$(strURL$, iSlashPos + 2)
    End If
    
    'Separate URL into Host and Path
    iSlashPos = InStr(1, strURL, "/")
    If iSlashPos = 0 Then iSlashPos = Len(strURL) + 1
    strPath = Mid$(strURL, iSlashPos)
    If strPath = "" Then strPath = "/"
    strHost = Mid$(strURL, 1, iSlashPos - 1)
    intPort = 80

    'sStart winsock
    Call StartWinsock

    'Create socket
    Sock = Socket(AF_INET, SOCK_STREAM, 0)
    If Sock = SOCKET_ERROR Then frmDownLoad.lblStatus.Caption = "SOCKET_ERROR: CreateSocket": Exit Function

    If RC = SOCKET_ERROR Then frmDownLoad.lblStatus.Caption = "SOCKET_ERROR CreateSocket-rc":  Exit Function
    IpAddr = GetHostByNameAlias(strHost)
    If IpAddr = -1 Then
        frmDownLoad.lblStatus.Caption = "Unknown host"
        Exit Function
    End If
    
    With SocketBuffer
        .sin_family = AF_INET
        .sin_port = htons(intPort)
        .sin_addr = IpAddr
        '.sin_zero = String$(8, 0)
        For i = 0 To 7
            .sin_zero(i) = 0  'String$(8, 0)
        Next
    End With
    
    frmDownLoad.lblStatus.Caption = "Connecting to " & strHost
    DoEvents
    
    'Connect to server
    RC = Connect(Sock, SocketBuffer, Len(SocketBuffer))
    
    If RC = SOCKET_ERROR Then
        CloseSocket Sock
        Call EndWinsock
        frmDownLoad.lblStatus.Caption = "Could not connect to " & strHost
        Exit Function
      Else
    End If
    
    frmDownLoad.lblStatus.Caption = "Connected to " & strHost
    DoEvents

'I'm not using a textbox to store the text in so....
''    'Set receive window
''    RC = WSAAsyncSelect(Sock, frmDownLoad.txtReceive.hWnd, _
''         ByVal &H202, ByVal FD_READ Or FD_CLOSE)
''    If RC = SOCKET_ERROR Then
''        CloseSocket Sock
''        Call EndWinsock
''        frmDownLoad.lblStatus.Caption = "SOCKET_ERROR: SetReceiveWindow"
''        Exit Sub
''    End If
    
    'Prepare GET header
    'When to use GET? -> When the amount of data that you
    'need to pass to the server is not much
    strMsg = "GET " & tmpHost & strPath & " HTTP/1.0" & vbCrLf
    strMsg = strMsg & "Accept: */*" & vbCrLf
    strMsg = strMsg & "User-Agent: " & App.Title & vbCrLf
    strMsg = strMsg & "Host: " & strHost & vbCrLf
    strMsg = strMsg & vbCrLf
    
    'Example POST header
    'When to use POST? -> Anytime, it is failsafe since the
    'content-length is passed to the server everytime
    'strCommand = "Temp1=hello&temp2=12345&Etc=hallo"
    'strMsg = "POST " & tmpHost & strPath & " HTTP/1.0" & vbCrLf
    'strMsg = strMsg & "Accept: */*" & vbCrLf
    'strMsg = strMsg & "User-Agent: " & App.Title & vbCrLf
    'strMsg = strMsg & "Host: " & strHost & vbCrLf
    'strMsg = strMsg & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
    'strMsg = strMsg & "Content-Length: " & Len(strCommand) & vbCrLf
    'strMsg = strMsg & vbCrLf & strCommand
    
    frmDownLoad.lblStatus.Caption = "Sending request..."
    DoEvents
    
    'Send request
    SendData Sock, strMsg
    
    If tmpHost = "" Then tmpHost = strHost
    
    'Wait for page to be downloaded
    'Seconds to wait = 10
    sStart = (Format$(Now, "NN") * 60 + Format$(Now, "SS")) + 10
    While Not sStart <= (Format$(Now, "NN") * 60 + Format$(Now, "SS")) And Sock > 0
        frmDownLoad.lblStatus.Caption = "Waiting for response from " & tmpHost '& "..." & sStart - (Format$(Now, "NN") * 60 + Format$(Now, "SS"))
        DoEvents
        
        'You can put a routine that will check if a boolean variable is True here
        'This could indicate that the request has been canceled
        'If CancelFlag = True Then
        '   frmdownload.lblstatus.caption = "Cancelled request"
        '   Exit Sub
        'End If
    Wend
    
    frmDownLoad.lblStatus.Caption = "Ready"
'
'*****Here is where I add the code to save the data in a string variable
'instead of sending it to the textbox. Bits and pieces of this are from vbapi.com
        
    Dim MsgBuffer As String * 8192, sServerResponse As String, iBytes As Integer