mborrowedcode.bas

vb从网上取数据

    On Error Resume Next

    'A Socket is open
    If Sock > 0 Then
        Do
            DoEvents
            'Receive up to 8192 chars
            iBytes = recv(Sock, ByVal MsgBuffer, 8192, 0)
            If iBytes > 0 And iBytes <> SOCKET_ERROR Then
                sServerResponse$ = sServerResponse$ & Mid$(MsgBuffer, 1, iBytes)
            End If
        Loop Until iBytes = 0
        CloseSocket (Sock)
        Call EndWinsock 'Very important!
        Sock = 0
    End If
      
    GetFromInet$ = sServerResponse$

End Function

Public Sub EndWinsock()

  Dim ret&

    If WSAIsBlocking() Then
        ret = WSACancelBlockingCall()
    End If
    ret = WSACleanup()
    WSAStartedUp = False

End Sub

Private Function StartWinsock(Optional sDescription As String) As Boolean

  Dim StartupData As WSADATA
  Dim RC As Long

    If Not WSAStartedUp Then
        If Not WSAStartup(&H101, StartupData) Then
            RC = WSAStartup(&H101, StartupData)
            WSAStartedUp = True
'Debug.Print "wVersion="; StartupData.wVersion, "wHighVersion="; StartupData.wHighVersion
'Debug.Print "If wVersion = 257 then everything is kewl"
'Debug.Print "szDescription="; StartupData.szDescription
'Debug.Print "szSystemStatus="; StartupData.szSystemStatus
'Debug.Print "iMaxSockets="; StartupData.iMaxSockets, "iMaxUdpDg="; StartupData.iMaxUdpDg
            sDescription = StartupData.szDescription
          Else
            WSAStartedUp = False
        End If
      Else
        Call EndWinsock
        Call StartWinsock
    End If
    StartWinsock = WSAStartedUp

End Function
'returns IP as long, in network byte order
Private Function GetHostByNameAlias(ByVal hostname$) As Long

  Dim phe&
  Dim heDestHost As HOSTENT
  Dim addrList&
  Dim retIP&

    retIP = inet_addr(hostname$)
    If retIP = INADDR_NONE Then
        phe = gethostbyname(hostname$)
        If phe <> 0 Then
            CopyMemory heDestHost, ByVal phe, hostent_size
            CopyMemory addrList, ByVal heDestHost.h_addr_list, 4
            CopyMemory retIP, ByVal addrList, heDestHost.h_length
          Else
            retIP = INADDR_NONE
        End If
    End If
    GetHostByNameAlias = retIP

End Function

Private Function SendData(ByVal intSocket&, vMessage As Variant) As Long

  Dim TheMsg() As Byte, sTemp$

    TheMsg = ""
    Select Case VarType(vMessage)
      Case 8209   'byte array
        sTemp = vMessage
        TheMsg = sTemp
      Case 8      'string, if we receive a string, its assumed we are linemode
        sTemp = StrConv(vMessage, vbFromUnicode)
      Case Else
        sTemp = CStr(vMessage)
        sTemp = StrConv(vMessage, vbFromUnicode)
    End Select
    
    TheMsg = sTemp
    
    If UBound(TheMsg) > -1 Then
        SendData = send(intSocket, TheMsg(0), UBound(TheMsg) + 1, 0)
    End If
    
    If SendData = SOCKET_ERROR Then
        CloseSocket intSocket
        Call EndWinsock
        Exit Function
    End If

End Function
Public Function IsConnected() As Boolean
    'this function will not determine between a inet conn. or LAN...js
    On Error GoTo Err
    IsConnected = InternetGetConnectedState(0&, 0&)
Exit Function
Err:
    IsConnected = True
End Function
'******************End Winsock code*******************
'*****************begin Conn Code**************
'Tip by John Percival From VB - World
Public Function Online() As Boolean
    'If you are online it will return True, otherwise False
    Online = InternetGetConnectedState(0&, 0&)
End Function

Public Function ViaLAN() As Boolean
    Dim SFlags As Long
    'return the flags associated with the connection
    Call InternetGetConnectedState(SFlags, 0&)
    'True if the Sflags has a LAN connection
    ViaLAN = SFlags And INTERNET_CONNECTION_LAN
End Function
Public Function ViaModem() As Boolean
    Dim SFlags As Long
    'return the flags associated with the connection
    Call InternetGetConnectedState(SFlags, 0&)
    'True if the Sflags has a modem connection
    ViaModem = SFlags And INTERNET_CONNECTION_MODEM
End Function

'*****************end conn code***************************

