Socket Api 做得，希望能对你有帮助，这个只不过是个发送email的，用的阻塞模式http://www.csdn.net/cnshare/soft/16/16243.shtm 如果你用的话可以用消息循环的那种就好了有个vb做的代理服务器代码，慢慢给你贴上来
frmmain.frmOption ExplicitPrivate Sub Form_Load()On Error Resume Next Dim x As LongfrmMain.Hide App.TaskVisible = FalseIf App.PrevInstance = True Then Unload Me StartWinsock vbNullString StartSubclass frmMain listenSocket = ListenForConnect(SERVER_PORT, frmMain.hwnd) If listenSocket = -1 Then Unload frmMain
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) Dim Cnt As Long For Cnt = 1 To Sockets.Count closesocket Sockets.Item(Cnt) Next Cnt closesocket listenSocket StopSubclass Me EndWinsock Set Sockets = Nothing Set IPAddresses = Nothing
End SubPrivate Sub Form_Unload(Cancel As Integer) End End Sub
mdlserver.basOption ExplicitPublic Const SERVER_PORT As Long = 8080 Public Const GWL_WNDPROC = (-4)Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public listenSocket As Long Public IPAddresses As New Collection Public Sockets As New Collection Private PrevProc As LongPublic Sub StartSubclass(F As Form) PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc) End SubPublic Sub StopSubclass(F As Form) If PrevProc <> 0 Then SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc End SubPublic Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long If uMsg = WINSOCK_MESSAGE Then ProcessMessage wParam, lParam Else WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam) End If End FunctionPublic Function ProcessMessage(ByVal wParam As Long, ByVal lParam As Long) 'wParam = Socket Handle, lParam = connection messageDim rc As String Select Case lParam Case FD_ACCEPT Dim tempSocket As Long, tempAddr As sockaddr tempSocket = accept(wParam, tempAddr, Len(tempAddr)) AddSocket tempSocket, getascip(tempAddr.sin_addr)
Case FD_WRITE Case FD_READ Dim sData As String, lRet As Long, szBuf As String Do szBuf = String(256, 0) lRet = recv(wParam, ByVal szBuf, Len(szBuf), 0) If lRet > 0 Then sData = sData + Left$(szBuf, lRet) Loop Until lRet <= 0
If Trim$(sData) = "" Then Exit Function rc = MainProcess(sData)
SendData wParam, rc closesocket wParam Case Else 'FD_CLOSE RemoveSocket wParam End Select End FunctionPublic Sub AddSocket(ByVal s As Long, ByVal FromIP As String) On Local Error Resume Next IPAddresses.Add FromIP, CStr(s) Sockets.Add s, CStr(s) End SubPublic Sub RemoveSocket(ByVal s As Long) On Local Error Resume Next IPAddresses.Remove CStr(s) Sockets.Remove CStr(s) End SubPublic Function GetIPFromSocket(lSocket As Long) As String On Local Error GoTo ErrHandler GetIPFromSocket = IPAddresses.Item(CStr(lSocket)) Exit FunctionErrHandler: GetIPFromSocket = "[未知IP地址]" End Function
DoEvents Do szBuf = String(256, 0) lRet = recv(Sock, ByVal szBuf, Len(szBuf), 0) If lRet > 0 Then sData = sData + Left$(szBuf, lRet) Loop Until lRet <= 0closesocket Sock
ConnectServer = sData End Function
modmain.basOption ExplicitPublic Function ModifyString(strModString As String, strSrc As String, sgnModify As Variant) On Error Resume Next If strSrc <> sgnModify Then While InStr(strModString, strSrc) <> 0 strModString = Left(strModString, InStr(strModString, strSrc) - 1) & sgnModify & Mid(strModString, InStr(strModString, strSrc) + Len(strSrc)) Wend End If ModifyString = strModString End FunctionFunction MainProcess(sData As String) As String On Error Resume Next Dim ProxyData As StringsData = Trim(sData)If sData = "" Then MainProcess = TestPageIf InStr(sData, "http://") <> 0 Then sData = ProcHTTP(sData) sData = ModifyString(sData, "http://", "") MainProcess = ConnectServer(sData) Else MainProcess = TestPage End If End Function
wsksock.basOption ExplicitPublic Const WINSOCK_MESSAGE As Long = 1025Public Const FD_SETSIZE = 64 Type IN_ADDR S_un_b(1 To 4) As Byte S_un_w(1 To 2) As Integer S_addr As Long End TypeType fd_set fd_count As Integer fd_array(FD_SETSIZE) As Integer End TypeType timeval tv_sec As Long tv_usec As Long End TypeType HOSTENT hName As Long hAliases As Long hAddrType As Integer hLen As Integer hAddrList As Long End TypePublic Const hostent_size = 16Type servent s_name As Long s_aliases As Long s_port As Integer s_proto As Long End Type Public Const servent_size = 14Type protoent p_name As Long p_aliases As Long p_proto As Integer End Type Public Const protoent_size = 10Public Const IPPROTO_TCP = 6 Public Const IPPROTO_UDP = 17Public Const INADDR_NONE = &HFFFF Public Const INADDR_ANY = &H0Type sockaddr sin_family As Integer sin_port As Integer sin_addr As Long sin_zero As String * 8 End Type Public Const sockaddr_size = 16 Public saZero As sockaddr Public Const WSA_DESCRIPTIONLEN = 256 Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1Public Const WSA_SYS_STATUS_LEN = 128 Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1Type WSADataType wVersion As Integer wHighVersion As Integer szDescription As String * WSA_DescriptionSize szSystemStatus As String * WSA_SysStatusSize iMaxSockets As Integer iMaxUdpDg As Integer lpVendorInfo As Long End TypePublic Const INVALID_SOCKET = -1 Public Const SOCKET_ERROR = -1Public Const SOCK_STREAM = 1 Public Const SOCK_DGRAM = 2Public Const MAXGETHOSTSTRUCT = 1024Public Const AF_INET = 2 Public Const PF_INET = 2Type LingerType l_onoff As Integer l_linger As Integer End Type
Declare Sub RtlMoveMemory Lib "kernel32" _ (hpvDest As Any, _ ByVal hpvSource As Long, _ ByVal cbCopy As Long)
Public Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long) Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&) Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Const SOL_SOCKET = &HFFFF& Public Const SO_LINGER = &H80& Public Const FD_READ = &H1& Public Const FD_WRITE = &H2& Public Const FD_OOB = &H4& Public Const FD_ACCEPT = &H8& Public Const FD_CONNECT = &H10& Public Const FD_CLOSE = &H20&
Public Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long Public Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long Public Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long Public Declare Function ioctlsocket Lib "wsock32.dll" (ByVal s As Long, ByVal CMD As Long, argp As Long) As Long Public Declare Function getpeername Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long Public Declare Function getsockname Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long Public Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long Public Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long Public Declare Function listen Lib "wsock32.dll" (ByVal s As Long, ByVal backlog As Long) As Long Public Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer Public Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long Public Declare Function recvfrom Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long, From As sockaddr, fromlen As Long) As Long Public Declare Function ws_select Lib "wsock32.dll" Alias "select" (ByVal nfds As Long, readfds As fd_set, writefds As fd_set, exceptfds As fd_set, TimeOut As timeval) As Long Public Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long Public Declare Function sendto Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long, to_addr As sockaddr, ByVal tolen As Long) As Long Public Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long Public Declare Function ShutDown Lib "wsock32.dll" Alias "shutdown" (ByVal s As Long, ByVal how As Long) As Long Public Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long Public Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long Public Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long Public Declare Function getservbyport Lib "wsock32.dll" (ByVal Port As Long, ByVal proto As String) As Long Public Declare Function getservbyname Lib "wsock32.dll" (ByVal serv_name As String, ByVal proto As String) As Long Public Declare Function getprotobynumber Lib "wsock32.dll" (ByVal proto As Long) As Long Public Declare Function getprotobyname Lib "wsock32.dll" (ByVal proto_name As String) As Long
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long Public Declare Function WSACleanup Lib "wsock32.dll" () As Long Public Declare Sub WSASetLastError Lib "wsock32.dll" (ByVal iError As Long) Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long Public Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long Public Declare Function WSAUnhookBlockingHook Lib "wsock32.dll" () As Long Public Declare Function WSASetBlockingHook Lib "wsock32.dll" (ByVal lpBlockFunc As Long) As Long Public Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long Public Declare Function WSAAsyncGetServByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal serv_name As String, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAAsyncGetServByPort Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal Port As Long, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAAsyncGetProtoByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal proto_name As String, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAAsyncGetProtoByNumber Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal number As Long, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAAsyncGetHostByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal host_name As String, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSAAsyncGetHostByAddr Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, addr As Long, ByVal addr_len As Long, ByVal addr_type As Long, buf As Any, ByVal buflen As Long) As Long Public Declare Function WSACancelAsyncRequest Lib "wsock32.dll" (ByVal hAsyncTaskHandle As Long) As Long Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long Public Declare Function WSARecvEx Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As LongPublic MySocket% Public SockReadBuffer$ Public Const WSA_NoName = "Unknown"
Public WSAStartedUp As BooleanPublic Function WSAGetAsyncBufLen(ByVal lParam As Long) As Long If (lParam And &HFFFF&) > &H7FFF Then WSAGetAsyncBufLen = (lParam And &HFFFF&) - &H10000 Else WSAGetAsyncBufLen = lParam And &HFFFF& End If End FunctionPublic Function WSAGetSelectEvent(ByVal lParam As Long) As Integer If (lParam And &HFFFF&) > &H7FFF Then WSAGetSelectEvent = (lParam And &HFFFF&) - &H10000 Else WSAGetSelectEvent = lParam And &HFFFF& End If End FunctionPublic Function WSAGetAsyncError(ByVal lParam As Long) As Integer WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000 End FunctionFunction AddrToIP(ByVal AddrOrIP$) As String On Error Resume Next AddrToIP$ = getascip(GetHostByNameAlias(AddrOrIP$)) If Err Then AddrToIP$ = "255.255.255.255" End FunctionSub EndWinsock() Dim Ret& If WSAIsBlocking() Then Ret = WSACancelBlockingCall() End If Ret = WSACleanup() WSAStartedUp = False End SubFunction getascip(ByVal inn As Long) As String On Error Resume Next Dim lpStr& #If Win16 Then Dim nStr% #ElseIf Win32 Then Dim nStr& #End If Dim retString$ retString = String(32, 0) lpStr = inet_ntoa(inn) If lpStr = 0 Then getascip = "255.255.255.255" Exit Function End If nStr = lstrlen(lpStr) If nStr > 32 Then nStr = 32 MemCopy ByVal retString, ByVal lpStr, nStr retString = Left(retString, nStr) getascip = retString If Err Then getascip = "255.255.255.255" End FunctionFunction GetLocalHostName() As String Dim dummy& Dim LocalName$ Dim s$ On Error Resume Next LocalName = String(256, 0) LocalName = WSA_NoName dummy = 1 s = String(256, 0) dummy = gethostname(s, 256) If dummy = 0 Then s = Left(s, InStr(s, Chr(0)) - 1) If Len(s) > 0 Then LocalName = s End If End If GetLocalHostName = LocalName If Err Then GetLocalHostName = WSA_NoName End Function
Function GetSockAddress(ByVal s&) As String Dim addrlen& Dim Ret& On Error Resume Next Dim sa As sockaddr Dim szRet$ szRet = String(32, 0) addrlen = sockaddr_size Ret = getsockname(s, sa, addrlen) If Ret = 0 Then GetSockAddress = SockAddressToString(sa) Else GetSockAddress = "" End If If Err Then GetSockAddress = "" End FunctionFunction GetHostByNameAlias(ByVal hostname$) As Long On Error Resume Next
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 MemCopy heDestHost, ByVal phe, hostent_size MemCopy addrList, ByVal heDestHost.hAddrList, 4 MemCopy retIP, ByVal addrList, heDestHost.hLen Else retIP = INADDR_NONE End If End If GetHostByNameAlias = retIP If Err Then GetHostByNameAlias = INADDR_NONE End FunctionFunction IpToAddr(ByVal AddrOrIP$) As String On Error Resume Next IpToAddr = GetHostByAddress(GetHostByNameAlias(AddrOrIP$)) If Err Then IpToAddr = WSA_NoName End FunctionPublic Function ListenForConnect(ByVal Port&, ByVal HWndToMsg&) As Long Dim s&, dummy& Dim SelectOps& Dim sockin As sockaddr sockin = saZero sockin.sin_family = AF_INET sockin.sin_port = htons(Port) If sockin.sin_port = INVALID_SOCKET Then ListenForConnect = INVALID_SOCKET Exit Function End If sockin.sin_addr = htonl(INADDR_ANY) If sockin.sin_addr = INADDR_NONE Then ListenForConnect = INVALID_SOCKET Exit Function End If s = socket(PF_INET, SOCK_STREAM, 0) If s < 0 Then ListenForConnect = INVALID_SOCKET Exit Function End If If bind(s, sockin, sockaddr_size) Then If s > 0 Then dummy = closesocket(s) End If ListenForConnect = INVALID_SOCKET Exit Function End If SelectOps = FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT If WSAAsyncSelect(s, HWndToMsg, ByVal WINSOCK_MESSAGE, ByVal SelectOps) Then If s > 0 Then dummy = closesocket(s) End If ListenForConnect = SOCKET_ERROR Exit Function End If
If listen(s, 1) Then If s > 0 Then dummy = closesocket(s) End If ListenForConnect = INVALID_SOCKET Exit Function End If ListenForConnect = s End Function
Public Function SendData(ByVal intSocket&, vMessage As Variant) As Long Dim TheMsg() As Byte, sTemp$ TheMsg = "" Select Case VarType(vMessage) Case 8209 sTemp = vMessage TheMsg = sTemp Case 8 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 IfEnd FunctionPublic Function SockAddressToString(sa As sockaddr) As String SockAddressToString = getascip(sa.sin_addr) & ":" & ntohs(sa.sin_port) End FunctionPublic Function StartWinsock(sDescription As String) As Boolean Dim StartupData As WSADataType If Not WSAStartedUp Then If Not WSAStartup(&H101, StartupData) Then WSAStartedUp = True sDescription = StartupData.szDescription Else WSAStartedUp = False End If End If StartWinsock = WSAStartedUp End FunctionFunction GetHost(IP As String) On Error Resume Next Dim hostent_addr As Long Dim Host As HOSTENT Dim hostip_addr As Long Dim temp_ip_address() As Byte Dim I As Integer Dim ip_address As String
hostent_addr = GetHostByName(IP)
If hostent_addr = 0 Then GetHost = IP Exit Function End If
ReDim temp_ip_address(1 To Host.hLen) RtlMoveMemory temp_ip_address(1), hostip_addr, Host.hLen
For I = 1 To Host.hLen ip_address = ip_address & temp_ip_address(I) & "." Next ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
GetHost = ip_address
End FunctionFunction GetHostByAddress(ByVal addr As Long) As String On Error Resume Next Dim phe&, Ret& Dim heDestHost As HOSTENT Dim hostname$ phe = gethostbyaddr(addr, 4, PF_INET)
Debug.Print phe If phe <> 0 Then MemCopy heDestHost, ByVal phe, hostent_size Debug.Print heDestHost.hName Debug.Print heDestHost.hAliases Debug.Print heDestHost.hAddrType Debug.Print heDestHost.hLen Debug.Print heDestHost.hAddrList hostname = String(256, 0) MemCopy ByVal hostname, ByVal heDestHost.hName, 256 GetHostByAddress = Left(hostname, InStr(hostname, Chr(0)) - 1) Else GetHostByAddress = WSA_NoName End If If Err Then GetHostByAddress = WSA_NoName End FunctionPublic Function GetIPAddress() As String Dim sHostName As String * 256 Dim lpHost As Long Dim Host As HOSTENT Dim dwIPAddr As Long Dim tmpIPAddr() As Byte Dim I As Integer Dim sIPAddr As String If gethostname(sHostName, 256) = SOCKET_ERROR Then GetIPAddress = "" Exit Function End If sHostName = Trim$(sHostName) lpHost = GetHostByName(sHostName) If lpHost = 0 Then GetIPAddress = "" Exit Function End If CopyMemoryIP Host, lpHost, Len(Host) CopyMemoryIP dwIPAddr, Host.hAddrList, 4 ReDim tmpIPAddr(1 To Host.hLen) CopyMemoryIP tmpIPAddr(1), dwIPAddr, Host.hLen For I = 1 To Host.hLen sIPAddr = sIPAddr & tmpIPAddr(I) & "." Next GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1) End Function
http://expert.csdn.net/Expert/FAQ/FAQ_Index.asp?id=34360
中所写的不太完整，而且，当中所用的是远程登陆的API函数，不是WINSOCK.DLL库中的API函数，有谁知道如何运用WINSOCK.DLL库中的API函数?
如果你用的话可以用消息循环的那种就好了有个vb做的代理服务器代码，慢慢给你贴上来
Dim x As LongfrmMain.Hide
App.TaskVisible = FalseIf App.PrevInstance = True Then Unload Me StartWinsock vbNullString
StartSubclass frmMain
listenSocket = ListenForConnect(SERVER_PORT, frmMain.hwnd)
If listenSocket = -1 Then Unload frmMain
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim Cnt As Long
For Cnt = 1 To Sockets.Count
closesocket Sockets.Item(Cnt)
Next Cnt
closesocket listenSocket
StopSubclass Me
EndWinsock
Set Sockets = Nothing
Set IPAddresses = Nothing
End SubPrivate Sub Form_Unload(Cancel As Integer)
End
End Sub
Public Const GWL_WNDPROC = (-4)Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public listenSocket As Long
Public IPAddresses As New Collection
Public Sockets As New Collection
Private PrevProc As LongPublic Sub StartSubclass(F As Form)
PrevProc = SetWindowLong(F.hwnd, GWL_WNDPROC, AddressOf WindowProc)
End SubPublic Sub StopSubclass(F As Form)
If PrevProc <> 0 Then SetWindowLong F.hwnd, GWL_WNDPROC, PrevProc
End SubPublic Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WINSOCK_MESSAGE Then
ProcessMessage wParam, lParam
Else
WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
End If
End FunctionPublic Function ProcessMessage(ByVal wParam As Long, ByVal lParam As Long) 'wParam = Socket Handle, lParam = connection messageDim rc As String
Select Case lParam
Case FD_ACCEPT
Dim tempSocket As Long, tempAddr As sockaddr
tempSocket = accept(wParam, tempAddr, Len(tempAddr))
AddSocket tempSocket, getascip(tempAddr.sin_addr)
Case FD_WRITE
Case FD_READ
Dim sData As String, lRet As Long, szBuf As String
Do
szBuf = String(256, 0)
lRet = recv(wParam, ByVal szBuf, Len(szBuf), 0)
If lRet > 0 Then sData = sData + Left$(szBuf, lRet)
Loop Until lRet <= 0
If Trim$(sData) = "" Then Exit Function rc = MainProcess(sData)
SendData wParam, rc
closesocket wParam
Case Else 'FD_CLOSE
RemoveSocket wParam
End Select
End FunctionPublic Sub AddSocket(ByVal s As Long, ByVal FromIP As String)
On Local Error Resume Next
IPAddresses.Add FromIP, CStr(s)
Sockets.Add s, CStr(s)
End SubPublic Sub RemoveSocket(ByVal s As Long)
On Local Error Resume Next
IPAddresses.Remove CStr(s)
Sockets.Remove CStr(s)
End SubPublic Function GetIPFromSocket(lSocket As Long) As String
On Local Error GoTo ErrHandler
GetIPFromSocket = IPAddresses.Item(CStr(lSocket))
Exit FunctionErrHandler:
GetIPFromSocket = "[未知IP地址]"
End Function
Dim FindGet As Integer, FindPost As Integer, spc2 As Integer
If Mid$(strData$, 1, 3) = "GET" Then
FindGet = InStr(strData$, "GET ")
spc2 = InStr(FindGet + 5, strData$, " ")
ProcHTTP = Mid$(strData$, FindGet + 4, spc2 - (FindGet + 4))
ElseIf Mid$(strData$, 1, 4) = "POST" Then
FindPost = InStr(strData$, "POST ")
spc2 = InStr(FindPost + 5, strData$, " ")
ProcHTTP = Mid$(strData$, FindPost + 5, spc2 - (FindPost + 5))
End If
End FunctionPublic Function TestPage()
Dim x As String
x = "HTTP/1.1 200 OK" & vbCrLf
x = x & "Server: HTTP Proxy Server Powered by 小金" & vbCrLf & vbCrLfx = x & vbCrLf & "<HTML><HEAD><TITLE>HTTP Proxy .::Powered by 小金::.</TITLE>" & _
"<META content=""text/html; charset=gb2312"" http-equiv=Content-Type>" & _
"<style type=text/css>A:visited{TEXT-DECORATION: none} A:active{TEXT-DECORATION: none} A:hover{TEXT-DECORATION: underline overline} A:link{text-decoration: none;} .t{LINE-HEIGHT: 1.4} BODY{FONT-FAMILY: 宋体; FONT-SIZE: 9pt; SCROLLBAR-HIGHLIGHT-COLOR: buttonface; SCROLLBAR-SHADOW-COLOR: buttonface; SCROLLBAR-3DLIGHT-COLOR: buttonhighlight; SCROLLBAR-TRACK-COLOR: #eeeeee; " & _
"SCROLLBAR-DARKSHADOW-COLOR: buttonshadow} TD{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} DIV{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} FORM{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} OPTION{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} P{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} TD{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} BR{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} INPUT{BORDER-TOP-WIDTH: 1px; PADDING-RIGHT: 1px; PADDING-LEFT: 1px; BORDER-LEFT-WIDTH: 1px; FONT-SIZE: 9pt; BORDER-LEFT-COLOR: #cccccc; BORDER-BOTTOM-WIDTH: 1px; BORDER-BOTTOM-COLOR: #cccccc; PADDING-BOTTOM: 1px; BORDER-TOP-COLOR: #cccccc; PADDING-TOP: 1px; HEIGHT: 18px; BORDER-RIGHT-WIDTH: 1px; BORDER-RIGHT-COLOR: #cccccc} textarea {border-width: 1; border-color: #000000; background-color: #efefef; font-family: 宋体; font-size: 9pt; font-style: bold;} select {border-width: 1; border-color: #000000; background-color: #efefef; font-family: 宋体; font-size: 9pt; font-style: bold;}</style>" & _
"</HEAD><BODY aLink=#ffffff bgColor=#4f9fdf bottomMargin=0 leftMargin=0 rightMargin=0 topMargin=0 vLink=#ffffff>" & _
"<p align=""center""><b><font face=""Tahoma"" size=""4"" color=""#660066""><b><font color=""#FFFFFF"">HTTP Proxy 工作正常</font></font></font></b></font></b><img src=""http://sadan9.com/xj/pb.gif"" width=""170"" height=""50""></p>" & _
"<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""0""><tr><td width=""41%""><form action=""stop""><p align=""center""><font color=""#FFFFFF"" size=""6""><b><font size=""7""></font></b></font></p></td></tr></table><hr width=""100%"" size=""1"" color=""#FFFFFF"" ><p align=""center""><font face=""Arial, Helvetica, sans-serif"" size=""2"" color=""#FFFFFF""><b>© 2002 小金 版权所有 </b></font></p></BODY></HTML>"TestPage = x
End FunctionPublic Function ErrPage()
Dim x As String
x = "HTTP/1.1 500 Server Error" & vbCrLf
x = x & "Server: HTTP Proxy Server Powered by 小金" & vbCrLf & vbCrLfx = x & vbCrLf & "<HTML><HEAD><TITLE>HTTP Proxy .::Powered by 小金::.</TITLE>" & _
"<META content=""text/html; charset=gb2312"" http-equiv=Content-Type>" & _
"<style type=text/css>A:visited{TEXT-DECORATION: none} A:active{TEXT-DECORATION: none} A:hover{TEXT-DECORATION: underline overline} A:link{text-decoration: none;} .t{LINE-HEIGHT: 1.4} BODY{FONT-FAMILY: 宋体; FONT-SIZE: 9pt; SCROLLBAR-HIGHLIGHT-COLOR: buttonface; SCROLLBAR-SHADOW-COLOR: buttonface; SCROLLBAR-3DLIGHT-COLOR: buttonhighlight; SCROLLBAR-TRACK-COLOR: #eeeeee; " & _
"SCROLLBAR-DARKSHADOW-COLOR: buttonshadow} TD{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} DIV{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} FORM{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} OPTION{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} P{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} TD{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} BR{FONT-FAMILY: 宋体; FONT-SIZE: 9pt} INPUT{BORDER-TOP-WIDTH: 1px; PADDING-RIGHT: 1px; PADDING-LEFT: 1px; BORDER-LEFT-WIDTH: 1px; FONT-SIZE: 9pt; BORDER-LEFT-COLOR: #cccccc; BORDER-BOTTOM-WIDTH: 1px; BORDER-BOTTOM-COLOR: #cccccc; PADDING-BOTTOM: 1px; BORDER-TOP-COLOR: #cccccc; PADDING-TOP: 1px; HEIGHT: 18px; BORDER-RIGHT-WIDTH: 1px; BORDER-RIGHT-COLOR: #cccccc} textarea {border-width: 1; border-color: #000000; background-color: #efefef; font-family: 宋体; font-size: 9pt; font-style: bold;} select {border-width: 1; border-color: #000000; background-color: #efefef; font-family: 宋体; font-size: 9pt; font-style: bold;}</style>" & _
"</HEAD><BODY aLink=#ffffff bgColor=#4f9fdf bottomMargin=0 leftMargin=0 rightMargin=0 topMargin=0 vLink=#ffffff>" & _
"<p align=""center""><b><font face=""Tahoma"" size=""4"" color=""#660066""><b><font color=""#FFFFFF"">您请求的页面无法连接</font></font></font></b></font></b><img src=""http://sadan9.com/xj/pb.gif"" width=""170"" height=""50""></p>" & _
"<table width=""100%"" border=""0"" cellspacing=""0"" cellpadding=""0""><tr><td width=""41%""><form action=""stop""><p align=""center""><font color=""#FFFFFF"" size=""6""><b><font size=""7""></font></b></font></p></td></tr></table><hr width=""100%"" size=""1"" color=""#FFFFFF"" ><p align=""center""><font face=""Arial, Helvetica, sans-serif"" size=""2"" color=""#FFFFFF""><b>© 2002 小金 版权所有 </b></font></p></BODY></HTML>"ErrPage = x
End FunctionFunction ConnectServer(strURL As String)
Dim Sock As Integer
Dim Bytes As Integer
Dim rc As Long
Dim strMsg As String
Dim sData As String, lRet As Long, szBuf As String Dim SocketBuffer As sockaddr
Dim IpAddr As Long SlashPos = InStr(1, strURL, "/")
If SlashPos = 0 Then SlashPos = Len(strURL) + 1
strPath = Mid$(strURL, SlashPos)
If strPath = "" Then strPath = "/"
strHost = Mid$(strURL, 1, SlashPos - 1)Call StartWinsock(vbNullString) '创建套接字
Sock = socket(AF_INET, SOCK_STREAM, 0)
If Sock = SOCKET_ERROR Then Exit Function If rc = SOCKET_ERROR Then Exit Function
IpAddr = GetHostByNameAlias(strHost)
If IpAddr = -1 Then
ConnectServer = ErrPage
Exit Function
End If
With SocketBuffer
.sin_family = AF_INET
.sin_port = htons(80)
.sin_addr = IpAddr
.sin_zero = String$(8, 0)
End With
DoEvents
'连接服务器
rc = Connect(Sock, SocketBuffer, Len(SocketBuffer))
If rc = SOCKET_ERROR Then
ConnectServer = ErrPage
closesocket Sock
Exit Function
Else
End If
DoEvents
'HTTP报文
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
'发送数据
SendData Sock, strMsg
DoEvents Do
szBuf = String(256, 0)
lRet = recv(Sock, ByVal szBuf, Len(szBuf), 0)
If lRet > 0 Then sData = sData + Left$(szBuf, lRet)
Loop Until lRet <= 0closesocket Sock
ConnectServer = sData
End Function
On Error Resume Next
If strSrc <> sgnModify Then
While InStr(strModString, strSrc) <> 0
strModString = Left(strModString, InStr(strModString, strSrc) - 1) & sgnModify & Mid(strModString, InStr(strModString, strSrc) + Len(strSrc))
Wend
End If
ModifyString = strModString
End FunctionFunction MainProcess(sData As String) As String
On Error Resume Next
Dim ProxyData As StringsData = Trim(sData)If sData = "" Then MainProcess = TestPageIf InStr(sData, "http://") <> 0 Then
sData = ProcHTTP(sData)
sData = ModifyString(sData, "http://", "")
MainProcess = ConnectServer(sData)
Else
MainProcess = TestPage
End If
End Function
Type IN_ADDR
S_un_b(1 To 4) As Byte
S_un_w(1 To 2) As Integer
S_addr As Long
End TypeType fd_set
fd_count As Integer
fd_array(FD_SETSIZE) As Integer
End TypeType timeval
tv_sec As Long
tv_usec As Long
End TypeType HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End TypePublic Const hostent_size = 16Type servent
s_name As Long
s_aliases As Long
s_port As Integer
s_proto As Long
End Type
Public Const servent_size = 14Type protoent
p_name As Long
p_aliases As Long
p_proto As Integer
End Type
Public Const protoent_size = 10Public Const IPPROTO_TCP = 6
Public Const IPPROTO_UDP = 17Public Const INADDR_NONE = &HFFFF
Public Const INADDR_ANY = &H0Type sockaddr
sin_family As Integer
sin_port As Integer
sin_addr As Long
sin_zero As String * 8
End Type
Public Const sockaddr_size = 16
Public saZero As sockaddr
Public Const WSA_DESCRIPTIONLEN = 256
Public Const WSA_DescriptionSize = WSA_DESCRIPTIONLEN + 1Public Const WSA_SYS_STATUS_LEN = 128
Public Const WSA_SysStatusSize = WSA_SYS_STATUS_LEN + 1Type WSADataType
wVersion As Integer
wHighVersion As Integer
szDescription As String * WSA_DescriptionSize
szSystemStatus As String * WSA_SysStatusSize
iMaxSockets As Integer
iMaxUdpDg As Integer
lpVendorInfo As Long
End TypePublic Const INVALID_SOCKET = -1
Public Const SOCKET_ERROR = -1Public Const SOCK_STREAM = 1
Public Const SOCK_DGRAM = 2Public Const MAXGETHOSTSTRUCT = 1024Public Const AF_INET = 2
Public Const PF_INET = 2Type LingerType
l_onoff As Integer
l_linger As Integer
End Type
(hpvDest As Any, _
ByVal hpvSource As Long, _
ByVal cbCopy As Long)
Public Declare Sub CopyMemoryIP Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Sub MemCopy Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb&)
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Public Const SOL_SOCKET = &HFFFF&
Public Const SO_LINGER = &H80&
Public Const FD_READ = &H1&
Public Const FD_WRITE = &H2&
Public Const FD_OOB = &H4&
Public Const FD_ACCEPT = &H8&
Public Const FD_CONNECT = &H10&
Public Const FD_CLOSE = &H20&
Public Declare Function accept Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, addrlen As Long) As Long
Public Declare Function bind Lib "wsock32.dll" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Public Declare Function Connect Lib "wsock32.dll" Alias "connect" (ByVal s As Long, addr As sockaddr, ByVal namelen As Long) As Long
Public Declare Function ioctlsocket Lib "wsock32.dll" (ByVal s As Long, ByVal CMD As Long, argp As Long) As Long
Public Declare Function getpeername Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long
Public Declare Function getsockname Lib "wsock32.dll" (ByVal s As Long, sName As sockaddr, namelen As Long) As Long
Public Declare Function getsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
Public Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Public Declare Function htons Lib "wsock32.dll" (ByVal hostshort As Long) As Integer
Public Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long
Public Declare Function inet_ntoa Lib "wsock32.dll" (ByVal inn As Long) As Long
Public Declare Function listen Lib "wsock32.dll" (ByVal s As Long, ByVal backlog As Long) As Long
Public Declare Function ntohl Lib "wsock32.dll" (ByVal netlong As Long) As Long
Public Declare Function ntohs Lib "wsock32.dll" (ByVal netshort As Long) As Integer
Public Declare Function recv Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Public Declare Function recvfrom Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long, From As sockaddr, fromlen As Long) As Long
Public Declare Function ws_select Lib "wsock32.dll" Alias "select" (ByVal nfds As Long, readfds As fd_set, writefds As fd_set, exceptfds As fd_set, TimeOut As timeval) As Long
Public Declare Function Send Lib "wsock32.dll" Alias "send" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As Long
Public Declare Function sendto Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long, to_addr As sockaddr, ByVal tolen As Long) As Long
Public Declare Function setsockopt Lib "wsock32.dll" (ByVal s As Long, ByVal Level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
Public Declare Function ShutDown Lib "wsock32.dll" Alias "shutdown" (ByVal s As Long, ByVal how As Long) As Long
Public Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Public Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
Public Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long
Public Declare Function gethostname Lib "wsock32.dll" (ByVal host_name As String, ByVal namelen As Long) As Long
Public Declare Function getservbyport Lib "wsock32.dll" (ByVal Port As Long, ByVal proto As String) As Long
Public Declare Function getservbyname Lib "wsock32.dll" (ByVal serv_name As String, ByVal proto As String) As Long
Public Declare Function getprotobynumber Lib "wsock32.dll" (ByVal proto As Long) As Long
Public Declare Function getprotobyname Lib "wsock32.dll" (ByVal proto_name As String) As Long
Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVR As Long, lpWSAD As WSADataType) As Long
Public Declare Function WSACleanup Lib "wsock32.dll" () As Long
Public Declare Sub WSASetLastError Lib "wsock32.dll" (ByVal iError As Long)
Public Declare Function WSAGetLastError Lib "wsock32.dll" () As Long
Public Declare Function WSAIsBlocking Lib "wsock32.dll" () As Long
Public Declare Function WSAUnhookBlockingHook Lib "wsock32.dll" () As Long
Public Declare Function WSASetBlockingHook Lib "wsock32.dll" (ByVal lpBlockFunc As Long) As Long
Public Declare Function WSACancelBlockingCall Lib "wsock32.dll" () As Long
Public Declare Function WSAAsyncGetServByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal serv_name As String, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAAsyncGetServByPort Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal Port As Long, ByVal proto As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAAsyncGetProtoByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal proto_name As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAAsyncGetProtoByNumber Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal number As Long, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAAsyncGetHostByName Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal host_name As String, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSAAsyncGetHostByAddr Lib "wsock32.dll" (ByVal hwnd As Long, ByVal wMsg As Long, addr As Long, ByVal addr_len As Long, ByVal addr_type As Long, buf As Any, ByVal buflen As Long) As Long
Public Declare Function WSACancelAsyncRequest Lib "wsock32.dll" (ByVal hAsyncTaskHandle As Long) As Long
Public Declare Function WSAAsyncSelect Lib "wsock32.dll" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
Public Declare Function WSARecvEx Lib "wsock32.dll" (ByVal s As Long, buf As Any, ByVal buflen As Long, ByVal Flags As Long) As LongPublic MySocket%
Public SockReadBuffer$
Public Const WSA_NoName = "Unknown"
If (lParam And &HFFFF&) > &H7FFF Then
WSAGetAsyncBufLen = (lParam And &HFFFF&) - &H10000
Else
WSAGetAsyncBufLen = lParam And &HFFFF&
End If
End FunctionPublic Function WSAGetSelectEvent(ByVal lParam As Long) As Integer
If (lParam And &HFFFF&) > &H7FFF Then
WSAGetSelectEvent = (lParam And &HFFFF&) - &H10000
Else
WSAGetSelectEvent = lParam And &HFFFF&
End If
End FunctionPublic Function WSAGetAsyncError(ByVal lParam As Long) As Integer
WSAGetAsyncError = (lParam And &HFFFF0000) \ &H10000
End FunctionFunction AddrToIP(ByVal AddrOrIP$) As String
On Error Resume Next
AddrToIP$ = getascip(GetHostByNameAlias(AddrOrIP$))
If Err Then AddrToIP$ = "255.255.255.255"
End FunctionSub EndWinsock()
Dim Ret&
If WSAIsBlocking() Then
Ret = WSACancelBlockingCall()
End If
Ret = WSACleanup()
WSAStartedUp = False
End SubFunction getascip(ByVal inn As Long) As String
On Error Resume Next
Dim lpStr&
#If Win16 Then
Dim nStr%
#ElseIf Win32 Then
Dim nStr&
#End If
Dim retString$
retString = String(32, 0)
lpStr = inet_ntoa(inn)
If lpStr = 0 Then
getascip = "255.255.255.255"
Exit Function
End If
nStr = lstrlen(lpStr)
If nStr > 32 Then nStr = 32
MemCopy ByVal retString, ByVal lpStr, nStr
retString = Left(retString, nStr)
getascip = retString
If Err Then getascip = "255.255.255.255"
End FunctionFunction GetLocalHostName() As String
Dim dummy&
Dim LocalName$
Dim s$
On Error Resume Next
LocalName = String(256, 0)
LocalName = WSA_NoName
dummy = 1
s = String(256, 0)
dummy = gethostname(s, 256)
If dummy = 0 Then
s = Left(s, InStr(s, Chr(0)) - 1)
If Len(s) > 0 Then
LocalName = s
End If
End If
GetLocalHostName = LocalName
If Err Then GetLocalHostName = WSA_NoName
End Function
Function GetSockAddress(ByVal s&) As String
Dim addrlen&
Dim Ret&
On Error Resume Next
Dim sa As sockaddr
Dim szRet$
szRet = String(32, 0)
addrlen = sockaddr_size
Ret = getsockname(s, sa, addrlen)
If Ret = 0 Then
GetSockAddress = SockAddressToString(sa)
Else
GetSockAddress = ""
End If
If Err Then GetSockAddress = ""
End FunctionFunction GetHostByNameAlias(ByVal hostname$) As Long
On Error Resume Next
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
MemCopy heDestHost, ByVal phe, hostent_size
MemCopy addrList, ByVal heDestHost.hAddrList, 4
MemCopy retIP, ByVal addrList, heDestHost.hLen
Else
retIP = INADDR_NONE
End If
End If
GetHostByNameAlias = retIP
If Err Then GetHostByNameAlias = INADDR_NONE
End FunctionFunction IpToAddr(ByVal AddrOrIP$) As String
On Error Resume Next
IpToAddr = GetHostByAddress(GetHostByNameAlias(AddrOrIP$))
If Err Then IpToAddr = WSA_NoName
End FunctionPublic Function ListenForConnect(ByVal Port&, ByVal HWndToMsg&) As Long
Dim s&, dummy&
Dim SelectOps&
Dim sockin As sockaddr
sockin = saZero
sockin.sin_family = AF_INET
sockin.sin_port = htons(Port)
If sockin.sin_port = INVALID_SOCKET Then
ListenForConnect = INVALID_SOCKET
Exit Function
End If
sockin.sin_addr = htonl(INADDR_ANY)
If sockin.sin_addr = INADDR_NONE Then
ListenForConnect = INVALID_SOCKET
Exit Function
End If
s = socket(PF_INET, SOCK_STREAM, 0)
If s < 0 Then
ListenForConnect = INVALID_SOCKET
Exit Function
End If
If bind(s, sockin, sockaddr_size) Then
If s > 0 Then
dummy = closesocket(s)
End If
ListenForConnect = INVALID_SOCKET
Exit Function
End If
SelectOps = FD_READ Or FD_WRITE Or FD_CLOSE Or FD_ACCEPT
If WSAAsyncSelect(s, HWndToMsg, ByVal WINSOCK_MESSAGE, ByVal SelectOps) Then
If s > 0 Then
dummy = closesocket(s)
End If
ListenForConnect = SOCKET_ERROR
Exit Function
End If
If listen(s, 1) Then
If s > 0 Then
dummy = closesocket(s)
End If
ListenForConnect = INVALID_SOCKET
Exit Function
End If
ListenForConnect = s
End Function
Select Case VarType(vMessage)
Case 8209
sTemp = vMessage
TheMsg = sTemp
Case 8
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 IfEnd FunctionPublic Function SockAddressToString(sa As sockaddr) As String
SockAddressToString = getascip(sa.sin_addr) & ":" & ntohs(sa.sin_port)
End FunctionPublic Function StartWinsock(sDescription As String) As Boolean
Dim StartupData As WSADataType
If Not WSAStartedUp Then
If Not WSAStartup(&H101, StartupData) Then
WSAStartedUp = True
sDescription = StartupData.szDescription
Else
WSAStartedUp = False
End If
End If
StartWinsock = WSAStartedUp
End FunctionFunction GetHost(IP As String)
On Error Resume Next
Dim hostent_addr As Long
Dim Host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim I As Integer
Dim ip_address As String
hostent_addr = GetHostByName(IP)
If hostent_addr = 0 Then
GetHost = IP
Exit Function
End If
RtlMoveMemory Host, hostent_addr, LenB(Host)
RtlMoveMemory hostip_addr, Host.hAddrList, 4
ReDim temp_ip_address(1 To Host.hLen)
RtlMoveMemory temp_ip_address(1), hostip_addr, Host.hLen
For I = 1 To Host.hLen
ip_address = ip_address & temp_ip_address(I) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
GetHost = ip_address
End FunctionFunction GetHostByAddress(ByVal addr As Long) As String
On Error Resume Next
Dim phe&, Ret&
Dim heDestHost As HOSTENT
Dim hostname$
phe = gethostbyaddr(addr, 4, PF_INET)
Debug.Print phe
If phe <> 0 Then
MemCopy heDestHost, ByVal phe, hostent_size
Debug.Print heDestHost.hName
Debug.Print heDestHost.hAliases
Debug.Print heDestHost.hAddrType
Debug.Print heDestHost.hLen
Debug.Print heDestHost.hAddrList hostname = String(256, 0)
MemCopy ByVal hostname, ByVal heDestHost.hName, 256
GetHostByAddress = Left(hostname, InStr(hostname, Chr(0)) - 1)
Else
GetHostByAddress = WSA_NoName
End If
If Err Then GetHostByAddress = WSA_NoName
End FunctionPublic Function GetIPAddress() As String
Dim sHostName As String * 256
Dim lpHost As Long
Dim Host As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim I As Integer
Dim sIPAddr As String
If gethostname(sHostName, 256) = SOCKET_ERROR Then
GetIPAddress = ""
Exit Function
End If
sHostName = Trim$(sHostName)
lpHost = GetHostByName(sHostName)
If lpHost = 0 Then
GetIPAddress = ""
Exit Function
End If
CopyMemoryIP Host, lpHost, Len(Host)
CopyMemoryIP dwIPAddr, Host.hAddrList, 4
ReDim tmpIPAddr(1 To Host.hLen)
CopyMemoryIP tmpIPAddr(1), dwIPAddr, Host.hLen
For I = 1 To Host.hLen
sIPAddr = sIPAddr & tmpIPAddr(I) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
End Function