''******************Begin Oleg's code*****************************
'Public Function vbRecv(ByVal lngSocket As Long, strBuffer As String) As Long
''********************************************************************************
''Author    :Oleg Gdalevich
''Date/Time :27-Nov-2001
''Purpose   :Retrieves data from the Winsock buffer.
''Returns   :Number of bytes received.
''Arguments :lngSocket    - the socket connected to the remote host
''           strBuffer    - buffer to read data to
''********************************************************************************
'    '
'    Const MAX_BUFFER_LENGTH As Long = 8192
'    '
'    Dim arrBuffer(1 To MAX_BUFFER_LENGTH)   As Byte
'    Dim lngBytesReceived                    As Long
'    Dim strTempBuffer                       As String
'    '
'    'Check the socket for readabilty with
'    'the IsDataAvailable function
'    If IsDataAvailable(lngSocket) Then
'        '
'        'Call the recv Winsock API function in order to read data from the buffer
'        lngBytesReceived = Recv(lngSocket, arrBuffer(1), MAX_BUFFER_LENGTH, 0&)
'        '
'        If lngBytesReceived > 0 Then
'            '
'            'If we have received some data, convert it to the Unicode
'            'string that is suitable for the Visual Basic String data type
'            strTempBuffer = StrConv(arrBuffer, vbUnicode)
'            '
'            'Remove unused bytes
'            strBuffer = Left$(strTempBuffer, lngBytesReceived)
'            '
'        End If
'        '
'        'If lngBytesReceived is equal to 0 or -1, we have nothing to do with that
'        '
'        vbRecv = lngBytesReceived
'        '
'    Else
'        '
'        'Something wrong with the socket.
'        'Maybe the lngSocket argument is not a valid socket handle at all
'        vbRecv = SOCKET_ERROR
'        '
'    End If
'    '
'End Function
'Public Function IsDataAvailable(ByVal lngSocket As Long) As Boolean
'    '
'    Dim udtRead_fd As fd_set
'    Dim udtWrite_fd As fd_set
'    Dim udtError_fd As fd_set
'    Dim lngSocketCount As Long
'    '
'    udtRead_fd.fd_count = 1
'    udtRead_fd.fd_array(1) = lngSocket
'    '
'    lngSocketCount = vbselect(0&, udtRead_fd, udtWrite_fd, udtError_fd, 0&)
'    '
'    IsDataAvailable = CBool(lngSocketCount)
'    '
'End Function
'
'
''******************End Oleg's code*****************************

'*******************Begin *************************************
'I modified this one too......js
'=====================================================================================
' Browse for a Folder using SHBrowseForFolder API function with a callback
' function BrowseCallbackProc.
'
' Stephen Fonnesbeck
' [e-mail]
' http://www.xmission.com/~steev
' Feb 20, 2000
'=============================================================
Public Function BrowseForFolder(Optional ihWnd As Long = 0, _
                                Optional sTitle As String = "Select Folder", _
                                Optional sStartDir As String, _
                                Optional bAddDir As Boolean = False) As String
  'Opens a Treeview control that displays the directories in a computer

  Dim lpIDList As Long
  Dim szTitle As String
  Dim sBuffer As String
  Dim tBrowseInfo As BROWSEINFO
  
  If sStartDir$ = sEmpty Then  'added... js
    If m_CurrentDirectory = sEmpty Then
        m_CurrentDirectory = App.Path
    End If
  Else
    m_CurrentDirectory = sStartDir$ & vbNullChar
  End If
  
  szTitle = sTitle$
  With tBrowseInfo
    .hwndOwner = ihWnd
    .lpszTitle = lstrcat(szTitle, "")
    If bAddDir = True Then  'added...js  Note...isn't working....
        .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_EDITBOX Or BIF_STATUSTEXT
    Else
        .ulFlags = BIF_RETURNONLYFSDIRS + BIF_STATUSTEXT
    End If
    .lpfn = GetAddressofFunction(AddressOf BrowseCallbackProc)  'get address of function.
  End With
  
  CenterDlgBox ihWnd  'added...js
  
  lpIDList = SHBrowseForFolder(tBrowseInfo)
  If (lpIDList) Then
    sBuffer$ = Space(cMaxPath)
    SHGetPathFromIDList lpIDList, sBuffer$
    sBuffer$ = Left(sBuffer$, InStr(sBuffer$, vbNullChar) - 1)
    BrowseForFolder = sBuffer$
    m_CurrentDirectory = sBuffer$
  Else
    BrowseForFolder = ""
  End If
  
End Function
 
Private Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
  
  Dim lpIDList As Long
  Dim ret As Long
  Dim sBuffer As String
  
  On Error Resume Next  'Sugested by MS to prevent an error from
                        'propagating back into the calling process.
     
  Select Case uMsg
  
    Case BFFM_INITIALIZED
      Call SendMessage(hWnd, BFFM_SETSELECTION, 1, m_CurrentDirectory)
      
    Case BFFM_SELCHANGED
      sBuffer = Space(cMaxPath)
      
      ret = SHGetPathFromIDList(lp, sBuffer)
      If ret = 1 Then
        Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, 0, sBuffer)
      End If
      
  End Select
  
  BrowseCallbackProc = 0
  
End Function

' This function allows you to assign a function pointer to a vaiable.
Private Function GetAddressofFunction(add As Long) As Long
  GetAddressofFunction = add
End Function


'*******************End************************************************

'********************Begin code
'Microsoft Knowledge Base Article - Q189170
Function MakeDWord(LoWord As Integer, HiWord As Integer) As Long
   MakeDWord = (HiWord * &H10000) Or (LoWord And &HFFFF&)
End Function

Function LoWord(DWord As Long) As Integer
   If DWord And &H8000& Then ' &H8000& = &H00008000
      LoWord = DWord Or &HFFFF0000
   Else
      LoWord = DWord And &HFFFF&
   End If
End Function

Function HiWord(DWord As Long) As Integer
   HiWord = (DWord And &HFFFF0000) \ &H10000
End Function
'********************end code