From 3de585f1354235662b33ab662888f79a1b7af484 Mon Sep 17 00:00:00 2001 From: Vladimir H Date: Tue, 9 Dec 2008 08:39:22 -0600 Subject: [PATCH] Manejo de errores cambiado. Eliminado Erl completo, pasando a parcial. --- AuroNet/AuroNet.cls | 932 ++++----- AuroNet/CSocketMaster.cls | 4522 +++++++++++++++++++++---------------------- AuroNet/modSocketMaster.bas | 2466 +++++++++++------------ Reseter.vbp | 2 +- bas/Ajustes.bas | 44 +- bas/ConfIO.bas | 174 +- bas/DIBUJO.bas | 454 ++--- bas/Global.bas | 1500 +++++++------- bas/NET.bas | 574 +++--- bas/Vt100.bas | 2088 ++++++++++---------- bas/modAppIcon.bas | 58 +- bas/modBasico.bas | 72 +- bas/modEth.bas | 386 ++-- bas/modNetInfo.bas | 564 +++--- cls/Timer Class.cls | 164 +- frm/Principal.frm | 312 +-- frm/Telnet.frm | 1526 +++++++-------- 17 files changed, 7919 insertions(+), 7919 deletions(-) rewrite AuroNet/AuroNet.cls (75%) rewrite AuroNet/CSocketMaster.cls (73%) rewrite AuroNet/modSocketMaster.bas (61%) rewrite bas/DIBUJO.bas (88%) rewrite bas/Global.bas (86%) rewrite bas/NET.bas (83%) rewrite bas/Vt100.bas (80%) rewrite bas/modEth.bas (64%) rewrite bas/modNetInfo.bas (72%) rewrite frm/Telnet.frm (79%) diff --git a/AuroNet/AuroNet.cls b/AuroNet/AuroNet.cls dissimilarity index 75% index 819a8bc..90d1a1e 100755 --- a/AuroNet/AuroNet.cls +++ b/AuroNet/AuroNet.cls @@ -1,466 +1,466 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True - Persistable = 0 'NotPersistable - DataBindingBehavior = 0 'vbNone - DataSourceBehavior = 0 'vbNone - MTSTransactionMode = 0 'NotAnMTSObject -END -Attribute VB_Name = "AuroNet" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = False -Option Explicit -' -'-------------------------------------------------------------------------------- -' Componente : AuroNet 0.1 -' Projecto : Herramientas AuroWare -' -' Descripción : Libreria de uso general para la interacción WEB -' Depende de : cSocketMaster, modSocketMaster, modBasico, AuroNetConf -' -' Modificado : -' 24/06/07 - UserAgent como propiedad -' 24/06/07 - Control de versión -'-------------------------------------------------------------------------------- -' -' -Private WithEvents AuroSocket As CSocketMaster -Attribute AuroSocket.VB_VarHelpID = -1 -Private ErrorGeneral As Boolean -Private ExitoGeneral As Boolean -Private MiTag As String -Private pBuffer As String -Private URL As String -Private Proxy As String -Private Proxy_Puerto As Integer -Private strHTTP As String - -Public Function HTML_CONSULTAR() As Boolean - ' - On Error GoTo HTML_CONSULTAR_Err - ' -100 ExitoGeneral = False -101 ErrorGeneral = False -102 Debug.Print Time & "$ CONSULTAR - Inicio | " & URL -103 strHTTP = vbNullString -104 AuroSocket.Connect IIf(Proxy <> "", Proxy, HostDeURL) & pBuffer, IIf(Proxy <> "", Proxy_Puerto, 80) - - Do -105 Esperar 0.5 -106 Loop Until AuroSocket.State = sckConnected Or AuroSocket.State = sckError Or ErrorGeneral - -107 If AuroSocket.State <> sckConnected Then -108 HTML_CONSULTAR = False -109 ExitoGeneral = False -110 ErrorGeneral = True - Else -111 HTML_CONSULTAR = True -112 ExitoGeneral = True -113 ErrorGeneral = False - End If - -114 AuroSocket.CloseSck -115 Debug.Print Time & "$ CONSULTAR - Fin | " & HTML_CONSULTAR - ' - Exit Function -HTML_CONSULTAR_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HTML_CONSULTAR.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Public Function Exito() - ' - On Error GoTo Exito_Err - ' -100 Exito = ExitoGeneral - ' - Exit Function -Exito_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Exito.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Public Function HTML_GET(Optional Parametros As String) As String - ' - On Error GoTo HTML_GET_Err - ' -Redireccion: -100 Debug.Print "$ GET - Inicio | " & URL & " | " & Now -101 AuroSocket.CloseSck - -102 If IsMissing(Parametros) Then pBuffer = vbNullString Else pBuffer = Parametros -103 ErrorGeneral = False -104 ExitoGeneral = False -105 strHTTP = "GET " + IIf(Proxy <> "", URL, URLdeHost) & pBuffer + " HTTP/1.0" + vbCrLf -106 strHTTP = strHTTP + "Accept: " + ACCEPT_TOKEN + vbCrLf -107 strHTTP = strHTTP + "Referer: " + HostDeURL + vbCrLf -108 strHTTP = strHTTP + "User-Agent: " + USERAGENT_TOKEN + vbCrLf -109 strHTTP = strHTTP + "Host: " + HostDeURL + vbCrLf -110 strHTTP = strHTTP + vbCrLf -111 AuroSocket.Connect IIf(Proxy <> "", Proxy, HostDeURL) & pBuffer, IIf(Proxy <> "", Proxy_Puerto, 80) - - Do -112 Esperar 0.5 -113 Loop Until ExitoGeneral Or ErrorGeneral - -114 AuroSocket.CloseSck - Dim pRedireccion As Long - Dim Redireccion As String - Dim Cabeceras As String -115 Cabeceras = ObtenerCabeceras(pBuffer) -116 pRedireccion = InStr(1, Cabeceras, "Location:") - -117 If pRedireccion <> 0 Then -118 pRedireccion = pRedireccion + Len("Location:") -119 Redireccion = Trim$(Mid$(Cabeceras, pRedireccion, InStr(pRedireccion, Cabeceras, vbCrLf) - pRedireccion)) - -120 If URL <> Redireccion Then -121 Direccion = Redireccion -122 Debug.Print Time & "$ GET - Redirección | " & URL -123 GoTo Redireccion - End If - End If - -124 HTML_GET = ObtenerHTML(pBuffer) -125 Debug.Print "$SOCKET HTML leido | " & Len(HTML_GET) & " | " & Now - -126 If Len(pBuffer) <> 0 And ExitoGeneral = True And ErrorGeneral = False Then -127 ExitoGeneral = True - Else -128 ErrorGeneral = True - End If - - ' - Exit Function -HTML_GET_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HTML_GET.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Public Function IpLocal() - ' - On Error GoTo IpLocal_Err - ' -100 IpLocal = AuroSocket.LocalIP - ' - Exit Function -IpLocal_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.IpLocal.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Private Function HostDeURL() As String - ' - On Error GoTo HostDeURL_Err - ' -100 HostDeURL = Replace$(Trim$(URL), "http://", vbNullString) - Dim Init As Integer -101 Init = InStr(1, HostDeURL, "/", vbTextCompare) - -102 If Init <> 0 Then HostDeURL = Left$(HostDeURL, Init - 1) - ' - Exit Function -HostDeURL_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HostDeURL.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Private Function URLdeHost() As String - ' - On Error GoTo URLdeHost_Err - ' -100 URLdeHost = Replace$(Trim$(URL), "http://", vbNullString) - Dim Init As Integer -101 Init = InStr(1, URLdeHost, "/", vbTextCompare) - -102 If Init <> 0 Then URLdeHost = Mid$(URLdeHost, Init) - ' - Exit Function -URLdeHost_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.URLdeHost.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Private Sub AuroSocket_CloseSck() - ' - On Error GoTo AuroSocket_CloseSck_Err - ' -100 Debug.Print "$SOCKET - Cerrado" & " | " & Now -101 ExitoGeneral = True - ' - Exit Sub -AuroSocket_CloseSck_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_CloseSck.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Sub - -Private Sub AuroSocket_Connect() - ' - On Error GoTo AuroSocket_Connect_Err - ' -100 AuroSocket.SendData strHTTP -101 Debug.Print "$SOCKET - Datos enviados" & " | " & Now - ' - Exit Sub -AuroSocket_Connect_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_Connect.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Sub - -Private Sub AuroSocket_DataArrival(ByVal bytesTotal As Long) - ' - On Error GoTo AuroSocket_DataArrival_Err - ' - Dim Pedazo As String -100 AuroSocket.GetData Pedazo -101 pBuffer = pBuffer & Pedazo -102 Debug.Print "$SOCKET - Respuesta recibida | " & AuroSocket.State & " | " & bytesTotal & " | " & Now - ' - Exit Sub -AuroSocket_DataArrival_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_DataArrival.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Sub - -Private Sub AuroSocket_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) - ' - On Error GoTo AuroSocket_Error_Err - ' -100 Debug.Print "$SOCKET - ERROR!!!" & " | " & Now -101 ErrorGeneral = True - ' - Exit Sub -AuroSocket_Error_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_Error.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Sub - -Private Sub Class_Initialize() - ' - On Error GoTo Class_Initialize_Err - ' -100 USERAGENT_TOKEN = "Auronet " & AuroNetVer -101 Set AuroSocket = New CSocketMaster - ' - Exit Sub -Class_Initialize_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Class_Initialize.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Sub - -Private Sub Class_Terminate() - ' - On Error Resume Next - ' - Set AuroSocket = Nothing -End Sub - -Public Property Get Direccion() As Variant - ' - On Error GoTo Direccion_Err - ' -100 Direccion = URL - ' - Exit Property -Direccion_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Direccion.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let Direccion(ByVal pDato As Variant) - ' - On Error GoTo Direccion_Err - ' -100 URL = pDato -101 pDato = Replace$(pDato, "http://", "") - -102 If InStr(1, pDato, "/") = 0 Then URL = URL & "/" - ' - Exit Property -Direccion_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Direccion.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Get error() As Variant - ' - On Error GoTo error_Err - ' -100 error = ErrorGeneral - ' - Exit Property -error_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.error.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let error(ByVal Estado As Variant) - ' - On Error GoTo error_Err - ' -100 ErrorGeneral = Estado - ' - Exit Property -error_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.error.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Get Tag() As Variant - ' - On Error GoTo Tag_Err - ' -100 Tag = MiTag - ' - Exit Property -Tag_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Tag.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let Tag(ByVal Tag As Variant) - ' - On Error GoTo Tag_Err - ' -100 MiTag = Tag - ' - Exit Property -Tag_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Tag.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Get Agente() As Variant - ' - On Error GoTo Agente_Err - ' -100 Agente = USERAGENT_TOKEN - ' - Exit Property -Agente_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Agente.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let Agente(ByVal vNewValue As Variant) - ' - On Error GoTo Agente_Err - ' -100 USERAGENT_TOKEN = CStr(vNewValue) - ' - Exit Property -Agente_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Agente.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Private Function ObtenerCabeceras(HTML As String) As String - ' - On Error GoTo ObtenerCabeceras_Err - ' - Dim Prueba As Long -100 Prueba = InStr(1, HTML, vbCrLf & vbCrLf) - -101 If Prueba <> 0 Then ObtenerCabeceras = Left$(HTML, Prueba) - ' - Exit Function -ObtenerCabeceras_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.ObtenerCabeceras.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Private Function ObtenerHTML(HTML As String) As String - ' - On Error GoTo ObtenerHTML_Err - ' - Dim Prueba As Long -100 Prueba = InStr(1, HTML, vbCrLf & vbCrLf) - -101 If Prueba <> 0 Then ObtenerHTML = Mid$(HTML, Prueba + 4) - ' - Exit Function -ObtenerHTML_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.ObtenerHTML.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Function - -Public Property Get Usar_Proxy() As Variant - ' - On Error GoTo Usar_Proxy_Err - ' -100 Usar_Proxy = Direccion - ' - Exit Property -Usar_Proxy_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let Usar_Proxy(ByVal Direccion As Variant) - ' - On Error GoTo Usar_Proxy_Err - ' -100 Proxy = CStr(Direccion) - ' - Exit Property -Usar_Proxy_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Get Usar_Proxy_Puerto() As Variant - ' - On Error GoTo Usar_Proxy_Puerto_Err - ' -100 Usar_Proxy_Puerto = CStr(Proxy_Puerto) - ' - Exit Property -Usar_Proxy_Puerto_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy_Puerto.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property - -Public Property Let Usar_Proxy_Puerto(ByVal puerto As Variant) - ' - On Error GoTo Usar_Proxy_Puerto_Err - ' -100 Proxy_Puerto = CInt(puerto) - ' - Exit Property -Usar_Proxy_Puerto_Err: - Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy_Puerto.Ref 12/8/2008 : 08:11:17" - Resume Next - ' -End Property +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True + Persistable = 0 'NotPersistable + DataBindingBehavior = 0 'vbNone + DataSourceBehavior = 0 'vbNone + MTSTransactionMode = 0 'NotAnMTSObject +END +Attribute VB_Name = "AuroNet" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +Option Explicit +' +'-------------------------------------------------------------------------------- +' Componente : AuroNet 0.1 +' Projecto : Herramientas AuroWare +' +' Descripción : Libreria de uso general para la interacción WEB +' Depende de : cSocketMaster, modSocketMaster, modBasico, AuroNetConf +' +' Modificado : +' 24/06/07 - UserAgent como propiedad +' 24/06/07 - Control de versión +'-------------------------------------------------------------------------------- +' +' +Private WithEvents AuroSocket As CSocketMaster +Attribute AuroSocket.VB_VarHelpID = -1 +Private ErrorGeneral As Boolean +Private ExitoGeneral As Boolean +Private MiTag As String +Private pBuffer As String +Private URL As String +Private Proxy As String +Private Proxy_Puerto As Integer +Private strHTTP As String + +Public Function HTML_CONSULTAR() As Boolean + ' + On Error GoTo HTML_CONSULTAR_Err + ' + ExitoGeneral = False + ErrorGeneral = False + Debug.Print Time & "$ CONSULTAR - Inicio | " & URL + strHTTP = vbNullString + AuroSocket.Connect IIf(Proxy <> "", Proxy, HostDeURL) & pBuffer, IIf(Proxy <> "", Proxy_Puerto, 80) + + Do + Esperar 0.5 + Loop Until AuroSocket.State = sckConnected Or AuroSocket.State = sckError Or ErrorGeneral + + If AuroSocket.State <> sckConnected Then + HTML_CONSULTAR = False + ExitoGeneral = False + ErrorGeneral = True + Else + HTML_CONSULTAR = True + ExitoGeneral = True + ErrorGeneral = False + End If + + AuroSocket.CloseSck + Debug.Print Time & "$ CONSULTAR - Fin | " & HTML_CONSULTAR + ' + Exit Function +HTML_CONSULTAR_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HTML_CONSULTAR" + Resume Next + ' +End Function + +Public Function Exito() + ' + On Error GoTo Exito_Err + ' + Exito = ExitoGeneral + ' + Exit Function +Exito_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Exito" + Resume Next + ' +End Function + +Public Function HTML_GET(Optional Parametros As String) As String + ' + On Error GoTo HTML_GET_Err + ' +Redireccion: + Debug.Print "$ GET - Inicio | " & URL & " | " & Now + AuroSocket.CloseSck + + If IsMissing(Parametros) Then pBuffer = vbNullString Else pBuffer = Parametros + ErrorGeneral = False + ExitoGeneral = False + strHTTP = "GET " + IIf(Proxy <> "", URL, URLdeHost) & pBuffer + " HTTP/1.0" + vbCrLf + strHTTP = strHTTP + "Accept: " + ACCEPT_TOKEN + vbCrLf + strHTTP = strHTTP + "Referer: " + HostDeURL + vbCrLf + strHTTP = strHTTP + "User-Agent: " + USERAGENT_TOKEN + vbCrLf + strHTTP = strHTTP + "Host: " + HostDeURL + vbCrLf + strHTTP = strHTTP + vbCrLf + AuroSocket.Connect IIf(Proxy <> "", Proxy, HostDeURL) & pBuffer, IIf(Proxy <> "", Proxy_Puerto, 80) + + Do + Esperar 0.5 + Loop Until ExitoGeneral Or ErrorGeneral + + AuroSocket.CloseSck + Dim pRedireccion As Long + Dim Redireccion As String + Dim Cabeceras As String + Cabeceras = ObtenerCabeceras(pBuffer) + pRedireccion = InStr(1, Cabeceras, "Location:") + + If pRedireccion <> 0 Then + pRedireccion = pRedireccion + Len("Location:") + Redireccion = Trim$(Mid$(Cabeceras, pRedireccion, InStr(pRedireccion, Cabeceras, vbCrLf) - pRedireccion)) + + If URL <> Redireccion Then + Direccion = Redireccion + Debug.Print Time & "$ GET - Redirección | " & URL + GoTo Redireccion + End If + End If + + HTML_GET = ObtenerHTML(pBuffer) + Debug.Print "$SOCKET HTML leido | " & Len(HTML_GET) & " | " & Now + + If Len(pBuffer) <> 0 And ExitoGeneral = True And ErrorGeneral = False Then + ExitoGeneral = True + Else + ErrorGeneral = True + End If + + ' + Exit Function +HTML_GET_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HTML_GET" + Resume Next + ' +End Function + +Public Function IpLocal() + ' + On Error GoTo IpLocal_Err + ' + IpLocal = AuroSocket.LocalIP + ' + Exit Function +IpLocal_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.IpLocal" + Resume Next + ' +End Function + +Private Function HostDeURL() As String + ' + On Error GoTo HostDeURL_Err + ' + HostDeURL = Replace$(Trim$(URL), "http://", vbNullString) + Dim Init As Integer + Init = InStr(1, HostDeURL, "/", vbTextCompare) + + If Init <> 0 Then HostDeURL = Left$(HostDeURL, Init - 1) + ' + Exit Function +HostDeURL_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.HostDeURL" + Resume Next + ' +End Function + +Private Function URLdeHost() As String + ' + On Error GoTo URLdeHost_Err + ' + URLdeHost = Replace$(Trim$(URL), "http://", vbNullString) + Dim Init As Integer + Init = InStr(1, URLdeHost, "/", vbTextCompare) + + If Init <> 0 Then URLdeHost = Mid$(URLdeHost, Init) + ' + Exit Function +URLdeHost_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.URLdeHost" + Resume Next + ' +End Function + +Private Sub AuroSocket_CloseSck() + ' + On Error GoTo AuroSocket_CloseSck_Err + ' + Debug.Print "$SOCKET - Cerrado" & " | " & Now + ExitoGeneral = True + ' + Exit Sub +AuroSocket_CloseSck_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_CloseSck" + Resume Next + ' +End Sub + +Private Sub AuroSocket_Connect() + ' + On Error GoTo AuroSocket_Connect_Err + ' + AuroSocket.SendData strHTTP + Debug.Print "$SOCKET - Datos enviados" & " | " & Now + ' + Exit Sub +AuroSocket_Connect_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_Connect" + Resume Next + ' +End Sub + +Private Sub AuroSocket_DataArrival(ByVal bytesTotal As Long) + ' + On Error GoTo AuroSocket_DataArrival_Err + ' + Dim Pedazo As String + AuroSocket.GetData Pedazo + pBuffer = pBuffer & Pedazo + Debug.Print "$SOCKET - Respuesta recibida | " & AuroSocket.State & " | " & bytesTotal & " | " & Now + ' + Exit Sub +AuroSocket_DataArrival_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_DataArrival" + Resume Next + ' +End Sub + +Private Sub AuroSocket_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) + ' + On Error GoTo AuroSocket_Error_Err + ' + Debug.Print "$SOCKET - ERROR!!!" & " | " & Now + ErrorGeneral = True + ' + Exit Sub +AuroSocket_Error_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.AuroSocket_Error" + Resume Next + ' +End Sub + +Private Sub Class_Initialize() + ' + On Error GoTo Class_Initialize_Err + ' + USERAGENT_TOKEN = "Auronet " & AuroNetVer + Set AuroSocket = New CSocketMaster + ' + Exit Sub +Class_Initialize_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Class_Initialize" + Resume Next + ' +End Sub + +Private Sub Class_Terminate() + ' + On Error Resume Next + ' + Set AuroSocket = Nothing +End Sub + +Public Property Get Direccion() As Variant + ' + On Error GoTo Direccion_Err + ' + Direccion = URL + ' + Exit Property +Direccion_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Direccion" + Resume Next + ' +End Property + +Public Property Let Direccion(ByVal pDato As Variant) + ' + On Error GoTo Direccion_Err + ' + URL = pDato + pDato = Replace$(pDato, "http://", "") + + If InStr(1, pDato, "/") = 0 Then URL = URL & "/" + ' + Exit Property +Direccion_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Direccion" + Resume Next + ' +End Property + +Public Property Get error() As Variant + ' + On Error GoTo error_Err + ' + error = ErrorGeneral + ' + Exit Property +error_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.error" + Resume Next + ' +End Property + +Public Property Let error(ByVal Estado As Variant) + ' + On Error GoTo error_Err + ' + ErrorGeneral = Estado + ' + Exit Property +error_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.error" + Resume Next + ' +End Property + +Public Property Get Tag() As Variant + ' + On Error GoTo Tag_Err + ' + Tag = MiTag + ' + Exit Property +Tag_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Tag" + Resume Next + ' +End Property + +Public Property Let Tag(ByVal Tag As Variant) + ' + On Error GoTo Tag_Err + ' + MiTag = Tag + ' + Exit Property +Tag_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Tag" + Resume Next + ' +End Property + +Public Property Get Agente() As Variant + ' + On Error GoTo Agente_Err + ' + Agente = USERAGENT_TOKEN + ' + Exit Property +Agente_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Agente" + Resume Next + ' +End Property + +Public Property Let Agente(ByVal vNewValue As Variant) + ' + On Error GoTo Agente_Err + ' + USERAGENT_TOKEN = CStr(vNewValue) + ' + Exit Property +Agente_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Agente" + Resume Next + ' +End Property + +Private Function ObtenerCabeceras(HTML As String) As String + ' + On Error GoTo ObtenerCabeceras_Err + ' + Dim Prueba As Long + Prueba = InStr(1, HTML, vbCrLf & vbCrLf) + + If Prueba <> 0 Then ObtenerCabeceras = Left$(HTML, Prueba) + ' + Exit Function +ObtenerCabeceras_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.ObtenerCabeceras" + Resume Next + ' +End Function + +Private Function ObtenerHTML(HTML As String) As String + ' + On Error GoTo ObtenerHTML_Err + ' + Dim Prueba As Long + Prueba = InStr(1, HTML, vbCrLf & vbCrLf) + + If Prueba <> 0 Then ObtenerHTML = Mid$(HTML, Prueba + 4) + ' + Exit Function +ObtenerHTML_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.ObtenerHTML" + Resume Next + ' +End Function + +Public Property Get Usar_Proxy() As Variant + ' + On Error GoTo Usar_Proxy_Err + ' + Usar_Proxy = Direccion + ' + Exit Property +Usar_Proxy_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy" + Resume Next + ' +End Property + +Public Property Let Usar_Proxy(ByVal Direccion As Variant) + ' + On Error GoTo Usar_Proxy_Err + ' + Proxy = CStr(Direccion) + ' + Exit Property +Usar_Proxy_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy" + Resume Next + ' +End Property + +Public Property Get Usar_Proxy_Puerto() As Variant + ' + On Error GoTo Usar_Proxy_Puerto_Err + ' + Usar_Proxy_Puerto = CStr(Proxy_Puerto) + ' + Exit Property +Usar_Proxy_Puerto_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy_Puerto" + Resume Next + ' +End Property + +Public Property Let Usar_Proxy_Puerto(ByVal puerto As Variant) + ' + On Error GoTo Usar_Proxy_Puerto_Err + ' + Proxy_Puerto = CInt(puerto) + ' + Exit Property +Usar_Proxy_Puerto_Err: + Controlar_Error Erl, Err.Description, "Reseter.AuroNet.Usar_Proxy_Puerto" + Resume Next + ' +End Property diff --git a/AuroNet/CSocketMaster.cls b/AuroNet/CSocketMaster.cls dissimilarity index 73% index fd8dbf1..1f41171 100755 --- a/AuroNet/CSocketMaster.cls +++ b/AuroNet/CSocketMaster.cls @@ -1,2261 +1,2261 @@ -VERSION 1.0 CLASS -BEGIN - MultiUse = -1 'True - Persistable = 0 'NotPersistable - DataBindingBehavior = 0 'vbNone - DataSourceBehavior = 0 'vbNone - MTSTransactionMode = 0 'NotAnMTSObject -END -Attribute VB_Name = "CSocketMaster" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = True -Attribute VB_PredeclaredId = False -Attribute VB_Exposed = False -'******************************************************************************** -' -'Name.......... CSocketMaster -'File.......... CSocketMaster.cls -'Version....... 1.2 -'Dependencies.. Requires modSocketMaster.bas code module -'Description... Winsock api implementation class -'Author........ Emiliano Scavuzzo -'Date.......... June, 28th 2004 -'Copyright (c) 2004 by Emiliano Scavuzzo -'Rosario, Argentina -' -'Based on CSocket by Oleg Gdalevich -'Subclassing based on WinSubHook2 by Paul Caton -' -'******************************************************************************** -Option Explicit -'============================================================================== -'API FUNCTIONS -'============================================================================== -Private 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 -Private Declare Function api_GlobalLock _ - Lib "kernel32" _ - Alias "GlobalLock" (ByVal hMem As Long) As Long -Private Declare Function api_GlobalUnlock _ - Lib "kernel32" _ - Alias "GlobalUnlock" (ByVal hMem As Long) As Long -Private Declare Function api_htons _ - Lib "ws2_32.dll" _ - Alias "htons" (ByVal hostshort As Integer) As Integer -Private Declare Function api_ntohs _ - Lib "ws2_32.dll" _ - Alias "ntohs" (ByVal netshort As Integer) As Integer -Private 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 -Private Declare Function api_gethostname _ - Lib "ws2_32.dll" _ - Alias "gethostname" (ByVal host_name As String, _ - ByVal namelen As Long) As Long -Private Declare Function api_gethostbyname _ - Lib "ws2_32.dll" _ - Alias "gethostbyname" (ByVal host_name As String) As Long -Private Declare Function api_bind _ - Lib "ws2_32.dll" _ - Alias "bind" (ByVal s As Long, _ - ByRef name As sockaddr_in, _ - ByVal namelen As Long) As Long -Private 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 -Private 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 -Private Declare Function api_inet_addr _ - Lib "ws2_32.dll" _ - Alias "inet_addr" (ByVal cp As String) As Long -Private 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 -Private 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 -Private 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 -Private 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 -Private 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 -Private 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 -Private Declare Function api_WSACancelAsyncRequest _ - Lib "ws2_32.dll" _ - Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long -Private Declare Function api_listen _ - Lib "ws2_32.dll" _ - Alias "listen" (ByVal s As Long, _ - ByVal backlog As Long) As Long -Private 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 -Private Declare Function api_inet_ntoa _ - Lib "ws2_32.dll" _ - Alias "inet_ntoa" (ByVal inn As Long) As Long -Private Declare Function api_ioctlsocket _ - Lib "ws2_32.dll" _ - Alias "ioctlsocket" (ByVal s As Long, _ - ByVal cmd As Long, _ - ByRef argp As Long) As Long -Private Declare Function api_closesocket _ - Lib "ws2_32.dll" _ - Alias "closesocket" (ByVal s As Long) As Long -'Private 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 -'============================================================================== -'CONSTANTS -'============================================================================== -Public Enum SockState - sckClosed = 0 - sckOpen - sckListening - sckConnectionPending - sckResolvingHost - sckHostResolved - sckConnecting - sckConnected - sckClosing - sckError -End Enum -Private Const SOMAXCONN As Long = 5 -Public Enum ProtocolConstants - sckTCPProtocol = 0 - sckUDPProtocol = 1 -End Enum -Private Const MSG_PEEK As Long = &H2 -'============================================================================== -'EVENTS -'============================================================================== -Public Event CloseSck() -Public Event Connect() -Public Event ConnectionRequest(ByVal requestID As Long) -Public Event DataArrival(ByVal bytesTotal As Long) -Public 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) -Public Event SendComplete() -Public Event SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long) -'============================================================================== -'MEMBER VARIABLES -'============================================================================== -Private m_lngSocketHandle As Long 'socket handle -Private m_enmState As SockState 'socket state -Private m_strTag As String 'tag -Private m_strRemoteHost As String 'remote host -Private m_lngRemotePort As Long 'remote port -Private m_strRemoteHostIP As String 'remote host ip -Private m_lngLocalPort As Long 'local port -Private m_lngLocalPortBind As Long 'temporary local port -Private m_strLocalIP As String 'local IP -Private m_enmProtocol As ProtocolConstants 'protocol used (TCP / UDP) -Private m_lngMemoryPointer As Long 'memory pointer used as buffer when resolving host -Private m_lngMemoryHandle As Long 'buffer memory handle -Private m_lngSendBufferLen As Long 'winsock buffer size for sends -Private m_lngRecvBufferLen As Long 'winsock buffer size for receives -Private m_strSendBuffer As String 'local incoming buffer -Private m_strRecvBuffer As String 'local outgoing buffer -Private m_blnAcceptClass As Boolean 'if True then this is an Accept socket class -Private m_colWaitingResolutions As Collection 'hosts waiting to be resolved by the system - -' **** WARNING WARNING WARNING WARNING ****** -'This sub MUST be the first on the class. DO NOT attempt -'to change it's location or the code will CRASH. -'This sub receives system messages from our WndProc. -Public Sub WndProc(ByVal hWnd As Long, _ - ByVal uMsg As Long, _ - ByVal wParam As Long, _ - ByVal lParam As Long) - ' - On Error GoTo WndProc_Err - - ' -100 Select Case uMsg - - Case RESOLVE_MESSAGE -101 PostResolution wParam, HiWord(lParam) - -102 Case SOCKET_MESSAGE -103 PostSocket LoWord(lParam), HiWord(lParam) - End Select - - ' - Exit Sub -WndProc_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.WndProc.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Private Sub Class_Initialize() - 'socket's handle default value - ' - On Error GoTo Class_Initialize_Err - ' -100 m_lngSocketHandle = INVALID_SOCKET - 'initiate resolution collection -101 Set m_colWaitingResolutions = New Collection - 'initiate processes and winsock service -102 modSocketMaster.InitiateProcesses - ' - Exit Sub -Class_Initialize_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Class_Initialize.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Private Sub Class_Terminate() - 'clean hostname resolution system - ' - On Error Resume Next - ' - CleanResolutionSystem - - 'destroy socket if it exists - If Not m_blnAcceptClass Then DestroySocket - 'clean processes and finish winsock service - modSocketMaster.FinalizeProcesses - 'clean resolution collection - Set m_colWaitingResolutions = Nothing -End Sub - -'============================================================================== -'PROPERTIES -'============================================================================== -Public Property Get RemotePort() As Long - ' - On Error GoTo RemotePort_Err - ' -100 RemotePort = m_lngRemotePort - ' - Exit Property -RemotePort_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemotePort.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Property - -Public Property Let RemotePort(ByVal lngPort As Long) - ' - On Error GoTo RemotePort_Err - - ' -100 If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then -101 Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state" - End If - -102 If lngPort < 0 Or lngPort > 65535 Then -103 Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range." - Else -104 m_lngRemotePort = lngPort - End If - - ' - Exit Property -RemotePort_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemotePort.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Property - -Public Property Get RemoteHost() As String - ' - On Error GoTo RemoteHost_Err - ' -100 RemoteHost = m_strRemoteHost - ' - Exit Property -RemoteHost_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHost.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Let RemoteHost(ByVal strHost As String) - ' - On Error GoTo RemoteHost_Err - - ' -100 If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then -101 Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state" - End If - -102 m_strRemoteHost = strHost - ' - Exit Property -RemoteHost_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHost.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get RemoteHostIP() As String - ' - On Error GoTo RemoteHostIP_Err - ' -100 RemoteHostIP = m_strRemoteHostIP - ' - Exit Property -RemoteHostIP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHostIP.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get LocalPort() As Long - ' - On Error GoTo LocalPort_Err - - ' -100 If m_lngLocalPortBind = 0 Then -101 LocalPort = m_lngLocalPort - Else -102 LocalPort = m_lngLocalPortBind - End If - - ' - Exit Property -LocalPort_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalPort.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Let LocalPort(ByVal lngPort As Long) - ' - On Error GoTo LocalPort_Err - - ' -100 If m_enmState <> sckClosed Then -101 Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state" - End If - -102 If lngPort < 0 Or lngPort > 65535 Then -103 Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range." - Else -104 m_lngLocalPort = lngPort - End If - - ' - Exit Property -LocalPort_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalPort.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get State() As SockState - ' - On Error GoTo State_Err - ' -100 State = m_enmState - ' - Exit Property -State_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.State.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get LocalHostName() As String - ' - On Error GoTo LocalHostName_Err - ' -100 LocalHostName = GetLocalHostName - ' - Exit Property -LocalHostName_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalHostName.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get LocalIP() As String - ' - On Error GoTo LocalIP_Err - - ' -100 If m_enmState = sckConnected Then -101 LocalIP = m_strLocalIP - Else -102 LocalIP = GetLocalIP - End If - - ' - Exit Property -LocalIP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalIP.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get BytesReceived() As Long - ' - On Error GoTo BytesReceived_Err - - ' -100 If m_enmProtocol = sckTCPProtocol Then -101 BytesReceived = Len(m_strRecvBuffer) - Else -102 BytesReceived = GetBufferLenUDP - End If - - ' - Exit Property -BytesReceived_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BytesReceived.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get SocketHandle() As Long - ' - On Error GoTo SocketHandle_Err - ' -100 SocketHandle = m_lngSocketHandle - ' - Exit Property -SocketHandle_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SocketHandle.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get Tag() As String - ' - On Error GoTo Tag_Err - ' -100 Tag = m_strTag - ' - Exit Property -Tag_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Tag.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Let Tag(ByVal strTag As String) - ' - On Error GoTo Tag_Err - ' -100 m_strTag = strTag - ' - Exit Property -Tag_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Tag.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Get Protocol() As ProtocolConstants - ' - On Error GoTo Protocol_Err - ' -100 Protocol = m_enmProtocol - ' - Exit Property -Protocol_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Protocol.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants) - ' - On Error GoTo Protocol_Err - - ' -100 If m_enmState <> sckClosed Then -101 Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state" - Else -102 m_enmProtocol = enmProtocol - End If - - ' - Exit Property -Protocol_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Protocol.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Property - -'Destroys the socket if it exists and unregisters it -'from control list. -Private Sub DestroySocket() - ' - On Error GoTo DestroySocket_Err - - ' -100 If Not m_lngSocketHandle = INVALID_SOCKET Then - Dim lngResult As Long -101 lngResult = api_closesocket(m_lngSocketHandle) - -102 If lngResult = SOCKET_ERROR Then -103 m_enmState = sckError - Dim lngErrorCode As Long -104 lngErrorCode = Err.LastDllError -105 Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode) - Else -106 modSocketMaster.UnregisterSocket m_lngSocketHandle -107 m_lngSocketHandle = INVALID_SOCKET - End If - End If - - ' - Exit Sub -DestroySocket_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.DestroySocket.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub - -Public Sub CloseSck() - ' - On Error GoTo CloseSck_Err - - ' -100 If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub -101 m_enmState = sckClosing -102 CleanResolutionSystem -103 DestroySocket -104 m_lngLocalPortBind = 0 -105 m_strRemoteHostIP = "" -106 m_strRecvBuffer = "" -107 m_strSendBuffer = "" -108 m_lngSendBufferLen = 0 -109 m_lngRecvBufferLen = 0 -110 m_enmState = sckClosed - ' - Exit Sub -CloseSck_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.CloseSck.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub - -'Tries to create a socket if there isn't one yet and registers -'it to the control list. -'Returns TRUE if it has success -Private Function SocketExists() As Boolean - ' - On Error GoTo SocketExists_Err - ' -100 SocketExists = True - Dim lngResult As Long - Dim lngErrorCode As Long - - 'check if there is a socket already -101 If m_lngSocketHandle = INVALID_SOCKET Then - - 'decide what kind of socket we are creating, TCP or UDP -102 If m_enmProtocol = sckTCPProtocol Then -103 lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP) - Else -104 lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP) - End If - -105 If lngResult = INVALID_SOCKET Then -106 m_enmState = sckError -107 SocketExists = False -108 lngErrorCode = Err.LastDllError - Dim blnCancelDisplay As Boolean -109 blnCancelDisplay = True -110 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay) - -111 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists" - Else -112 m_lngSocketHandle = lngResult - 'set and get some socket options -113 ProcessOptions -114 SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True) - End If - End If - - ' - Exit Function -SocketExists_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SocketExists.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Function - -'Tries to connect to RemoteHost if it was passed, or uses -'m_strRemoteHost instead. If it is a hostname tries to -'resolve it first. -Public Sub Connect(Optional RemoteHost As Variant, _ - Optional RemotePort As Variant) - ' - On Error GoTo Connect_Err - - ' -100 If m_enmState <> sckClosed Then -101 Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state" - End If - -102 If Not IsMissing(RemoteHost) Then -103 m_strRemoteHost = CStr(RemoteHost) - End If - - 'for some reason we get a GPF if we try to - 'resolve a null string, so we replace it with - 'an empty string -104 If m_strRemoteHost = vbNullString Then -105 m_strRemoteHost = "" - End If - - 'check if RemotePort is a number between 1 and 65535 -106 If Not IsMissing(RemotePort) Then -107 If IsNumeric(RemotePort) Then -108 If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then -109 Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range." - Else -110 m_lngRemotePort = CLng(RemotePort) - End If - - Else -111 Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type." - End If - End If - - 'create a socket if there isn't one yet -112 If Not SocketExists Then Exit Sub - - 'Here we bind the socket -113 If Not BindInternal Then Exit Sub - - 'If we are using UDP we just exit silently. - 'Remember UDP is a connectionless protocol. -114 If m_enmProtocol = sckUDPProtocol Then -115 m_enmState = sckOpen - Exit Sub - End If - - 'try to get a 32 bits long that is used to identify a host - Dim lngAddress As Long -116 lngAddress = ResolveIfHostname(m_strRemoteHost) - - 'We've got two options here: - '1) m_strRemoteHost was an IP, so a resolution wasn't - ' necessary, and now lngAddress is a 32 bits long and - ' we proceed to connect. - '2) m_strRemoteHost was a hostname, so a resolution was - ' necessary and it's taking place right now. We leave - ' silently. -117 If lngAddress <> vbNull Then - '136 registrar "~SOCK: Conectando directamente por IP", 3 -118 ConnectToIP lngAddress, 0 - End If - - ' - Exit Sub -Connect_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Connect.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub - -'When the system resolves a hostname in asynchronous way we -'call this function to decide what to do with the result. -Private Sub PostResolution(ByVal lngAsynHandle As Long, _ - ByVal lngErrorCode As Long) - 'erase that record from the collection since we won't need it any longer - ' - On Error GoTo PostResolution_Err - ' -100 m_colWaitingResolutions.Remove "R" & lngAsynHandle -101 UnregisterResolution lngAsynHandle - -102 If m_enmState <> sckResolvingHost Then Exit Sub -103 If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname -104 m_enmState = sckHostResolved - Dim udtHostent As HOSTENT - Dim lngPtrToIP As Long - Dim arrIpAddress(1 To 4) As Byte - Dim lngRemoteHostAddress As Long - Dim Count As Integer - Dim strIpAddress As String -105 api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent) -106 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 -107 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 -108 api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4 - 'free memory, won't need it any longer -109 FreeMemory - - 'We turn the 32 bits long into a readable string. - 'Note: we don't need this string. I put this here just - 'in case you need it. -110 For Count = 1 To 4 -111 strIpAddress = strIpAddress & arrIpAddress(Count) & "." - Next - -112 strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) -113 ConnectToIP lngRemoteHostAddress, 0 - Else 'there were errors trying to resolve the hostname - 'free buffer memory -114 FreeMemory -115 ConnectToIP vbNull, lngErrorCode - End If - - ' - Exit Sub -PostResolution_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PostResolution.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub - -'This procedure is called by the WindowProc callback function. -'The lngEventID argument is an ID of the network event -'occurred for the socket. The lngErrorCode argument contains -'an error code only if an error was occurred during an -'asynchronous execution. -Private Sub PostSocket(ByVal lngEventID As Long, _ - ByVal lngErrorCode As Long) - ' - On Error GoTo PostSocket_Err - ' - Dim blnCancelDisplay As Boolean - - 'handle any possible error -100 If lngErrorCode <> 0 Then -101 m_enmState = sckError -102 Registrar "~SOCK: Estado -> sckError", 3 -103 blnCancelDisplay = True -104 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay) - -105 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket" - Exit Sub - End If - - Dim udtSockAddr As sockaddr_in - Dim lngResult As Long - Dim lngBytesReceived As Long - -106 Select Case lngEventID - - '====================================================================== - Case FD_CONNECT - - 'Arrival of this message means that the connection initiated by the call - 'of the connect Winsock API function was successfully established. - 'registrar "~SOCK:" & "FD_CONNECT " & m_lngSocketHandle, 3 -107 If m_enmState <> sckConnecting Then -108 Registrar "~SOCK:" & "Advertencia: Omitiendo FD_CONNECT", 3 - Exit Sub - End If - - 'Get the local parameters -109 GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP - 'Get the connection local end-point parameters -110 GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost -111 m_enmState = sckConnected -112 Registrar "~SOCK: Estado -> sckConnected", 3 -113 RaiseEvent Connect - - '====================================================================== -114 Case FD_WRITE - - 'This message means that the socket in a write-able - 'state, that is, buffer for outgoing data of the transport - 'service is empty and ready to receive data to send through - 'the network. - 'registrar "~SOCK:" & "FD_WRITE " & m_lngSocketHandle, 3 -115 If m_enmState <> sckConnected Then -116 Registrar "~SOCK:" & "Advertencia: Omitiendo FD_WRITE", 3 - Exit Sub - End If - -117 If Len(m_strSendBuffer) > 0 Then -118 SendBufferedData - End If - - '====================================================================== -119 Case FD_READ - - 'Some data has arrived for this socket. - 'registrar "~SOCK:" & "FD_READ " & m_lngSocketHandle, 3 -120 If m_enmProtocol = sckTCPProtocol Then -121 If m_enmState <> sckConnected Then -122 Registrar "~SOCK:" & "Advertencia: Omitiendo FD_READ", 3 - Exit Sub - End If - - 'Call the RecvDataToBuffer function that move arrived data - 'from the Winsock buffer to the local one and returns number - 'of bytes received. -123 lngBytesReceived = RecvDataToBuffer - -124 If lngBytesReceived > 0 Then -125 RaiseEvent DataArrival(Len(m_strRecvBuffer)) - End If - - Else 'UDP protocol - -126 If m_enmState <> sckOpen Then -127 Registrar "~SOCK:" & "Advertencia: Omitiendo FD_READ", 3 - Exit Sub - End If - - 'If we use UDP we don't remove data from winsock buffer. - 'We just let the user know the amount received so - 'he/she can decide what to do. -128 lngBytesReceived = GetBufferLenUDP - -129 If lngBytesReceived > 0 Then -130 RaiseEvent DataArrival(lngBytesReceived) - End If - - 'Now the buffer is emptied no matter what the user - 'dicided to do with the received data -131 EmptyBuffer - End If - - '====================================================================== -132 Case FD_ACCEPT - - 'When the socket is in a listening state, arrival of this message - 'means that a connection request was received. Call the accept - 'Winsock API function in oreder to create a new socket for the - 'requested connection. - 'registrar "~SOCK:" & "FD_ACCEPT " & m_lngSocketHandle, 3 -133 If m_enmState <> sckListening Then -134 Registrar "~SOCK:" & "Advertencia: Omitiendo FD_ACCEPT", 3 - Exit Sub - End If - -135 lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) - -136 If lngResult = INVALID_SOCKET Then -137 lngErrorCode = Err.LastDllError -138 m_enmState = sckError -139 blnCancelDisplay = True -140 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay) - -141 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket" - Else - 'We assign a temporal instance of CSocketMaster to - 'handle this new socket until user accepts (or not) - 'the new connection -142 modSocketMaster.RegisterAccept lngResult - 'We change remote info before firing ConnectionRequest - 'event so the user can see which host is trying to - 'connect. - Dim lngTempRP As Long - Dim strTempRHIP As String - Dim strTempRH As String -143 lngTempRP = m_lngRemotePort -144 strTempRHIP = m_strRemoteHostIP -145 strTempRH = m_strRemoteHost -146 GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost -147 Registrar "~SOCK: Socket aceptado -> " & lngResult, 3 -148 RaiseEvent ConnectionRequest(lngResult) - - 'we return original info -149 If m_enmState = sckListening Then -150 m_lngRemotePort = lngTempRP -151 m_strRemoteHostIP = strTempRHIP -152 m_strRemoteHost = strTempRH - End If - - 'This is very important. If the connection wasn't accepted - 'we must close the socket. -153 If IsAcceptRegistered(lngResult) Then -154 api_closesocket lngResult -155 modSocketMaster.UnregisterSocket lngResult -156 modSocketMaster.UnregisterAccept lngResult -157 Registrar "~SOCK: Socket aceptado cerrado -> " & lngResult, 3 - End If - End If - - '====================================================================== -158 Case FD_CLOSE - - 'This message means that the remote host is closing the conection - 'registrar "~SOCK:" & "FD_CLOSE " & m_lngSocketHandle, 3 -159 If m_enmState <> sckConnected Then -160 Registrar "~SOCK: Advertencia: Omitiendo FD_CLOSE", 3 - Exit Sub - End If - -161 m_enmState = sckClosing -162 Registrar "~SOCK: Estado -> sckClosing", 3 -163 RaiseEvent CloseSck - End Select - - ' - Exit Sub -PostSocket_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PostSocket.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub - -'Connect to a given 32 bits long ip -Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, _ - ByVal lngErrorCode As Long) - ' - On Error GoTo ConnectToIP_Err - ' - Dim blnCancelDisplay As Boolean - - 'Check and handle errors -100 If lngErrorCode <> 0 Then -101 m_enmState = sckError -102 blnCancelDisplay = True -103 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) - -104 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" - Exit Sub - End If - -105 Registrar "~SOCK: Conectando a: " + m_strRemoteHost + " " + m_strRemoteHostIP, 3 -106 m_enmState = sckConnecting -107 Registrar "~SOCK: Estado -> sckConnecting", 3 - Dim udtSockAddr As sockaddr_in - Dim lngResult As Long - - 'Build the sockaddr_in structure to pass it to the connect - 'Winsock API function as an address of the remote host. -108 With udtSockAddr -109 .sin_addr = lngRemoteHostAddress -110 .sin_family = AF_INET -111 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) - End With - - 'Call the connect Winsock API function in order to establish connection. -112 lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) - - 'Check and handle errors -113 If lngResult = SOCKET_ERROR Then -114 lngErrorCode = Err.LastDllError - -115 If lngErrorCode <> WSAEWOULDBLOCK Then -116 If lngErrorCode = WSAEADDRNOTAVAIL Then -117 Err.Raise WSAEADDRNOTAVAIL, "CSocketMaster.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL) - Else -118 m_enmState = sckError -119 blnCancelDisplay = True -120 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) - -121 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" - End If - End If - End If - - ' - Exit Sub -ConnectToIP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ConnectToIP.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Sub -'Public Sub Bind(Optional LocalPort As Variant, _ -' Optional LocalIP As Variant) -' ' -' On Error GoTo Bind_Err -' ' -' -'100 If m_enmState <> sckClosed Then -'102 Err.Raise sckInvalidOp, "CSocketMaster.Bind", "Operación invalida en el estado actual" -' End If -' -''104 If BindInternal(LocalPort, LocalIP) Then -' -'104 If BindInternal(LocalPort, LocalIP) Then -'106 m_enmState = sckOpen -' End If -' -' ' -' Exit Sub -' -'Bind_Err: -' -' Controlar_Error Erl, Err.Description, "XMR.CSocketMaster.Bind" -' Resume Next -' ' -'End Sub - -'This function binds a socket to a local port and IP. -'Retunrs TRUE if it has success. -Private Function BindInternal(Optional ByVal varLocalPort As Variant, _ - Optional ByVal varLocalIP As Variant) As Boolean - ' - On Error GoTo BindInternal_Err - - ' -100 If m_enmState = sckOpen Then -101 BindInternal = True - Exit Function - End If - - Dim lngLocalPortInternal As Long - Dim strLocalHostInternal As String - Dim strIP As String - Dim lngAddressInternal As Long - Dim lngResult As Long - Dim lngErrorCode As Long -102 BindInternal = False - - 'Check if varLocalPort is a number between 0 and 65535 -103 If Not IsMissing(varLocalPort) Then -104 If IsNumeric(varLocalPort) Then -105 If varLocalPort < 0 Or varLocalPort > 65535 Then -106 BindInternal = False -107 Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "El argumento pasado a la función no era correcto o no era en el rango especificado" - Else -108 lngLocalPortInternal = CLng(varLocalPort) - End If - - Else -109 BindInternal = False -110 Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Tipos variantes no soportados" - End If - - Else -111 lngLocalPortInternal = m_lngLocalPort - End If - -112 If IsMissing(varLocalIP) Then varLocalIP = "000.000.000.000" -113 strLocalHostInternal = CStr(varLocalIP) - 'registrar "~SOCK:" & "@Wine => varLocalIP: " & CStr(varLocalIP) & " | strLocalHostInternal: " & CStr(strLocalHostInternal) & " | strIP: " & strIP, 3 - 'get a 32 bits long IP -114 lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult) - - 'registrar "~SOCK:" & "@Wine => lngResult: " & lngResult, 3 -115 If lngResult <> 0 Then Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Argumento inválido" - - 'create a socket if there isn't one yet -116 If Not SocketExists Then Exit Function - Dim udtSockAddr As sockaddr_in - -117 With udtSockAddr -118 .sin_addr = lngAddressInternal -119 .sin_family = AF_INET -120 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal)) - End With - - 'bind the socket -121 lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) - -122 If lngResult = SOCKET_ERROR Then -123 lngErrorCode = Err.LastDllError -124 Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) - Else - -125 If lngLocalPortInternal <> 0 Then - '160 registrar "~SOCK: Servidor enlazado -> " & strLocalHostInternal & " | Puerto -> " & lngLocalPortInternal, 3 -126 m_lngLocalPort = lngLocalPortInternal - Else -127 lngResult = GetLocalPort(m_lngSocketHandle) - -128 If lngResult = SOCKET_ERROR Then -129 lngErrorCode = Err.LastDllError -130 Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) - Else - 'registrar "~SOCK: Servidor enlazado -> " & strLocalHostInternal & " | Puerto -> " & lngLocalPortInternal, 3 -131 m_lngLocalPortBind = lngResult - End If - End If - -132 BindInternal = True - End If - - ' - Exit Function -BindInternal_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BindInternal.Ref 12/8/2008 : 08:11:19" - Resume Next - ' -End Function - -'Allocate some memory for HOSTEN structure and returns -'a pointer to this buffer if no error occurs. -'Returns 0 if it fails. -Private Function AllocateMemory() As Long - ' - On Error GoTo AllocateMemory_Err - ' -100 m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT) - -101 If m_lngMemoryHandle <> 0 Then -102 m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle) - -103 If m_lngMemoryPointer <> 0 Then -104 api_GlobalUnlock (m_lngMemoryHandle) -105 AllocateMemory = m_lngMemoryPointer - Else -106 api_GlobalFree (m_lngMemoryHandle) -107 AllocateMemory = m_lngMemoryPointer '0 - End If - - Else -108 AllocateMemory = m_lngMemoryHandle '0 - End If - - ' - Exit Function -AllocateMemory_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.AllocateMemory.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Free memory allocated by AllocateMemory -Private Sub FreeMemory() - ' - On Error GoTo FreeMemory_Err - - ' -100 If m_lngMemoryHandle <> 0 Then -101 m_lngMemoryPointer = 0 -102 api_GlobalFree m_lngMemoryHandle -103 m_lngMemoryHandle = 0 - 'registrar "~SOCK: Liberada memoria de resolución", 3 - End If - - ' - Exit Sub -FreeMemory_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.FreeMemory.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -Private Function GetLocalHostName() As String - ' - On Error GoTo GetLocalHostName_Err - ' - Dim strHostNameBuf As String * LOCAL_HOST_BUFF - Dim lngResult As Long -100 lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF) - -101 If lngResult = SOCKET_ERROR Then -102 GetLocalHostName = vbNullString - Dim lngErrorCode As Long -103 lngErrorCode = Err.LastDllError -104 Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode) - Else -105 GetLocalHostName = Left$(strHostNameBuf, InStr(1, strHostNameBuf, vbNullChar) - 1) - End If - - ' - Exit Function -GetLocalHostName_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalHostName.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Get local IP when the socket isn't connected yet -Private Function GetLocalIP() As String - ' - On Error GoTo GetLocalIP_Err - ' - Dim lngResult As Long - Dim lngPtrToIP As Long - Dim strLocalHost As String - Dim arrIpAddress(1 To 4) As Byte - Dim Count As Integer - Dim udtHostent As HOSTENT - Dim strIpAddress As String -100 strLocalHost = GetLocalHostName -101 lngResult = api_gethostbyname(strLocalHost) - -102 If lngResult = 0 Then -103 GetLocalIP = vbNullString - Dim lngErrorCode As Long -104 lngErrorCode = Err.LastDllError -105 Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode) - Else -106 api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) -107 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 -108 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 - -109 For Count = 1 To 4 -110 strIpAddress = strIpAddress & arrIpAddress(Count) & "." - Next - -111 strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) -112 GetLocalIP = strIpAddress - End If - - ' - Exit Function -GetLocalIP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalIP.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'If Host is an IP doesn't resolve anything and returns a -'a 32 bits long IP. -'If Host isn't an IP then returns vbNull, tries to resolve it -'in asynchronous way. -Private Function ResolveIfHostname(ByVal Host As String) As Long - ' - On Error GoTo ResolveIfHostname_Err - ' - Dim lngAddress As Long -100 lngAddress = api_inet_addr(Host) - -101 If lngAddress = INADDR_NONE Then 'if Host isn't an IP -102 ResolveIfHostname = vbNull -103 m_enmState = sckResolvingHost - -104 If AllocateMemory Then - Dim lngAsynHandle As Long -105 lngAsynHandle = modSocketMaster.ResolveHost(Host, m_lngMemoryPointer, ObjPtr(Me)) - -106 If lngAsynHandle = 0 Then -107 FreeMemory -108 m_enmState = sckError - Dim lngErrorCode As Long -109 lngErrorCode = Err.LastDllError - Dim blnCancelDisplay As Boolean -110 blnCancelDisplay = True -111 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay) - -112 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ResolveIfHostname" - Else -113 m_colWaitingResolutions.Add lngAsynHandle, "R" & lngAsynHandle -114 Registrar "~SOCK: Resolviendo servidor -> " & Host & " - con control ASYNC: " & lngAsynHandle, 3 - End If - - Else -115 m_enmState = sckError -116 Registrar "~SOCK: Error asignando memoria", 3 -117 Err.Raise sckOutOfMemory, "CSocketMaster.ResolveIfHostname", "Sin memoria" - End If - - Else 'if Host is an IP doen't need to resolve anything -118 ResolveIfHostname = lngAddress - End If - - ' - Exit Function -ResolveIfHostname_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ResolveIfHostname.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Resolves a host (if necessary) in synchronous way -'If succeeds returns a 32 bits long IP, -'strHostIP = readable IP string and lngErrorCode = 0 -'If fails returns vbNull, -'strHostIP = vbNullString and lngErrorCode <> 0 -Private Function ResolveIfHostnameSync(ByVal Host As String, _ - ByRef strHostIP As String, _ - ByRef lngErrorCode As Long) As Long - ' - On Error GoTo ResolveIfHostnameSync_Err - ' - Dim lngPtrToHOSTENT As Long - Dim udtHostent As HOSTENT - Dim lngAddress As Long - Dim lngPtrToIP As Long - Dim arrIpAddress(1 To 4) As Byte - Dim Count As Integer -100 lngAddress = api_inet_addr(Host) - -101 If lngAddress = INADDR_NONE Then 'if Host isn't an IP -102 lngPtrToHOSTENT = api_gethostbyname(Host) - -103 If lngPtrToHOSTENT = 0 Then -104 lngErrorCode = Err.LastDllError -105 strHostIP = vbNullString -106 ResolveIfHostnameSync = vbNull - Else -107 api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent) -108 api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 -109 api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 -110 api_CopyMemory lngAddress, ByVal lngPtrToIP, 4 - -111 For Count = 1 To 4 -112 strHostIP = strHostIP & arrIpAddress(Count) & "." - Next - -113 strHostIP = Left$(strHostIP, Len(strHostIP) - 1) -114 lngErrorCode = 0 -115 ResolveIfHostnameSync = lngAddress - End If - - Else 'if Host is an IP doen't need to resolve anything -116 lngErrorCode = 0 -117 strHostIP = Host -118 ResolveIfHostnameSync = lngAddress - End If - - ' - Exit Function -ResolveIfHostnameSync_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ResolveIfHostnameSync.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Returns local port from a connected or bound socket. -'Returns SOCKET_ERROR if fails. -Private Function GetLocalPort(ByVal lngSocket As Long) As Long - ' - On Error GoTo GetLocalPort_Err - ' - Dim udtSockAddr As sockaddr_in - Dim lngResult As Long -100 lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr)) - -101 If lngResult = SOCKET_ERROR Then -102 GetLocalPort = SOCKET_ERROR - Else -103 GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) - End If - - ' - Exit Function -GetLocalPort_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalPort.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -Public Sub SendData(data As Variant) - ' - On Error GoTo SendData_Err - ' - Dim arrData() As Byte 'We store the data here before send it - -100 If m_enmProtocol = sckTCPProtocol Then -101 If m_enmState <> sckConnected Then -102 Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request" - Exit Sub - End If - - Else 'If we use UDP we create a socket if there isn't one yet - -103 If Not SocketExists Then Exit Sub -104 If Not BindInternal Then Exit Sub -105 m_enmState = sckOpen - End If - - 'We need to convert data variant into a byte array -106 Select Case varType(data) - - Case vbString - Dim strdata As String -107 strdata = CStr(data) - -108 If Len(strdata) = 0 Then Exit Sub -109 ReDim arrData(Len(strdata) - 1) -110 arrData() = StrConv(strdata, vbFromUnicode) - -111 Case vbArray + vbByte - Dim strArray As String -112 strArray = StrConv(data, vbUnicode) - -113 If Len(strArray) = 0 Then Exit Sub -114 arrData() = StrConv(strArray, vbFromUnicode) - -115 Case vbBoolean - Dim blnData As Boolean -116 blnData = CBool(data) -117 ReDim arrData(LenB(blnData) - 1) -118 api_CopyMemory arrData(0), blnData, LenB(blnData) - -119 Case vbByte - Dim bytData As Byte -120 bytData = CByte(data) -121 ReDim arrData(LenB(bytData) - 1) -122 api_CopyMemory arrData(0), bytData, LenB(bytData) - -123 Case vbCurrency - Dim curData As Currency -124 curData = CCur(data) -125 ReDim arrData(LenB(curData) - 1) -126 api_CopyMemory arrData(0), curData, LenB(curData) - -127 Case vbDate - Dim datData As Date -128 datData = CDate(data) -129 ReDim arrData(LenB(datData) - 1) -130 api_CopyMemory arrData(0), datData, LenB(datData) - -131 Case vbDouble - Dim dblData As Double -132 dblData = CDbl(data) -133 ReDim arrData(LenB(dblData) - 1) -134 api_CopyMemory arrData(0), dblData, LenB(dblData) - -135 Case vbInteger - Dim intData As Integer -136 intData = CInt(data) -137 ReDim arrData(LenB(intData) - 1) -138 api_CopyMemory arrData(0), intData, LenB(intData) - -139 Case vbLong - Dim lngData As Long -140 lngData = CLng(data) -141 ReDim arrData(LenB(lngData) - 1) -142 api_CopyMemory arrData(0), lngData, LenB(lngData) - -143 Case vbSingle - Dim sngData As Single -144 sngData = CSng(data) -145 ReDim arrData(LenB(sngData) - 1) -146 api_CopyMemory arrData(0), sngData, LenB(sngData) - -147 Case Else -148 Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type." - End Select - - 'if there's already something in the buffer that means we are - 'already sending data, so we put the new data in the buffer - 'and exit silently -149 If Len(m_strSendBuffer) > 0 Then -150 m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) - Exit Sub - Else -151 m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) - End If - - 'send the data -152 SendBufferedData - ' - Exit Sub -SendData_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendData.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Check which protocol we are using to decide which -'function should handle the data sending. -Private Sub SendBufferedData() - ' - On Error GoTo SendBufferedData_Err - - ' -100 If m_enmProtocol = sckTCPProtocol Then -101 SendBufferedDataTCP - Else -102 SendBufferedDataUDP - End If - - ' - Exit Sub -SendBufferedData_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedData.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Send buffered data if we are using UDP protocol. -Private Sub SendBufferedDataUDP() - ' - On Error GoTo SendBufferedDataUDP_Err - ' - Dim lngAddress As Long - Dim udtSockAddr As sockaddr_in - Dim arrData() As Byte - Dim lngBufferLength As Long - Dim lngResult As Long - Dim lngErrorCode As Long - Dim strTemp As String -100 lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode) - -101 If lngErrorCode <> 0 Then -102 m_strSendBuffer = "" - -103 If lngErrorCode = WSAEAFNOSUPPORT Then -104 Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode) - Else -105 Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument" - End If - End If - -106 With udtSockAddr -107 .sin_addr = lngAddress -108 .sin_family = AF_INET -109 .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) - End With - -110 lngBufferLength = Len(m_strSendBuffer) -111 arrData() = StrConv(m_strSendBuffer, vbFromUnicode) -112 m_strSendBuffer = "" -113 lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr)) - -114 If lngResult = SOCKET_ERROR Then -115 lngErrorCode = Err.LastDllError -116 m_enmState = sckError - Dim blnCancelDisplay As Boolean -117 blnCancelDisplay = True -118 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay) - -119 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP" - End If - - ' - Exit Sub -SendBufferedDataUDP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedDataUDP.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Send buffered data if we are using TCP protocol. -Private Sub SendBufferedDataTCP() - ' - On Error GoTo SendBufferedDataTCP_Err - ' - Dim arrData() As Byte - Dim lngBufferLength As Long - Dim lngResult As Long - Dim lngTotalSent As Long - -100 Do Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0 -101 lngBufferLength = Len(m_strSendBuffer) - -102 If lngBufferLength > m_lngSendBufferLen Then -103 lngBufferLength = m_lngSendBufferLen -104 arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode) - Else -105 arrData() = StrConv(m_strSendBuffer, vbFromUnicode) - End If - -106 lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&) - -107 If lngResult = SOCKET_ERROR Then - Dim lngErrorCode As Long -108 lngErrorCode = Err.LastDllError - -109 If lngErrorCode = WSAEWOULDBLOCK Then -110 Registrar "~SOCK:" & "Advertencia: Buffer de envío lleno, esperando...", 3 - -111 If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer)) - Else -112 m_enmState = sckError - Dim blnCancelDisplay As Boolean -113 blnCancelDisplay = True -114 RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay) - -115 If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedData" - End If - - Else -116 Registrar "~SOCK: Bytes enviados => " & lngResult, 3 -117 lngTotalSent = lngTotalSent + lngResult - -118 If Len(m_strSendBuffer) > lngResult Then -119 m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1) - Else -120 Registrar "~SOCK: Envío terminado", 3 -121 m_strSendBuffer = "" - Dim lngTemp As Long -122 lngTemp = lngTotalSent -123 lngTotalSent = 0 -124 RaiseEvent SendProgress(lngTemp, 0) -125 RaiseEvent SendComplete - End If - End If - - Loop - - ' - Exit Sub -SendBufferedDataTCP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedDataTCP.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'This function retrieves data from the Winsock buffer -'into the class local buffer. The function returns number -'of bytes retrieved (received). -Private Function RecvDataToBuffer() As Long - ' - On Error GoTo RecvDataToBuffer_Err - ' - Dim arrBuffer() As Byte - Dim lngBytesReceived As Long - Dim strBuffTemporal As String -100 ReDim arrBuffer(m_lngRecvBufferLen - 1) -101 lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&) - -102 If lngBytesReceived = SOCKET_ERROR Then -103 m_enmState = sckError - Dim lngErrorCode As Long -104 lngErrorCode = Err.LastDllError -105 Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode) -106 ElseIf lngBytesReceived > 0 Then -107 strBuffTemporal = StrConv(arrBuffer(), vbUnicode) -108 m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived) -109 RecvDataToBuffer = lngBytesReceived - End If - - ' - Exit Function -RecvDataToBuffer_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RecvDataToBuffer.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Retrieves some socket options. -'If it is an UDP socket also sets SO_BROADCAST option. -Private Sub ProcessOptions() - ' - On Error GoTo ProcessOptions_Err - ' - Dim lngResult As Long - Dim lngBuffer As Long - Dim lngErrorCode As Long - -100 If m_enmProtocol = sckTCPProtocol Then -101 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer)) - -102 If lngResult = SOCKET_ERROR Then -103 lngErrorCode = Err.LastDllError -104 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) - Else -105 m_lngRecvBufferLen = lngBuffer - End If - -106 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer)) - -107 If lngResult = SOCKET_ERROR Then -108 lngErrorCode = Err.LastDllError -109 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) - Else -110 m_lngSendBufferLen = lngBuffer - End If - - Else -111 lngBuffer = 1 -112 lngResult = api_setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer)) -113 lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer)) - -114 If lngResult = SOCKET_ERROR Then -115 lngErrorCode = Err.LastDllError -116 Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) - Else -117 m_lngRecvBufferLen = lngBuffer -118 m_lngSendBufferLen = lngBuffer - End If - End If - - 'registrar "~SOCK:" & "Tamaño de buffer para envíar: " & m_lngRecvBufferLen, 3 - 'registrar "~SOCK:" & "Tamaño de buffer para recibir: " & m_lngSendBufferLen, 3 - ' - Exit Sub -ProcessOptions_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ProcessOptions.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -Public Sub GetData(ByRef data As Variant, _ - Optional varType As Variant, _ - Optional maxLen As Variant) - ' - On Error GoTo GetData_Err - - ' -100 If m_enmProtocol = sckTCPProtocol Then -101 If m_enmState <> sckConnected And Not m_blnAcceptClass Then -102 Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" - Exit Sub - End If - - Else - -103 If m_enmState <> sckOpen Then -104 Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" - Exit Sub - End If - -105 If GetBufferLenUDP = 0 Then Exit Sub - End If - -106 If Not IsMissing(maxLen) Then -107 If IsNumeric(maxLen) Then -108 If CLng(maxLen) < 0 Then -109 Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range." - End If - - Else - -110 If m_enmProtocol = sckTCPProtocol Then -111 maxLen = Len(m_strRecvBuffer) - Else -112 maxLen = GetBufferLenUDP - End If - End If - End If - - Dim lngBytesRecibidos As Long -113 lngBytesRecibidos = RecvData(data, False, varType, maxLen) -114 Registrar "~SOCK: Bytes Obtenidos del buffer: " & lngBytesRecibidos, 3 - ' - Exit Sub -GetData_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetData.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -Public Sub PeekData(ByRef data As Variant, _ - Optional varType As Variant, _ - Optional maxLen As Variant) - ' - On Error GoTo PeekData_Err - - ' -100 If m_enmProtocol = sckTCPProtocol Then -101 If m_enmState <> sckConnected Then -102 Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" - Exit Sub - End If - - Else - -103 If m_enmState <> sckOpen Then -104 Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" - Exit Sub - End If - -105 If GetBufferLenUDP = 0 Then Exit Sub - End If - -106 If Not IsMissing(maxLen) Then -107 If IsNumeric(maxLen) Then -108 If CLng(maxLen) < 0 Then -109 Err.Raise sckInvalidArg, "CSocketMaster.PeekData", "The argument passed to a function was not in the correct format or in the specified range." - End If - - Else - -110 If m_enmProtocol = sckTCPProtocol Then -111 maxLen = Len(m_strRecvBuffer) - Else -112 maxLen = GetBufferLenUDP - End If - End If - End If - - Dim lngBytesRecibidos As Long -113 lngBytesRecibidos = RecvData(data, True, varType, maxLen) -114 Registrar "~SOCK: Bytes obtenidos del buffer: " & lngBytesRecibidos, 3 - ' - Exit Sub -PeekData_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PeekData.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'This function is to retrieve data from the buffer. If we are using TCP -'then the data is retrieved from a local buffer (m_strRecvBuffer). If we -'are using UDP the data is retrieved from winsock buffer. -'It can be called by two public methods of the class - GetData and PeekData. -'Behavior of the function is defined by the blnPeek argument. If a value of -'that argument is TRUE, the function returns number of bytes in the -'buffer, and copy data from that buffer into the data argument. -'If a value of the blnPeek is FALSE, then this function returns number of -'bytes received, and move data from the buffer into the data -'argument. MOVE means that data will be removed from the buffer. -Private Function RecvData(ByRef data As Variant, _ - ByVal blnPeek As Boolean, _ - Optional varClass As Variant, _ - Optional maxLen As Variant) As Long - ' - On Error GoTo RecvData_Err - ' - Dim blnMaxLenMiss As Boolean - Dim blnClassMiss As Boolean - 'Dim strRecvData As String - Dim lngBufferLen As Long - Dim arrBuffer() As Byte - Dim lngErrorCode As Long - -100 If m_enmProtocol = sckTCPProtocol Then -101 lngBufferLen = Len(m_strRecvBuffer) - Else -102 lngBufferLen = GetBufferLenUDP - End If - -103 blnMaxLenMiss = IsMissing(maxLen) -104 blnClassMiss = IsMissing(varClass) - - 'Select type of data -105 If varType(data) = vbEmpty Then -106 If blnClassMiss Then varClass = vbArray + vbByte - Else -107 varClass = varType(data) - End If - - 'As stated on Winsock control documentation if the - 'data type passed is string or byte array type then - 'we must take into account maxLen argument. - 'If it is another type maxLen is ignored. -108 If varClass = vbString Or varClass = vbArray + vbByte Then -109 If blnMaxLenMiss Then 'if maxLen argument is missing -110 If lngBufferLen = 0 Then -111 RecvData = 0 -112 arrBuffer = StrConv("", vbFromUnicode) -113 data = arrBuffer - Exit Function - Else -114 RecvData = lngBufferLen -115 BuildArray lngBufferLen, blnPeek, lngErrorCode, arrBuffer - End If - - Else 'if maxLen argument is not missing - -116 If maxLen = 0 Or lngBufferLen = 0 Then -117 RecvData = 0 -118 arrBuffer = StrConv("", vbFromUnicode) -119 data = arrBuffer - -120 If m_enmProtocol = sckUDPProtocol Then -121 EmptyBuffer -122 Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE) - End If - - Exit Function -123 ElseIf maxLen > lngBufferLen Then -124 RecvData = lngBufferLen -125 BuildArray lngBufferLen, blnPeek, lngErrorCode, arrBuffer - Else -126 RecvData = CLng(maxLen) -127 BuildArray CLng(maxLen), blnPeek, lngErrorCode, arrBuffer - End If - End If - End If - -128 Select Case varClass - - Case vbString - Dim strdata As String -129 strdata = StrConv(arrBuffer(), vbUnicode) -130 data = strdata - -131 Case vbArray + vbByte -132 data = arrBuffer - -133 Case vbBoolean - Dim blnData As Boolean - -134 If LenB(blnData) > lngBufferLen Then Exit Function -135 BuildArray LenB(blnData), blnPeek, lngErrorCode, arrBuffer -136 RecvData = LenB(blnData) -137 api_CopyMemory blnData, arrBuffer(0), LenB(blnData) -138 data = blnData - -139 Case vbByte - Dim bytData As Byte - -140 If LenB(bytData) > lngBufferLen Then Exit Function -141 BuildArray LenB(bytData), blnPeek, lngErrorCode, arrBuffer -142 RecvData = LenB(bytData) -143 api_CopyMemory bytData, arrBuffer(0), LenB(bytData) -144 data = bytData - -145 Case vbCurrency - Dim curData As Currency - -146 If LenB(curData) > lngBufferLen Then Exit Function -147 BuildArray LenB(curData), blnPeek, lngErrorCode, arrBuffer -148 RecvData = LenB(curData) -149 api_CopyMemory curData, arrBuffer(0), LenB(curData) -150 data = curData - -151 Case vbDate - Dim datData As Date - -152 If LenB(datData) > lngBufferLen Then Exit Function -153 BuildArray LenB(datData), blnPeek, lngErrorCode, arrBuffer -154 RecvData = LenB(datData) -155 api_CopyMemory datData, arrBuffer(0), LenB(datData) -156 data = datData - -157 Case vbDouble - Dim dblData As Double - -158 If LenB(dblData) > lngBufferLen Then Exit Function -159 BuildArray LenB(dblData), blnPeek, lngErrorCode, arrBuffer -160 RecvData = LenB(dblData) -161 api_CopyMemory dblData, arrBuffer(0), LenB(dblData) -162 data = dblData - -163 Case vbInteger - Dim intData As Integer - -164 If LenB(intData) > lngBufferLen Then Exit Function -165 BuildArray LenB(intData), blnPeek, lngErrorCode, arrBuffer -166 RecvData = LenB(intData) -167 api_CopyMemory intData, arrBuffer(0), LenB(intData) -168 data = intData - -169 Case vbLong - Dim lngData As Long - -170 If LenB(lngData) > lngBufferLen Then Exit Function -171 BuildArray LenB(lngData), blnPeek, lngErrorCode, arrBuffer -172 RecvData = LenB(lngData) -173 api_CopyMemory lngData, arrBuffer(0), LenB(lngData) -174 data = lngData - -175 Case vbSingle - Dim sngData As Single - -176 If LenB(sngData) > lngBufferLen Then Exit Function -177 BuildArray LenB(sngData), blnPeek, lngErrorCode, arrBuffer -178 RecvData = LenB(sngData) -179 api_CopyMemory sngData, arrBuffer(0), LenB(sngData) -180 data = sngData - -181 Case Else -182 Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type." - End Select - - 'if BuildArray returns an error is handled here -183 If lngErrorCode <> 0 Then -184 Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode) - End If - - ' - Exit Function -RecvData_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RecvData.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Returns a byte array of Size bytes filled with incoming buffer data. -Private Sub BuildArray(ByVal Size As Long, _ - ByVal blnPeek As Boolean, _ - ByRef lngErrorCode As Long, _ - ByRef bytArray() As Byte) - ' - On Error GoTo BuildArray_Err - ' - Dim strdata As String - -100 If m_enmProtocol = sckTCPProtocol Then -101 strdata = Left$(m_strRecvBuffer, CLng(Size)) - -102 If strdata <> vbNullString Then bytArray = StrConv(strdata, vbFromUnicode) -103 If Not blnPeek Then m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1) - Else 'UDP protocol - Dim arrBuffer() As Byte - Dim lngResult As Long - Dim udtSockAddr As sockaddr_in - Dim lngFlags As Long - -104 If blnPeek Then lngFlags = MSG_PEEK -105 ReDim arrBuffer(Size - 1) -106 lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr)) - -107 If lngResult = SOCKET_ERROR Then -108 lngErrorCode = Err.LastDllError - End If - -109 bytArray = arrBuffer -110 GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost - End If - - ' - Exit Sub -BuildArray_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BuildArray.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Clean resolution system that is in charge of -'asynchronous hostname resolutions. -Private Sub CleanResolutionSystem() - ' - On Error GoTo CleanResolutionSystem_Err - ' - Dim varAsynHandle As Variant - Dim lngResult As Long - - 'cancel async resolutions if they're still running -100 For Each varAsynHandle In m_colWaitingResolutions -101 lngResult = api_WSACancelAsyncRequest(varAsynHandle) - -102 If lngResult = 0 Then -103 modSocketMaster.UnregisterResolution varAsynHandle -104 Set m_colWaitingResolutions = Nothing -105 Set m_colWaitingResolutions = New Collection - 'free memory buffer where resolution results are stored -106 FreeMemory - End If - - Next - - ' - Exit Sub -CleanResolutionSystem_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.CleanResolutionSystem.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -Public Sub Listen() - ' - On Error GoTo Listen_Err - - ' -100 If m_enmState <> sckClosed And m_enmState <> sckOpen Then -101 Err.Raise sckInvalidOp, "CSocketMaster.Listen", "Invalid operation at current state" - End If - -102 If Not SocketExists Then Exit Sub -103 If Not BindInternal Then Exit Sub - Dim lngResult As Long -104 lngResult = api_listen(m_lngSocketHandle, SOMAXCONN) - -105 If lngResult = SOCKET_ERROR Then - Dim lngErrorCode As Long -106 lngErrorCode = Err.LastDllError -107 Err.Raise lngErrorCode, "CSocketMaster.Listen", GetErrorDescription(lngErrorCode) - Else -108 m_enmState = sckListening -109 Registrar "~SOCK: Estado -> sckListening ", 3 - End If - - ' - Exit Sub -Listen_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Listen.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -Public Sub Accept(requestID As Long) - ' - On Error GoTo Accept_Err - - ' -100 If m_enmState <> sckClosed Then -101 Registrar "~SOCK: Operación inválida en el estado actual", 3 - End If - -102 m_lngSocketHandle = requestID -103 m_enmProtocol = sckTCPProtocol -104 ProcessOptions - -105 If Not modSocketMaster.IsAcceptRegistered(requestID) Then -106 If IsSocketRegistered(requestID) Then -107 m_lngSocketHandle = INVALID_SOCKET -108 m_lngRecvBufferLen = 0 -109 m_lngSendBufferLen = 0 -110 Registrar "~SOCK: Protocolo incorrecto o estado de conexión para la transacción", 3 - Else -111 m_blnAcceptClass = True -112 m_enmState = sckConnected -113 Registrar "~SOCK: Estado -> sckConnected", 3 -114 GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP -115 modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False - Exit Sub - End If - End If - - Dim clsSocket As CSocketMaster -116 Set clsSocket = GetAcceptClass(requestID) -117 modSocketMaster.UnregisterAccept requestID -118 GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP -119 GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost -120 m_enmState = sckConnected -121 Registrar "~SOCK: Estado -> sckConnected", 3 - -122 If clsSocket.BytesReceived > 0 Then -123 clsSocket.GetData m_strRecvBuffer - End If - -124 modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me) - -125 If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer)) -126 If clsSocket.State = sckClosing Then -127 m_enmState = sckClosing -128 Registrar "~SOCK: Estado -> sckClosing", 3 -129 RaiseEvent CloseSck - End If - -130 Set clsSocket = Nothing - ' - Exit Sub -Accept_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Accept.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Retrieves local info from a connected socket. -'If succeeds returns TRUE and loads the arguments. -'If fails returns FALSE and arguments are not loaded. -Private Function GetLocalInfo(ByVal lngSocket As Long, _ - ByRef lngLocalPort As Long, _ - ByRef strLocalIP As String) As Boolean - ' - On Error GoTo GetLocalInfo_Err - ' -100 GetLocalInfo = False - Dim lngResult As Long - Dim udtSockAddr As sockaddr_in -101 lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr)) - -102 If lngResult = SOCKET_ERROR Then -103 lngLocalPort = 0 -104 strLocalIP = "" - Else -105 GetLocalInfo = True -106 lngLocalPort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) -107 strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) - End If - - ' - Exit Function -GetLocalInfo_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalInfo.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Retrieves remote info from a connected socket. -'If succeeds returns TRUE and loads the arguments. -'If fails returns FALSE and arguments are not loaded. -Private Function GetRemoteInfo(ByVal lngSocket As Long, _ - ByRef lngRemotePort As Long, _ - ByRef strRemoteHostIP As String, _ - ByRef strRemoteHost As String) As Boolean - ' - On Error GoTo GetRemoteInfo_Err - ' -100 GetRemoteInfo = False - Dim lngResult As Long - Dim udtSockAddr As sockaddr_in -101 lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr)) - -102 If lngResult = 0 Then -103 GetRemoteInfo = True -104 GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost - Else -105 lngRemotePort = 0 -106 strRemoteHostIP = "" -107 strRemoteHost = "" - End If - - ' - Exit Function -GetRemoteInfo_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetRemoteInfo.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Gets remote info from a sockaddr_in structure. -Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, _ - ByRef lngRemotePort As Long, _ - ByRef strRemoteHostIP As String, _ - ByRef strRemoteHost As String) - 'Dim lngResult As Long - 'Dim udtHostent As HOSTENT - ' - On Error GoTo GetRemoteInfoFromSI_Err - ' -100 lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) -101 strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) - 'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET) - 'If lngResult <> 0 Then - ' api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) - ' strRemoteHost = StringFromPointer(udtHostent.hName) - 'Else -102 strRemoteHost = "" - 'End If - ' - Exit Sub -GetRemoteInfoFromSI_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetRemoteInfoFromSI.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub - -'Returns winsock incoming buffer length from an UDP socket. -Private Function GetBufferLenUDP() As Long - ' - On Error GoTo GetBufferLenUDP_Err - ' - Dim lngResult As Long - Dim lngBuffer As Long -100 lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer) - -101 If lngResult = SOCKET_ERROR Then -102 GetBufferLenUDP = 0 - Else -103 GetBufferLenUDP = lngBuffer - End If - - ' - Exit Function -GetBufferLenUDP_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetBufferLenUDP.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Function - -'Empty winsock incoming buffer from an UDP socket. -Private Sub EmptyBuffer() - ' - On Error GoTo EmptyBuffer_Err - ' - Dim B As Byte -100 api_recv m_lngSocketHandle, B, Len(B), 0& - ' - Exit Sub -EmptyBuffer_Err: - Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.EmptyBuffer.Ref 12/8/2008 : 08:11:18" - Resume Next - ' -End Sub +VERSION 1.0 CLASS +BEGIN + MultiUse = -1 'True + Persistable = 0 'NotPersistable + DataBindingBehavior = 0 'vbNone + DataSourceBehavior = 0 'vbNone + MTSTransactionMode = 0 'NotAnMTSObject +END +Attribute VB_Name = "CSocketMaster" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = True +Attribute VB_PredeclaredId = False +Attribute VB_Exposed = False +'******************************************************************************** +' +'Name.......... CSocketMaster +'File.......... CSocketMaster.cls +'Version....... 1.2 +'Dependencies.. Requires modSocketMaster.bas code module +'Description... Winsock api implementation class +'Author........ Emiliano Scavuzzo +'Date.......... June, 28th 2004 +'Copyright (c) 2004 by Emiliano Scavuzzo +'Rosario, Argentina +' +'Based on CSocket by Oleg Gdalevich +'Subclassing based on WinSubHook2 by Paul Caton +' +'******************************************************************************** +Option Explicit +'============================================================================== +'API FUNCTIONS +'============================================================================== +Private 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 +Private Declare Function api_GlobalLock _ + Lib "kernel32" _ + Alias "GlobalLock" (ByVal hMem As Long) As Long +Private Declare Function api_GlobalUnlock _ + Lib "kernel32" _ + Alias "GlobalUnlock" (ByVal hMem As Long) As Long +Private Declare Function api_htons _ + Lib "ws2_32.dll" _ + Alias "htons" (ByVal hostshort As Integer) As Integer +Private Declare Function api_ntohs _ + Lib "ws2_32.dll" _ + Alias "ntohs" (ByVal netshort As Integer) As Integer +Private 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 +Private Declare Function api_gethostname _ + Lib "ws2_32.dll" _ + Alias "gethostname" (ByVal host_name As String, _ + ByVal namelen As Long) As Long +Private Declare Function api_gethostbyname _ + Lib "ws2_32.dll" _ + Alias "gethostbyname" (ByVal host_name As String) As Long +Private Declare Function api_bind _ + Lib "ws2_32.dll" _ + Alias "bind" (ByVal s As Long, _ + ByRef name As sockaddr_in, _ + ByVal namelen As Long) As Long +Private 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 +Private 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 +Private Declare Function api_inet_addr _ + Lib "ws2_32.dll" _ + Alias "inet_addr" (ByVal cp As String) As Long +Private 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 +Private 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 +Private 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 +Private 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 +Private 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 +Private 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 +Private Declare Function api_WSACancelAsyncRequest _ + Lib "ws2_32.dll" _ + Alias "WSACancelAsyncRequest" (ByVal hAsyncTaskHandle As Long) As Long +Private Declare Function api_listen _ + Lib "ws2_32.dll" _ + Alias "listen" (ByVal s As Long, _ + ByVal backlog As Long) As Long +Private 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 +Private Declare Function api_inet_ntoa _ + Lib "ws2_32.dll" _ + Alias "inet_ntoa" (ByVal inn As Long) As Long +Private Declare Function api_ioctlsocket _ + Lib "ws2_32.dll" _ + Alias "ioctlsocket" (ByVal s As Long, _ + ByVal cmd As Long, _ + ByRef argp As Long) As Long +Private Declare Function api_closesocket _ + Lib "ws2_32.dll" _ + Alias "closesocket" (ByVal s As Long) As Long +'Private 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 +'============================================================================== +'CONSTANTS +'============================================================================== +Public Enum SockState + sckClosed = 0 + sckOpen + sckListening + sckConnectionPending + sckResolvingHost + sckHostResolved + sckConnecting + sckConnected + sckClosing + sckError +End Enum +Private Const SOMAXCONN As Long = 5 +Public Enum ProtocolConstants + sckTCPProtocol = 0 + sckUDPProtocol = 1 +End Enum +Private Const MSG_PEEK As Long = &H2 +'============================================================================== +'EVENTS +'============================================================================== +Public Event CloseSck() +Public Event Connect() +Public Event ConnectionRequest(ByVal requestID As Long) +Public Event DataArrival(ByVal bytesTotal As Long) +Public 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) +Public Event SendComplete() +Public Event SendProgress(ByVal bytesSent As Long, ByVal bytesRemaining As Long) +'============================================================================== +'MEMBER VARIABLES +'============================================================================== +Private m_lngSocketHandle As Long 'socket handle +Private m_enmState As SockState 'socket state +Private m_strTag As String 'tag +Private m_strRemoteHost As String 'remote host +Private m_lngRemotePort As Long 'remote port +Private m_strRemoteHostIP As String 'remote host ip +Private m_lngLocalPort As Long 'local port +Private m_lngLocalPortBind As Long 'temporary local port +Private m_strLocalIP As String 'local IP +Private m_enmProtocol As ProtocolConstants 'protocol used (TCP / UDP) +Private m_lngMemoryPointer As Long 'memory pointer used as buffer when resolving host +Private m_lngMemoryHandle As Long 'buffer memory handle +Private m_lngSendBufferLen As Long 'winsock buffer size for sends +Private m_lngRecvBufferLen As Long 'winsock buffer size for receives +Private m_strSendBuffer As String 'local incoming buffer +Private m_strRecvBuffer As String 'local outgoing buffer +Private m_blnAcceptClass As Boolean 'if True then this is an Accept socket class +Private m_colWaitingResolutions As Collection 'hosts waiting to be resolved by the system + +' **** WARNING WARNING WARNING WARNING ****** +'This sub MUST be the first on the class. DO NOT attempt +'to change it's location or the code will CRASH. +'This sub receives system messages from our WndProc. +Public Sub WndProc(ByVal hWnd As Long, _ + ByVal uMsg As Long, _ + ByVal wParam As Long, _ + ByVal lParam As Long) + ' + On Error GoTo WndProc_Err + + ' + Select Case uMsg + + Case RESOLVE_MESSAGE + PostResolution wParam, HiWord(lParam) + + Case SOCKET_MESSAGE + PostSocket LoWord(lParam), HiWord(lParam) + End Select + + ' + Exit Sub +WndProc_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.WndProc" + Resume Next + ' +End Sub + +Private Sub Class_Initialize() + 'socket's handle default value + ' + On Error GoTo Class_Initialize_Err + ' + m_lngSocketHandle = INVALID_SOCKET + 'initiate resolution collection + Set m_colWaitingResolutions = New Collection + 'initiate processes and winsock service + modSocketMaster.InitiateProcesses + ' + Exit Sub +Class_Initialize_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Class_Initialize" + Resume Next + ' +End Sub + +Private Sub Class_Terminate() + 'clean hostname resolution system + ' + On Error Resume Next + ' + CleanResolutionSystem + + 'destroy socket if it exists + If Not m_blnAcceptClass Then DestroySocket + 'clean processes and finish winsock service + modSocketMaster.FinalizeProcesses + 'clean resolution collection + Set m_colWaitingResolutions = Nothing +End Sub + +'============================================================================== +'PROPERTIES +'============================================================================== +Public Property Get RemotePort() As Long + ' + On Error GoTo RemotePort_Err + ' + RemotePort = m_lngRemotePort + ' + Exit Property +RemotePort_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemotePort" + Resume Next + ' +End Property + +Public Property Let RemotePort(ByVal lngPort As Long) + ' + On Error GoTo RemotePort_Err + + ' + If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then + Err.Raise sckInvalidOp, "CSocketMaster.RemotePort", "Invalid operation at current state" + End If + + If lngPort < 0 Or lngPort > 65535 Then + Err.Raise sckInvalidArg, "CSocketMaster.RemotePort", "The argument passed to a function was not in the correct format or in the specified range." + Else + m_lngRemotePort = lngPort + End If + + ' + Exit Property +RemotePort_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemotePort" + Resume Next + ' +End Property + +Public Property Get RemoteHost() As String + ' + On Error GoTo RemoteHost_Err + ' + RemoteHost = m_strRemoteHost + ' + Exit Property +RemoteHost_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHost" + Resume Next + ' +End Property + +Public Property Let RemoteHost(ByVal strHost As String) + ' + On Error GoTo RemoteHost_Err + + ' + If m_enmProtocol = sckTCPProtocol And m_enmState <> sckClosed Then + Err.Raise sckInvalidOp, "CSocketMaster.RemoteHost", "Invalid operation at current state" + End If + + m_strRemoteHost = strHost + ' + Exit Property +RemoteHost_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHost" + Resume Next + ' +End Property + +Public Property Get RemoteHostIP() As String + ' + On Error GoTo RemoteHostIP_Err + ' + RemoteHostIP = m_strRemoteHostIP + ' + Exit Property +RemoteHostIP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RemoteHostIP" + Resume Next + ' +End Property + +Public Property Get LocalPort() As Long + ' + On Error GoTo LocalPort_Err + + ' + If m_lngLocalPortBind = 0 Then + LocalPort = m_lngLocalPort + Else + LocalPort = m_lngLocalPortBind + End If + + ' + Exit Property +LocalPort_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalPort" + Resume Next + ' +End Property + +Public Property Let LocalPort(ByVal lngPort As Long) + ' + On Error GoTo LocalPort_Err + + ' + If m_enmState <> sckClosed Then + Err.Raise sckInvalidOp, "CSocketMaster.LocalPort", "Invalid operation at current state" + End If + + If lngPort < 0 Or lngPort > 65535 Then + Err.Raise sckInvalidArg, "CSocketMaster.LocalPort", "The argument passed to a function was not in the correct format or in the specified range." + Else + m_lngLocalPort = lngPort + End If + + ' + Exit Property +LocalPort_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalPort" + Resume Next + ' +End Property + +Public Property Get State() As SockState + ' + On Error GoTo State_Err + ' + State = m_enmState + ' + Exit Property +State_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.State" + Resume Next + ' +End Property + +Public Property Get LocalHostName() As String + ' + On Error GoTo LocalHostName_Err + ' + LocalHostName = GetLocalHostName + ' + Exit Property +LocalHostName_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalHostName" + Resume Next + ' +End Property + +Public Property Get LocalIP() As String + ' + On Error GoTo LocalIP_Err + + ' + If m_enmState = sckConnected Then + LocalIP = m_strLocalIP + Else + LocalIP = GetLocalIP + End If + + ' + Exit Property +LocalIP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.LocalIP" + Resume Next + ' +End Property + +Public Property Get BytesReceived() As Long + ' + On Error GoTo BytesReceived_Err + + ' + If m_enmProtocol = sckTCPProtocol Then + BytesReceived = Len(m_strRecvBuffer) + Else + BytesReceived = GetBufferLenUDP + End If + + ' + Exit Property +BytesReceived_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BytesReceived" + Resume Next + ' +End Property + +Public Property Get SocketHandle() As Long + ' + On Error GoTo SocketHandle_Err + ' + SocketHandle = m_lngSocketHandle + ' + Exit Property +SocketHandle_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SocketHandle" + Resume Next + ' +End Property + +Public Property Get Tag() As String + ' + On Error GoTo Tag_Err + ' + Tag = m_strTag + ' + Exit Property +Tag_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Tag" + Resume Next + ' +End Property + +Public Property Let Tag(ByVal strTag As String) + ' + On Error GoTo Tag_Err + ' + m_strTag = strTag + ' + Exit Property +Tag_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Tag" + Resume Next + ' +End Property + +Public Property Get Protocol() As ProtocolConstants + ' + On Error GoTo Protocol_Err + ' + Protocol = m_enmProtocol + ' + Exit Property +Protocol_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Protocol" + Resume Next + ' +End Property + +Public Property Let Protocol(ByVal enmProtocol As ProtocolConstants) + ' + On Error GoTo Protocol_Err + + ' + If m_enmState <> sckClosed Then + Err.Raise sckInvalidOp, "CSocketMaster.Protocol", "Invalid operation at current state" + Else + m_enmProtocol = enmProtocol + End If + + ' + Exit Property +Protocol_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Protocol" + Resume Next + ' +End Property + +'Destroys the socket if it exists and unregisters it +'from control list. +Private Sub DestroySocket() + ' + On Error GoTo DestroySocket_Err + + ' + If Not m_lngSocketHandle = INVALID_SOCKET Then + Dim lngResult As Long + lngResult = api_closesocket(m_lngSocketHandle) + + If lngResult = SOCKET_ERROR Then + m_enmState = sckError + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.DestroySocket", GetErrorDescription(lngErrorCode) + Else + modSocketMaster.UnregisterSocket m_lngSocketHandle + m_lngSocketHandle = INVALID_SOCKET + End If + End If + + ' + Exit Sub +DestroySocket_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.DestroySocket" + Resume Next + ' +End Sub + +Public Sub CloseSck() + ' + On Error GoTo CloseSck_Err + + ' + If m_lngSocketHandle = INVALID_SOCKET Then Exit Sub + m_enmState = sckClosing + CleanResolutionSystem + DestroySocket + m_lngLocalPortBind = 0 + m_strRemoteHostIP = "" + m_strRecvBuffer = "" + m_strSendBuffer = "" + m_lngSendBufferLen = 0 + m_lngRecvBufferLen = 0 + m_enmState = sckClosed + ' + Exit Sub +CloseSck_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.CloseSck" + Resume Next + ' +End Sub + +'Tries to create a socket if there isn't one yet and registers +'it to the control list. +'Returns TRUE if it has success +Private Function SocketExists() As Boolean + ' + On Error GoTo SocketExists_Err + ' + SocketExists = True + Dim lngResult As Long + Dim lngErrorCode As Long + + 'check if there is a socket already + If m_lngSocketHandle = INVALID_SOCKET Then + + 'decide what kind of socket we are creating, TCP or UDP + If m_enmProtocol = sckTCPProtocol Then + lngResult = api_socket(AF_INET, SOCK_STREAM, IPPROTO_TCP) + Else + lngResult = api_socket(AF_INET, SOCK_DGRAM, IPPROTO_UDP) + End If + + If lngResult = INVALID_SOCKET Then + m_enmState = sckError + SocketExists = False + lngErrorCode = Err.LastDllError + Dim blnCancelDisplay As Boolean + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SocketExists", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SocketExists" + Else + m_lngSocketHandle = lngResult + 'set and get some socket options + ProcessOptions + SocketExists = modSocketMaster.RegisterSocket(m_lngSocketHandle, ObjPtr(Me), True) + End If + End If + + ' + Exit Function +SocketExists_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SocketExists" + Resume Next + ' +End Function + +'Tries to connect to RemoteHost if it was passed, or uses +'m_strRemoteHost instead. If it is a hostname tries to +'resolve it first. +Public Sub Connect(Optional RemoteHost As Variant, _ + Optional RemotePort As Variant) + ' + On Error GoTo Connect_Err + + ' + If m_enmState <> sckClosed Then + Err.Raise sckInvalidOp, "CSocketMaster.Connect", "Invalid operation at current state" + End If + + If Not IsMissing(RemoteHost) Then + m_strRemoteHost = CStr(RemoteHost) + End If + + 'for some reason we get a GPF if we try to + 'resolve a null string, so we replace it with + 'an empty string + If m_strRemoteHost = vbNullString Then + m_strRemoteHost = "" + End If + + 'check if RemotePort is a number between 1 and 65535 + If Not IsMissing(RemotePort) Then + If IsNumeric(RemotePort) Then + If CLng(RemotePort) > 65535 Or CLng(RemotePort) < 1 Then + Err.Raise sckInvalidArg, "CSocketMaster.Connect", "The argument passed to a function was not in the correct format or in the specified range." + Else + m_lngRemotePort = CLng(RemotePort) + End If + + Else + Err.Raise sckUnsupported, "CSocketMaster.Connect", "Unsupported variant type." + End If + End If + + 'create a socket if there isn't one yet + If Not SocketExists Then Exit Sub + + 'Here we bind the socket + If Not BindInternal Then Exit Sub + + 'If we are using UDP we just exit silently. + 'Remember UDP is a connectionless protocol. + If m_enmProtocol = sckUDPProtocol Then + m_enmState = sckOpen + Exit Sub + End If + + 'try to get a 32 bits long that is used to identify a host + Dim lngAddress As Long + lngAddress = ResolveIfHostname(m_strRemoteHost) + + 'We've got two options here: + '1) m_strRemoteHost was an IP, so a resolution wasn't + ' necessary, and now lngAddress is a 32 bits long and + ' we proceed to connect. + '2) m_strRemoteHost was a hostname, so a resolution was + ' necessary and it's taking place right now. We leave + ' silently. + If lngAddress <> vbNull Then + '136 registrar "~SOCK: Conectando directamente por IP", 3 + ConnectToIP lngAddress, 0 + End If + + ' + Exit Sub +Connect_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Connect" + Resume Next + ' +End Sub + +'When the system resolves a hostname in asynchronous way we +'call this function to decide what to do with the result. +Private Sub PostResolution(ByVal lngAsynHandle As Long, _ + ByVal lngErrorCode As Long) + 'erase that record from the collection since we won't need it any longer + ' + On Error GoTo PostResolution_Err + ' + m_colWaitingResolutions.Remove "R" & lngAsynHandle + UnregisterResolution lngAsynHandle + + If m_enmState <> sckResolvingHost Then Exit Sub + If lngErrorCode = 0 Then 'if there weren't errors trying to resolve the hostname + m_enmState = sckHostResolved + Dim udtHostent As HOSTENT + Dim lngPtrToIP As Long + Dim arrIpAddress(1 To 4) As Byte + Dim lngRemoteHostAddress As Long + Dim Count As Integer + Dim strIpAddress As String + api_CopyMemory udtHostent, ByVal m_lngMemoryPointer, LenB(udtHostent) + api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 + api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 + api_CopyMemory lngRemoteHostAddress, ByVal lngPtrToIP, 4 + 'free memory, won't need it any longer + FreeMemory + + 'We turn the 32 bits long into a readable string. + 'Note: we don't need this string. I put this here just + 'in case you need it. + For Count = 1 To 4 + strIpAddress = strIpAddress & arrIpAddress(Count) & "." + Next + + strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) + ConnectToIP lngRemoteHostAddress, 0 + Else 'there were errors trying to resolve the hostname + 'free buffer memory + FreeMemory + ConnectToIP vbNull, lngErrorCode + End If + + ' + Exit Sub +PostResolution_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PostResolution" + Resume Next + ' +End Sub + +'This procedure is called by the WindowProc callback function. +'The lngEventID argument is an ID of the network event +'occurred for the socket. The lngErrorCode argument contains +'an error code only if an error was occurred during an +'asynchronous execution. +Private Sub PostSocket(ByVal lngEventID As Long, _ + ByVal lngErrorCode As Long) + ' + On Error GoTo PostSocket_Err + ' + Dim blnCancelDisplay As Boolean + + 'handle any possible error + If lngErrorCode <> 0 Then + m_enmState = sckError + Registrar "~SOCK: Estado -> sckError", 3 + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket" + Exit Sub + End If + + Dim udtSockAddr As sockaddr_in + Dim lngResult As Long + Dim lngBytesReceived As Long + + Select Case lngEventID + + '====================================================================== + Case FD_CONNECT + + 'Arrival of this message means that the connection initiated by the call + 'of the connect Winsock API function was successfully established. + 'registrar "~SOCK:" & "FD_CONNECT " & m_lngSocketHandle, 3 + If m_enmState <> sckConnecting Then + Registrar "~SOCK:" & "Advertencia: Omitiendo FD_CONNECT", 3 + Exit Sub + End If + + 'Get the local parameters + GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP + 'Get the connection local end-point parameters + GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost + m_enmState = sckConnected + Registrar "~SOCK: Estado -> sckConnected", 3 + RaiseEvent Connect + + '====================================================================== + Case FD_WRITE + + 'This message means that the socket in a write-able + 'state, that is, buffer for outgoing data of the transport + 'service is empty and ready to receive data to send through + 'the network. + 'registrar "~SOCK:" & "FD_WRITE " & m_lngSocketHandle, 3 + If m_enmState <> sckConnected Then + Registrar "~SOCK:" & "Advertencia: Omitiendo FD_WRITE", 3 + Exit Sub + End If + + If Len(m_strSendBuffer) > 0 Then + SendBufferedData + End If + + '====================================================================== + Case FD_READ + + 'Some data has arrived for this socket. + 'registrar "~SOCK:" & "FD_READ " & m_lngSocketHandle, 3 + If m_enmProtocol = sckTCPProtocol Then + If m_enmState <> sckConnected Then + Registrar "~SOCK:" & "Advertencia: Omitiendo FD_READ", 3 + Exit Sub + End If + + 'Call the RecvDataToBuffer function that move arrived data + 'from the Winsock buffer to the local one and returns number + 'of bytes received. + lngBytesReceived = RecvDataToBuffer + + If lngBytesReceived > 0 Then + RaiseEvent DataArrival(Len(m_strRecvBuffer)) + End If + + Else 'UDP protocol + + If m_enmState <> sckOpen Then + Registrar "~SOCK:" & "Advertencia: Omitiendo FD_READ", 3 + Exit Sub + End If + + 'If we use UDP we don't remove data from winsock buffer. + 'We just let the user know the amount received so + 'he/she can decide what to do. + lngBytesReceived = GetBufferLenUDP + + If lngBytesReceived > 0 Then + RaiseEvent DataArrival(lngBytesReceived) + End If + + 'Now the buffer is emptied no matter what the user + 'dicided to do with the received data + EmptyBuffer + End If + + '====================================================================== + Case FD_ACCEPT + + 'When the socket is in a listening state, arrival of this message + 'means that a connection request was received. Call the accept + 'Winsock API function in oreder to create a new socket for the + 'requested connection. + 'registrar "~SOCK:" & "FD_ACCEPT " & m_lngSocketHandle, 3 + If m_enmState <> sckListening Then + Registrar "~SOCK:" & "Advertencia: Omitiendo FD_ACCEPT", 3 + Exit Sub + End If + + lngResult = api_accept(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = INVALID_SOCKET Then + lngErrorCode = Err.LastDllError + m_enmState = sckError + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.PostSocket", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.PostSocket" + Else + 'We assign a temporal instance of CSocketMaster to + 'handle this new socket until user accepts (or not) + 'the new connection + modSocketMaster.RegisterAccept lngResult + 'We change remote info before firing ConnectionRequest + 'event so the user can see which host is trying to + 'connect. + Dim lngTempRP As Long + Dim strTempRHIP As String + Dim strTempRH As String + lngTempRP = m_lngRemotePort + strTempRHIP = m_strRemoteHostIP + strTempRH = m_strRemoteHost + GetRemoteInfo lngResult, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost + Registrar "~SOCK: Socket aceptado -> " & lngResult, 3 + RaiseEvent ConnectionRequest(lngResult) + + 'we return original info + If m_enmState = sckListening Then + m_lngRemotePort = lngTempRP + m_strRemoteHostIP = strTempRHIP + m_strRemoteHost = strTempRH + End If + + 'This is very important. If the connection wasn't accepted + 'we must close the socket. + If IsAcceptRegistered(lngResult) Then + api_closesocket lngResult + modSocketMaster.UnregisterSocket lngResult + modSocketMaster.UnregisterAccept lngResult + Registrar "~SOCK: Socket aceptado cerrado -> " & lngResult, 3 + End If + End If + + '====================================================================== + Case FD_CLOSE + + 'This message means that the remote host is closing the conection + 'registrar "~SOCK:" & "FD_CLOSE " & m_lngSocketHandle, 3 + If m_enmState <> sckConnected Then + Registrar "~SOCK: Advertencia: Omitiendo FD_CLOSE", 3 + Exit Sub + End If + + m_enmState = sckClosing + Registrar "~SOCK: Estado -> sckClosing", 3 + RaiseEvent CloseSck + End Select + + ' + Exit Sub +PostSocket_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PostSocket" + Resume Next + ' +End Sub + +'Connect to a given 32 bits long ip +Private Sub ConnectToIP(ByVal lngRemoteHostAddress As Long, _ + ByVal lngErrorCode As Long) + ' + On Error GoTo ConnectToIP_Err + ' + Dim blnCancelDisplay As Boolean + + 'Check and handle errors + If lngErrorCode <> 0 Then + m_enmState = sckError + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" + Exit Sub + End If + + Registrar "~SOCK: Conectando a: " + m_strRemoteHost + " " + m_strRemoteHostIP, 3 + m_enmState = sckConnecting + Registrar "~SOCK: Estado -> sckConnecting", 3 + Dim udtSockAddr As sockaddr_in + Dim lngResult As Long + + 'Build the sockaddr_in structure to pass it to the connect + 'Winsock API function as an address of the remote host. + With udtSockAddr + .sin_addr = lngRemoteHostAddress + .sin_family = AF_INET + .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) + End With + + 'Call the connect Winsock API function in order to establish connection. + lngResult = api_connect(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) + + 'Check and handle errors + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + + If lngErrorCode <> WSAEWOULDBLOCK Then + If lngErrorCode = WSAEADDRNOTAVAIL Then + Err.Raise WSAEADDRNOTAVAIL, "CSocketMaster.ConnectToIP", GetErrorDescription(WSAEADDRNOTAVAIL) + Else + m_enmState = sckError + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ConnectToIP", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ConnectToIP" + End If + End If + End If + + ' + Exit Sub +ConnectToIP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ConnectToIP" + Resume Next + ' +End Sub +'Public Sub Bind(Optional LocalPort As Variant, _ +' Optional LocalIP As Variant) +' ' +' On Error GoTo Bind_Err +' ' +' +'100 If m_enmState <> sckClosed Then +'102 Err.Raise sckInvalidOp, "CSocketMaster.Bind", "Operación invalida en el estado actual" +' End If +' +''104 If BindInternal(LocalPort, LocalIP) Then +' +'104 If BindInternal(LocalPort, LocalIP) Then +'106 m_enmState = sckOpen +' End If +' +' ' +' Exit Sub +' +'Bind_Err: +' +' Controlar_Error Erl, Err.Description, "XMR.CSocketMaster.Bind" +' Resume Next +' ' +'End Sub + +'This function binds a socket to a local port and IP. +'Retunrs TRUE if it has success. +Private Function BindInternal(Optional ByVal varLocalPort As Variant, _ + Optional ByVal varLocalIP As Variant) As Boolean + ' + On Error GoTo BindInternal_Err + + ' + If m_enmState = sckOpen Then + BindInternal = True + Exit Function + End If + + Dim lngLocalPortInternal As Long + Dim strLocalHostInternal As String + Dim strIP As String + Dim lngAddressInternal As Long + Dim lngResult As Long + Dim lngErrorCode As Long + BindInternal = False + + 'Check if varLocalPort is a number between 0 and 65535 + If Not IsMissing(varLocalPort) Then + If IsNumeric(varLocalPort) Then + If varLocalPort < 0 Or varLocalPort > 65535 Then + BindInternal = False + Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "El argumento pasado a la función no era correcto o no era en el rango especificado" + Else + lngLocalPortInternal = CLng(varLocalPort) + End If + + Else + BindInternal = False + Err.Raise sckUnsupported, "CSocketMaster.BindInternal", "Tipos variantes no soportados" + End If + + Else + lngLocalPortInternal = m_lngLocalPort + End If + + If IsMissing(varLocalIP) Then varLocalIP = "000.000.000.000" + strLocalHostInternal = CStr(varLocalIP) + 'registrar "~SOCK:" & "@Wine => varLocalIP: " & CStr(varLocalIP) & " | strLocalHostInternal: " & CStr(strLocalHostInternal) & " | strIP: " & strIP, 3 + 'get a 32 bits long IP + lngAddressInternal = ResolveIfHostnameSync(strLocalHostInternal, strIP, lngResult) + + 'registrar "~SOCK:" & "@Wine => lngResult: " & lngResult, 3 + If lngResult <> 0 Then Err.Raise sckInvalidArg, "CSocketMaster.BindInternal", "Argumento inválido" + + 'create a socket if there isn't one yet + If Not SocketExists Then Exit Function + Dim udtSockAddr As sockaddr_in + + With udtSockAddr + .sin_addr = lngAddressInternal + .sin_family = AF_INET + .sin_port = api_htons(modSocketMaster.UnsignedToInteger(lngLocalPortInternal)) + End With + + 'bind the socket + lngResult = api_bind(m_lngSocketHandle, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) + Else + + If lngLocalPortInternal <> 0 Then + '160 registrar "~SOCK: Servidor enlazado -> " & strLocalHostInternal & " | Puerto -> " & lngLocalPortInternal, 3 + m_lngLocalPort = lngLocalPortInternal + Else + lngResult = GetLocalPort(m_lngSocketHandle) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.BindInternal", GetErrorDescription(lngErrorCode) + Else + 'registrar "~SOCK: Servidor enlazado -> " & strLocalHostInternal & " | Puerto -> " & lngLocalPortInternal, 3 + m_lngLocalPortBind = lngResult + End If + End If + + BindInternal = True + End If + + ' + Exit Function +BindInternal_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BindInternal" + Resume Next + ' +End Function + +'Allocate some memory for HOSTEN structure and returns +'a pointer to this buffer if no error occurs. +'Returns 0 if it fails. +Private Function AllocateMemory() As Long + ' + On Error GoTo AllocateMemory_Err + ' + m_lngMemoryHandle = api_GlobalAlloc(GMEM_FIXED, MAXGETHOSTSTRUCT) + + If m_lngMemoryHandle <> 0 Then + m_lngMemoryPointer = api_GlobalLock(m_lngMemoryHandle) + + If m_lngMemoryPointer <> 0 Then + api_GlobalUnlock (m_lngMemoryHandle) + AllocateMemory = m_lngMemoryPointer + Else + api_GlobalFree (m_lngMemoryHandle) + AllocateMemory = m_lngMemoryPointer '0 + End If + + Else + AllocateMemory = m_lngMemoryHandle '0 + End If + + ' + Exit Function +AllocateMemory_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.AllocateMemory" + Resume Next + ' +End Function + +'Free memory allocated by AllocateMemory +Private Sub FreeMemory() + ' + On Error GoTo FreeMemory_Err + + ' + If m_lngMemoryHandle <> 0 Then + m_lngMemoryPointer = 0 + api_GlobalFree m_lngMemoryHandle + m_lngMemoryHandle = 0 + 'registrar "~SOCK: Liberada memoria de resolución", 3 + End If + + ' + Exit Sub +FreeMemory_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.FreeMemory" + Resume Next + ' +End Sub + +Private Function GetLocalHostName() As String + ' + On Error GoTo GetLocalHostName_Err + ' + Dim strHostNameBuf As String * LOCAL_HOST_BUFF + Dim lngResult As Long + lngResult = api_gethostname(strHostNameBuf, LOCAL_HOST_BUFF) + + If lngResult = SOCKET_ERROR Then + GetLocalHostName = vbNullString + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.GetLocalHostName", GetErrorDescription(lngErrorCode) + Else + GetLocalHostName = Left$(strHostNameBuf, InStr(1, strHostNameBuf, vbNullChar) - 1) + End If + + ' + Exit Function +GetLocalHostName_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalHostName" + Resume Next + ' +End Function + +'Get local IP when the socket isn't connected yet +Private Function GetLocalIP() As String + ' + On Error GoTo GetLocalIP_Err + ' + Dim lngResult As Long + Dim lngPtrToIP As Long + Dim strLocalHost As String + Dim arrIpAddress(1 To 4) As Byte + Dim Count As Integer + Dim udtHostent As HOSTENT + Dim strIpAddress As String + strLocalHost = GetLocalHostName + lngResult = api_gethostbyname(strLocalHost) + + If lngResult = 0 Then + GetLocalIP = vbNullString + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.GetLocalIP", GetErrorDescription(lngErrorCode) + Else + api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) + api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 + api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 + + For Count = 1 To 4 + strIpAddress = strIpAddress & arrIpAddress(Count) & "." + Next + + strIpAddress = Left$(strIpAddress, Len(strIpAddress) - 1) + GetLocalIP = strIpAddress + End If + + ' + Exit Function +GetLocalIP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalIP" + Resume Next + ' +End Function + +'If Host is an IP doesn't resolve anything and returns a +'a 32 bits long IP. +'If Host isn't an IP then returns vbNull, tries to resolve it +'in asynchronous way. +Private Function ResolveIfHostname(ByVal Host As String) As Long + ' + On Error GoTo ResolveIfHostname_Err + ' + Dim lngAddress As Long + lngAddress = api_inet_addr(Host) + + If lngAddress = INADDR_NONE Then 'if Host isn't an IP + ResolveIfHostname = vbNull + m_enmState = sckResolvingHost + + If AllocateMemory Then + Dim lngAsynHandle As Long + lngAsynHandle = modSocketMaster.ResolveHost(Host, m_lngMemoryPointer, ObjPtr(Me)) + + If lngAsynHandle = 0 Then + FreeMemory + m_enmState = sckError + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Dim blnCancelDisplay As Boolean + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.ResolveIfHostname", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.ResolveIfHostname" + Else + m_colWaitingResolutions.Add lngAsynHandle, "R" & lngAsynHandle + Registrar "~SOCK: Resolviendo servidor -> " & Host & " - con control ASYNC: " & lngAsynHandle, 3 + End If + + Else + m_enmState = sckError + Registrar "~SOCK: Error asignando memoria", 3 + Err.Raise sckOutOfMemory, "CSocketMaster.ResolveIfHostname", "Sin memoria" + End If + + Else 'if Host is an IP doen't need to resolve anything + ResolveIfHostname = lngAddress + End If + + ' + Exit Function +ResolveIfHostname_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ResolveIfHostname" + Resume Next + ' +End Function + +'Resolves a host (if necessary) in synchronous way +'If succeeds returns a 32 bits long IP, +'strHostIP = readable IP string and lngErrorCode = 0 +'If fails returns vbNull, +'strHostIP = vbNullString and lngErrorCode <> 0 +Private Function ResolveIfHostnameSync(ByVal Host As String, _ + ByRef strHostIP As String, _ + ByRef lngErrorCode As Long) As Long + ' + On Error GoTo ResolveIfHostnameSync_Err + ' + Dim lngPtrToHOSTENT As Long + Dim udtHostent As HOSTENT + Dim lngAddress As Long + Dim lngPtrToIP As Long + Dim arrIpAddress(1 To 4) As Byte + Dim Count As Integer + lngAddress = api_inet_addr(Host) + + If lngAddress = INADDR_NONE Then 'if Host isn't an IP + lngPtrToHOSTENT = api_gethostbyname(Host) + + If lngPtrToHOSTENT = 0 Then + lngErrorCode = Err.LastDllError + strHostIP = vbNullString + ResolveIfHostnameSync = vbNull + Else + api_CopyMemory udtHostent, ByVal lngPtrToHOSTENT, LenB(udtHostent) + api_CopyMemory lngPtrToIP, ByVal udtHostent.hAddrList, 4 + api_CopyMemory arrIpAddress(1), ByVal lngPtrToIP, 4 + api_CopyMemory lngAddress, ByVal lngPtrToIP, 4 + + For Count = 1 To 4 + strHostIP = strHostIP & arrIpAddress(Count) & "." + Next + + strHostIP = Left$(strHostIP, Len(strHostIP) - 1) + lngErrorCode = 0 + ResolveIfHostnameSync = lngAddress + End If + + Else 'if Host is an IP doen't need to resolve anything + lngErrorCode = 0 + strHostIP = Host + ResolveIfHostnameSync = lngAddress + End If + + ' + Exit Function +ResolveIfHostnameSync_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ResolveIfHostnameSync" + Resume Next + ' +End Function + +'Returns local port from a connected or bound socket. +'Returns SOCKET_ERROR if fails. +Private Function GetLocalPort(ByVal lngSocket As Long) As Long + ' + On Error GoTo GetLocalPort_Err + ' + Dim udtSockAddr As sockaddr_in + Dim lngResult As Long + lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = SOCKET_ERROR Then + GetLocalPort = SOCKET_ERROR + Else + GetLocalPort = modSocketMaster.IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) + End If + + ' + Exit Function +GetLocalPort_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalPort" + Resume Next + ' +End Function + +Public Sub SendData(data As Variant) + ' + On Error GoTo SendData_Err + ' + Dim arrData() As Byte 'We store the data here before send it + + If m_enmProtocol = sckTCPProtocol Then + If m_enmState <> sckConnected Then + Err.Raise sckBadState, "CSocketMaster.SendData", "Wrong protocol or connection state for the requested transaction or request" + Exit Sub + End If + + Else 'If we use UDP we create a socket if there isn't one yet + + If Not SocketExists Then Exit Sub + If Not BindInternal Then Exit Sub + m_enmState = sckOpen + End If + + 'We need to convert data variant into a byte array + Select Case varType(data) + + Case vbString + Dim strdata As String + strdata = CStr(data) + + If Len(strdata) = 0 Then Exit Sub + ReDim arrData(Len(strdata) - 1) + arrData() = StrConv(strdata, vbFromUnicode) + + Case vbArray + vbByte + Dim strArray As String + strArray = StrConv(data, vbUnicode) + + If Len(strArray) = 0 Then Exit Sub + arrData() = StrConv(strArray, vbFromUnicode) + + Case vbBoolean + Dim blnData As Boolean + blnData = CBool(data) + ReDim arrData(LenB(blnData) - 1) + api_CopyMemory arrData(0), blnData, LenB(blnData) + + Case vbByte + Dim bytData As Byte + bytData = CByte(data) + ReDim arrData(LenB(bytData) - 1) + api_CopyMemory arrData(0), bytData, LenB(bytData) + + Case vbCurrency + Dim curData As Currency + curData = CCur(data) + ReDim arrData(LenB(curData) - 1) + api_CopyMemory arrData(0), curData, LenB(curData) + + Case vbDate + Dim datData As Date + datData = CDate(data) + ReDim arrData(LenB(datData) - 1) + api_CopyMemory arrData(0), datData, LenB(datData) + + Case vbDouble + Dim dblData As Double + dblData = CDbl(data) + ReDim arrData(LenB(dblData) - 1) + api_CopyMemory arrData(0), dblData, LenB(dblData) + + Case vbInteger + Dim intData As Integer + intData = CInt(data) + ReDim arrData(LenB(intData) - 1) + api_CopyMemory arrData(0), intData, LenB(intData) + + Case vbLong + Dim lngData As Long + lngData = CLng(data) + ReDim arrData(LenB(lngData) - 1) + api_CopyMemory arrData(0), lngData, LenB(lngData) + + Case vbSingle + Dim sngData As Single + sngData = CSng(data) + ReDim arrData(LenB(sngData) - 1) + api_CopyMemory arrData(0), sngData, LenB(sngData) + + Case Else + Err.Raise sckUnsupported, "CSocketMaster.SendData", "Unsupported variant type." + End Select + + 'if there's already something in the buffer that means we are + 'already sending data, so we put the new data in the buffer + 'and exit silently + If Len(m_strSendBuffer) > 0 Then + m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) + Exit Sub + Else + m_strSendBuffer = m_strSendBuffer + StrConv(arrData(), vbUnicode) + End If + + 'send the data + SendBufferedData + ' + Exit Sub +SendData_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendData" + Resume Next + ' +End Sub + +'Check which protocol we are using to decide which +'function should handle the data sending. +Private Sub SendBufferedData() + ' + On Error GoTo SendBufferedData_Err + + ' + If m_enmProtocol = sckTCPProtocol Then + SendBufferedDataTCP + Else + SendBufferedDataUDP + End If + + ' + Exit Sub +SendBufferedData_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedData" + Resume Next + ' +End Sub + +'Send buffered data if we are using UDP protocol. +Private Sub SendBufferedDataUDP() + ' + On Error GoTo SendBufferedDataUDP_Err + ' + Dim lngAddress As Long + Dim udtSockAddr As sockaddr_in + Dim arrData() As Byte + Dim lngBufferLength As Long + Dim lngResult As Long + Dim lngErrorCode As Long + Dim strTemp As String + lngAddress = ResolveIfHostnameSync(m_strRemoteHost, strTemp, lngErrorCode) + + If lngErrorCode <> 0 Then + m_strSendBuffer = "" + + If lngErrorCode = WSAEAFNOSUPPORT Then + Err.Raise lngErrorCode, "CSocketMaster.SendBufferedDataUDP", GetErrorDescription(lngErrorCode) + Else + Err.Raise sckInvalidArg, "CSocketMaster.SendBufferedDataUDP", "Invalid argument" + End If + End If + + With udtSockAddr + .sin_addr = lngAddress + .sin_family = AF_INET + .sin_port = api_htons(modSocketMaster.UnsignedToInteger(m_lngRemotePort)) + End With + + lngBufferLength = Len(m_strSendBuffer) + arrData() = StrConv(m_strSendBuffer, vbFromUnicode) + m_strSendBuffer = "" + lngResult = api_sendto(m_lngSocketHandle, arrData(0), lngBufferLength, 0&, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + m_enmState = sckError + Dim blnCancelDisplay As Boolean + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedDataUDP", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedDataUDP" + End If + + ' + Exit Sub +SendBufferedDataUDP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedDataUDP" + Resume Next + ' +End Sub + +'Send buffered data if we are using TCP protocol. +Private Sub SendBufferedDataTCP() + ' + On Error GoTo SendBufferedDataTCP_Err + ' + Dim arrData() As Byte + Dim lngBufferLength As Long + Dim lngResult As Long + Dim lngTotalSent As Long + + Do Until lngResult = SOCKET_ERROR Or Len(m_strSendBuffer) = 0 + lngBufferLength = Len(m_strSendBuffer) + + If lngBufferLength > m_lngSendBufferLen Then + lngBufferLength = m_lngSendBufferLen + arrData() = StrConv(Left$(m_strSendBuffer, m_lngSendBufferLen), vbFromUnicode) + Else + arrData() = StrConv(m_strSendBuffer, vbFromUnicode) + End If + + lngResult = api_send(m_lngSocketHandle, arrData(0), lngBufferLength, 0&) + + If lngResult = SOCKET_ERROR Then + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + + If lngErrorCode = WSAEWOULDBLOCK Then + Registrar "~SOCK:" & "Advertencia: Buffer de envío lleno, esperando...", 3 + + If lngTotalSent > 0 Then RaiseEvent SendProgress(lngTotalSent, Len(m_strSendBuffer)) + Else + m_enmState = sckError + Dim blnCancelDisplay As Boolean + blnCancelDisplay = True + RaiseEvent error(lngErrorCode, GetErrorDescription(lngErrorCode), 0, "CSocketMaster.SendBufferedData", "", 0, blnCancelDisplay) + + If blnCancelDisplay = False Then MsgBox GetErrorDescription(lngErrorCode), vbOKOnly, "CSocketMaster.SendBufferedData" + End If + + Else + Registrar "~SOCK: Bytes enviados => " & lngResult, 3 + lngTotalSent = lngTotalSent + lngResult + + If Len(m_strSendBuffer) > lngResult Then + m_strSendBuffer = Mid$(m_strSendBuffer, lngResult + 1) + Else + Registrar "~SOCK: Envío terminado", 3 + m_strSendBuffer = "" + Dim lngTemp As Long + lngTemp = lngTotalSent + lngTotalSent = 0 + RaiseEvent SendProgress(lngTemp, 0) + RaiseEvent SendComplete + End If + End If + + Loop + + ' + Exit Sub +SendBufferedDataTCP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.SendBufferedDataTCP" + Resume Next + ' +End Sub + +'This function retrieves data from the Winsock buffer +'into the class local buffer. The function returns number +'of bytes retrieved (received). +Private Function RecvDataToBuffer() As Long + ' + On Error GoTo RecvDataToBuffer_Err + ' + Dim arrBuffer() As Byte + Dim lngBytesReceived As Long + Dim strBuffTemporal As String + ReDim arrBuffer(m_lngRecvBufferLen - 1) + lngBytesReceived = api_recv(m_lngSocketHandle, arrBuffer(0), m_lngRecvBufferLen, 0&) + + If lngBytesReceived = SOCKET_ERROR Then + m_enmState = sckError + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.RecvDataToBuffer", GetErrorDescription(lngErrorCode) + ElseIf lngBytesReceived > 0 Then + strBuffTemporal = StrConv(arrBuffer(), vbUnicode) + m_strRecvBuffer = m_strRecvBuffer & Left$(strBuffTemporal, lngBytesReceived) + RecvDataToBuffer = lngBytesReceived + End If + + ' + Exit Function +RecvDataToBuffer_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RecvDataToBuffer" + Resume Next + ' +End Function + +'Retrieves some socket options. +'If it is an UDP socket also sets SO_BROADCAST option. +Private Sub ProcessOptions() + ' + On Error GoTo ProcessOptions_Err + ' + Dim lngResult As Long + Dim lngBuffer As Long + Dim lngErrorCode As Long + + If m_enmProtocol = sckTCPProtocol Then + lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_RCVBUF, lngBuffer, LenB(lngBuffer)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) + Else + m_lngRecvBufferLen = lngBuffer + End If + + lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_SNDBUF, lngBuffer, LenB(lngBuffer)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) + Else + m_lngSendBufferLen = lngBuffer + End If + + Else + lngBuffer = 1 + lngResult = api_setsockopt(m_lngSocketHandle, SOL_SOCKET, SO_BROADCAST, lngBuffer, LenB(lngBuffer)) + lngResult = api_getsockopt(m_lngSocketHandle, SOL_SOCKET, SO_MAX_MSG_SIZE, lngBuffer, LenB(lngBuffer)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.ProcessOptions", GetErrorDescription(lngErrorCode) + Else + m_lngRecvBufferLen = lngBuffer + m_lngSendBufferLen = lngBuffer + End If + End If + + 'registrar "~SOCK:" & "Tamaño de buffer para envíar: " & m_lngRecvBufferLen, 3 + 'registrar "~SOCK:" & "Tamaño de buffer para recibir: " & m_lngSendBufferLen, 3 + ' + Exit Sub +ProcessOptions_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.ProcessOptions" + Resume Next + ' +End Sub + +Public Sub GetData(ByRef data As Variant, _ + Optional varType As Variant, _ + Optional maxLen As Variant) + ' + On Error GoTo GetData_Err + + ' + If m_enmProtocol = sckTCPProtocol Then + If m_enmState <> sckConnected And Not m_blnAcceptClass Then + Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" + Exit Sub + End If + + Else + + If m_enmState <> sckOpen Then + Err.Raise sckBadState, "CSocketMaster.GetData", "Wrong protocol or connection state for the requested transaction or request" + Exit Sub + End If + + If GetBufferLenUDP = 0 Then Exit Sub + End If + + If Not IsMissing(maxLen) Then + If IsNumeric(maxLen) Then + If CLng(maxLen) < 0 Then + Err.Raise sckInvalidArg, "CSocketMaster.GetData", "The argument passed to a function was not in the correct format or in the specified range." + End If + + Else + + If m_enmProtocol = sckTCPProtocol Then + maxLen = Len(m_strRecvBuffer) + Else + maxLen = GetBufferLenUDP + End If + End If + End If + + Dim lngBytesRecibidos As Long + lngBytesRecibidos = RecvData(data, False, varType, maxLen) + Registrar "~SOCK: Bytes Obtenidos del buffer: " & lngBytesRecibidos, 3 + ' + Exit Sub +GetData_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetData" + Resume Next + ' +End Sub + +Public Sub PeekData(ByRef data As Variant, _ + Optional varType As Variant, _ + Optional maxLen As Variant) + ' + On Error GoTo PeekData_Err + + ' + If m_enmProtocol = sckTCPProtocol Then + If m_enmState <> sckConnected Then + Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" + Exit Sub + End If + + Else + + If m_enmState <> sckOpen Then + Err.Raise sckBadState, "CSocketMaster.PeekData", "Wrong protocol or connection state for the requested transaction or request" + Exit Sub + End If + + If GetBufferLenUDP = 0 Then Exit Sub + End If + + If Not IsMissing(maxLen) Then + If IsNumeric(maxLen) Then + If CLng(maxLen) < 0 Then + Err.Raise sckInvalidArg, "CSocketMaster.PeekData", "The argument passed to a function was not in the correct format or in the specified range." + End If + + Else + + If m_enmProtocol = sckTCPProtocol Then + maxLen = Len(m_strRecvBuffer) + Else + maxLen = GetBufferLenUDP + End If + End If + End If + + Dim lngBytesRecibidos As Long + lngBytesRecibidos = RecvData(data, True, varType, maxLen) + Registrar "~SOCK: Bytes obtenidos del buffer: " & lngBytesRecibidos, 3 + ' + Exit Sub +PeekData_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.PeekData" + Resume Next + ' +End Sub + +'This function is to retrieve data from the buffer. If we are using TCP +'then the data is retrieved from a local buffer (m_strRecvBuffer). If we +'are using UDP the data is retrieved from winsock buffer. +'It can be called by two public methods of the class - GetData and PeekData. +'Behavior of the function is defined by the blnPeek argument. If a value of +'that argument is TRUE, the function returns number of bytes in the +'buffer, and copy data from that buffer into the data argument. +'If a value of the blnPeek is FALSE, then this function returns number of +'bytes received, and move data from the buffer into the data +'argument. MOVE means that data will be removed from the buffer. +Private Function RecvData(ByRef data As Variant, _ + ByVal blnPeek As Boolean, _ + Optional varClass As Variant, _ + Optional maxLen As Variant) As Long + ' + On Error GoTo RecvData_Err + ' + Dim blnMaxLenMiss As Boolean + Dim blnClassMiss As Boolean + 'Dim strRecvData As String + Dim lngBufferLen As Long + Dim arrBuffer() As Byte + Dim lngErrorCode As Long + + If m_enmProtocol = sckTCPProtocol Then + lngBufferLen = Len(m_strRecvBuffer) + Else + lngBufferLen = GetBufferLenUDP + End If + + blnMaxLenMiss = IsMissing(maxLen) + blnClassMiss = IsMissing(varClass) + + 'Select type of data + If varType(data) = vbEmpty Then + If blnClassMiss Then varClass = vbArray + vbByte + Else + varClass = varType(data) + End If + + 'As stated on Winsock control documentation if the + 'data type passed is string or byte array type then + 'we must take into account maxLen argument. + 'If it is another type maxLen is ignored. + If varClass = vbString Or varClass = vbArray + vbByte Then + If blnMaxLenMiss Then 'if maxLen argument is missing + If lngBufferLen = 0 Then + RecvData = 0 + arrBuffer = StrConv("", vbFromUnicode) + data = arrBuffer + Exit Function + Else + RecvData = lngBufferLen + BuildArray lngBufferLen, blnPeek, lngErrorCode, arrBuffer + End If + + Else 'if maxLen argument is not missing + + If maxLen = 0 Or lngBufferLen = 0 Then + RecvData = 0 + arrBuffer = StrConv("", vbFromUnicode) + data = arrBuffer + + If m_enmProtocol = sckUDPProtocol Then + EmptyBuffer + Err.Raise WSAEMSGSIZE, "CSocketMaster.RecvData", GetErrorDescription(WSAEMSGSIZE) + End If + + Exit Function + ElseIf maxLen > lngBufferLen Then + RecvData = lngBufferLen + BuildArray lngBufferLen, blnPeek, lngErrorCode, arrBuffer + Else + RecvData = CLng(maxLen) + BuildArray CLng(maxLen), blnPeek, lngErrorCode, arrBuffer + End If + End If + End If + + Select Case varClass + + Case vbString + Dim strdata As String + strdata = StrConv(arrBuffer(), vbUnicode) + data = strdata + + Case vbArray + vbByte + data = arrBuffer + + Case vbBoolean + Dim blnData As Boolean + + If LenB(blnData) > lngBufferLen Then Exit Function + BuildArray LenB(blnData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(blnData) + api_CopyMemory blnData, arrBuffer(0), LenB(blnData) + data = blnData + + Case vbByte + Dim bytData As Byte + + If LenB(bytData) > lngBufferLen Then Exit Function + BuildArray LenB(bytData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(bytData) + api_CopyMemory bytData, arrBuffer(0), LenB(bytData) + data = bytData + + Case vbCurrency + Dim curData As Currency + + If LenB(curData) > lngBufferLen Then Exit Function + BuildArray LenB(curData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(curData) + api_CopyMemory curData, arrBuffer(0), LenB(curData) + data = curData + + Case vbDate + Dim datData As Date + + If LenB(datData) > lngBufferLen Then Exit Function + BuildArray LenB(datData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(datData) + api_CopyMemory datData, arrBuffer(0), LenB(datData) + data = datData + + Case vbDouble + Dim dblData As Double + + If LenB(dblData) > lngBufferLen Then Exit Function + BuildArray LenB(dblData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(dblData) + api_CopyMemory dblData, arrBuffer(0), LenB(dblData) + data = dblData + + Case vbInteger + Dim intData As Integer + + If LenB(intData) > lngBufferLen Then Exit Function + BuildArray LenB(intData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(intData) + api_CopyMemory intData, arrBuffer(0), LenB(intData) + data = intData + + Case vbLong + Dim lngData As Long + + If LenB(lngData) > lngBufferLen Then Exit Function + BuildArray LenB(lngData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(lngData) + api_CopyMemory lngData, arrBuffer(0), LenB(lngData) + data = lngData + + Case vbSingle + Dim sngData As Single + + If LenB(sngData) > lngBufferLen Then Exit Function + BuildArray LenB(sngData), blnPeek, lngErrorCode, arrBuffer + RecvData = LenB(sngData) + api_CopyMemory sngData, arrBuffer(0), LenB(sngData) + data = sngData + + Case Else + Err.Raise sckUnsupported, "CSocketMaster.RecvData", "Unsupported variant type." + End Select + + 'if BuildArray returns an error is handled here + If lngErrorCode <> 0 Then + Err.Raise lngErrorCode, "CSocketMaster.RecvData", GetErrorDescription(lngErrorCode) + End If + + ' + Exit Function +RecvData_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.RecvData" + Resume Next + ' +End Function + +'Returns a byte array of Size bytes filled with incoming buffer data. +Private Sub BuildArray(ByVal Size As Long, _ + ByVal blnPeek As Boolean, _ + ByRef lngErrorCode As Long, _ + ByRef bytArray() As Byte) + ' + On Error GoTo BuildArray_Err + ' + Dim strdata As String + + If m_enmProtocol = sckTCPProtocol Then + strdata = Left$(m_strRecvBuffer, CLng(Size)) + + If strdata <> vbNullString Then bytArray = StrConv(strdata, vbFromUnicode) + If Not blnPeek Then m_strRecvBuffer = Mid$(m_strRecvBuffer, Size + 1) + Else 'UDP protocol + Dim arrBuffer() As Byte + Dim lngResult As Long + Dim udtSockAddr As sockaddr_in + Dim lngFlags As Long + + If blnPeek Then lngFlags = MSG_PEEK + ReDim arrBuffer(Size - 1) + lngResult = api_recvfrom(m_lngSocketHandle, arrBuffer(0), Size, lngFlags, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = SOCKET_ERROR Then + lngErrorCode = Err.LastDllError + End If + + bytArray = arrBuffer + GetRemoteInfoFromSI udtSockAddr, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost + End If + + ' + Exit Sub +BuildArray_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.BuildArray" + Resume Next + ' +End Sub + +'Clean resolution system that is in charge of +'asynchronous hostname resolutions. +Private Sub CleanResolutionSystem() + ' + On Error GoTo CleanResolutionSystem_Err + ' + Dim varAsynHandle As Variant + Dim lngResult As Long + + 'cancel async resolutions if they're still running + For Each varAsynHandle In m_colWaitingResolutions + lngResult = api_WSACancelAsyncRequest(varAsynHandle) + + If lngResult = 0 Then + modSocketMaster.UnregisterResolution varAsynHandle + Set m_colWaitingResolutions = Nothing + Set m_colWaitingResolutions = New Collection + 'free memory buffer where resolution results are stored + FreeMemory + End If + + Next + + ' + Exit Sub +CleanResolutionSystem_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.CleanResolutionSystem" + Resume Next + ' +End Sub + +Public Sub Listen() + ' + On Error GoTo Listen_Err + + ' + If m_enmState <> sckClosed And m_enmState <> sckOpen Then + Err.Raise sckInvalidOp, "CSocketMaster.Listen", "Invalid operation at current state" + End If + + If Not SocketExists Then Exit Sub + If Not BindInternal Then Exit Sub + Dim lngResult As Long + lngResult = api_listen(m_lngSocketHandle, SOMAXCONN) + + If lngResult = SOCKET_ERROR Then + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "CSocketMaster.Listen", GetErrorDescription(lngErrorCode) + Else + m_enmState = sckListening + Registrar "~SOCK: Estado -> sckListening ", 3 + End If + + ' + Exit Sub +Listen_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Listen" + Resume Next + ' +End Sub + +Public Sub Accept(requestID As Long) + ' + On Error GoTo Accept_Err + + ' + If m_enmState <> sckClosed Then + Registrar "~SOCK: Operación inválida en el estado actual", 3 + End If + + m_lngSocketHandle = requestID + m_enmProtocol = sckTCPProtocol + ProcessOptions + + If Not modSocketMaster.IsAcceptRegistered(requestID) Then + If IsSocketRegistered(requestID) Then + m_lngSocketHandle = INVALID_SOCKET + m_lngRecvBufferLen = 0 + m_lngSendBufferLen = 0 + Registrar "~SOCK: Protocolo incorrecto o estado de conexión para la transacción", 3 + Else + m_blnAcceptClass = True + m_enmState = sckConnected + Registrar "~SOCK: Estado -> sckConnected", 3 + GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP + modSocketMaster.RegisterSocket m_lngSocketHandle, ObjPtr(Me), False + Exit Sub + End If + End If + + Dim clsSocket As CSocketMaster + Set clsSocket = GetAcceptClass(requestID) + modSocketMaster.UnregisterAccept requestID + GetLocalInfo m_lngSocketHandle, m_lngLocalPortBind, m_strLocalIP + GetRemoteInfo m_lngSocketHandle, m_lngRemotePort, m_strRemoteHostIP, m_strRemoteHost + m_enmState = sckConnected + Registrar "~SOCK: Estado -> sckConnected", 3 + + If clsSocket.BytesReceived > 0 Then + clsSocket.GetData m_strRecvBuffer + End If + + modSocketMaster.Subclass_ChangeOwner requestID, ObjPtr(Me) + + If Len(m_strRecvBuffer) > 0 Then RaiseEvent DataArrival(Len(m_strRecvBuffer)) + If clsSocket.State = sckClosing Then + m_enmState = sckClosing + Registrar "~SOCK: Estado -> sckClosing", 3 + RaiseEvent CloseSck + End If + + Set clsSocket = Nothing + ' + Exit Sub +Accept_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.Accept" + Resume Next + ' +End Sub + +'Retrieves local info from a connected socket. +'If succeeds returns TRUE and loads the arguments. +'If fails returns FALSE and arguments are not loaded. +Private Function GetLocalInfo(ByVal lngSocket As Long, _ + ByRef lngLocalPort As Long, _ + ByRef strLocalIP As String) As Boolean + ' + On Error GoTo GetLocalInfo_Err + ' + GetLocalInfo = False + Dim lngResult As Long + Dim udtSockAddr As sockaddr_in + lngResult = api_getsockname(lngSocket, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = SOCKET_ERROR Then + lngLocalPort = 0 + strLocalIP = "" + Else + GetLocalInfo = True + lngLocalPort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) + strLocalIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) + End If + + ' + Exit Function +GetLocalInfo_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetLocalInfo" + Resume Next + ' +End Function + +'Retrieves remote info from a connected socket. +'If succeeds returns TRUE and loads the arguments. +'If fails returns FALSE and arguments are not loaded. +Private Function GetRemoteInfo(ByVal lngSocket As Long, _ + ByRef lngRemotePort As Long, _ + ByRef strRemoteHostIP As String, _ + ByRef strRemoteHost As String) As Boolean + ' + On Error GoTo GetRemoteInfo_Err + ' + GetRemoteInfo = False + Dim lngResult As Long + Dim udtSockAddr As sockaddr_in + lngResult = api_getpeername(lngSocket, udtSockAddr, LenB(udtSockAddr)) + + If lngResult = 0 Then + GetRemoteInfo = True + GetRemoteInfoFromSI udtSockAddr, lngRemotePort, strRemoteHostIP, strRemoteHost + Else + lngRemotePort = 0 + strRemoteHostIP = "" + strRemoteHost = "" + End If + + ' + Exit Function +GetRemoteInfo_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetRemoteInfo" + Resume Next + ' +End Function + +'Gets remote info from a sockaddr_in structure. +Private Sub GetRemoteInfoFromSI(ByRef udtSockAddr As sockaddr_in, _ + ByRef lngRemotePort As Long, _ + ByRef strRemoteHostIP As String, _ + ByRef strRemoteHost As String) + 'Dim lngResult As Long + 'Dim udtHostent As HOSTENT + ' + On Error GoTo GetRemoteInfoFromSI_Err + ' + lngRemotePort = IntegerToUnsigned(api_ntohs(udtSockAddr.sin_port)) + strRemoteHostIP = StringFromPointer(api_inet_ntoa(udtSockAddr.sin_addr)) + 'lngResult = api_gethostbyaddr(udtSockAddr.sin_addr, 4&, AF_INET) + 'If lngResult <> 0 Then + ' api_CopyMemory udtHostent, ByVal lngResult, LenB(udtHostent) + ' strRemoteHost = StringFromPointer(udtHostent.hName) + 'Else + strRemoteHost = "" + 'End If + ' + Exit Sub +GetRemoteInfoFromSI_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetRemoteInfoFromSI" + Resume Next + ' +End Sub + +'Returns winsock incoming buffer length from an UDP socket. +Private Function GetBufferLenUDP() As Long + ' + On Error GoTo GetBufferLenUDP_Err + ' + Dim lngResult As Long + Dim lngBuffer As Long + lngResult = api_ioctlsocket(m_lngSocketHandle, FIONREAD, lngBuffer) + + If lngResult = SOCKET_ERROR Then + GetBufferLenUDP = 0 + Else + GetBufferLenUDP = lngBuffer + End If + + ' + Exit Function +GetBufferLenUDP_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.GetBufferLenUDP" + Resume Next + ' +End Function + +'Empty winsock incoming buffer from an UDP socket. +Private Sub EmptyBuffer() + ' + On Error GoTo EmptyBuffer_Err + ' + Dim B As Byte + api_recv m_lngSocketHandle, B, Len(B), 0& + ' + Exit Sub +EmptyBuffer_Err: + Controlar_Error Erl, Err.Description, "Reseter.CSocketMaster.EmptyBuffer" + Resume Next + ' +End Sub diff --git a/AuroNet/modSocketMaster.bas b/AuroNet/modSocketMaster.bas dissimilarity index 61% index 28a3bef..d3275cb 100755 --- a/AuroNet/modSocketMaster.bas +++ b/AuroNet/modSocketMaster.bas @@ -1,1233 +1,1233 @@ -Attribute VB_Name = "modSocketMaster" -'************************************************************************************** -' -'modSocketMaster module 1.2 -'Copyright (c) 2004 by Emiliano Scavuzzo -' -'Rosario, Argentina -' -'************************************************************************************** -'This module contains API declarations and helper functions for the CSocketMaster class -'************************************************************************************** -Option Explicit -'============================================================================== -'API FUNCTIONS -'============================================================================== -'Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long -Public Declare Sub api_CopyMemory _ - Lib "kernel32" _ - Alias "RtlMoveMemory" (Destination As Any, _ - Source As Any, _ - ByVal Length As Long) -Public Declare Function api_GlobalAlloc _ - Lib "kernel32" _ - Alias "GlobalAlloc" (ByVal wFlags As Long, _ - ByVal dwBytes As Long) As Long -Public Declare Function api_GlobalFree _ - Lib "kernel32" _ - Alias "GlobalFree" (ByVal hMem As Long) As Long -Private Declare Function api_WSAStartup _ - Lib "ws2_32.dll" _ - Alias "WSAStartup" (ByVal wVersionRequired As Long, _ - lpWSADATA As WSAData) As Long -Private Declare Function api_WSACleanup _ - Lib "ws2_32.dll" _ - Alias "WSACleanup" () As Long -Private 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 -Private Declare Function api_WSAAsyncSelect _ - Lib "ws2_32.dll" _ - Alias "WSAAsyncSelect" (ByVal s As Long, _ - ByVal hWnd As Long, _ - ByVal wMsg As Long, _ - ByVal lEvent As Long) As Long -Private 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 -Private Declare Function api_DestroyWindow _ - Lib "user32" _ - Alias "DestroyWindow" (ByVal hWnd As Long) As Long -Private Declare Function api_lstrlen _ - Lib "kernel32" _ - Alias "lstrlenA" (ByVal lpString As Any) As Long -Private Declare Function api_lstrcpy _ - Lib "kernel32" _ - Alias "lstrcpyA" (ByVal lpString1 As String, _ - ByVal lpString2 As Long) As Long -'============================================================================== -'CONSTANTS -'============================================================================== -Public Const SOCKET_ERROR As Integer = -1 -Public Const INVALID_SOCKET As Integer = -1 -Public Const INADDR_NONE As Long = &HFFFF -Private Const WSADESCRIPTION_LEN As Integer = 257 -Private Const WSASYS_STATUS_LEN As Integer = 129 -Private Enum WinsockVersion - SOCKET_VERSION_11 = &H101 - SOCKET_VERSION_22 = &H202 -End Enum -Public Const MAXGETHOSTSTRUCT As Long = 1024 -Public Const AF_INET As Long = 2 -Public Const SOCK_STREAM As Long = 1 -Public Const SOCK_DGRAM As Long = 2 -Public Const IPPROTO_TCP As Long = 6 -Public Const IPPROTO_UDP As Long = 17 -Public Const FD_READ As Integer = &H1& -Public Const FD_WRITE As Integer = &H2& -Public Const FD_ACCEPT As Integer = &H8& -Public Const FD_CONNECT As Integer = &H10& -Public Const FD_CLOSE As Integer = &H20& -Private Const OFFSET_2 As Long = 65536 -Private Const MAXINT_2 As Long = 32767 -Public Const GMEM_FIXED As Integer = &H0 -Public Const LOCAL_HOST_BUFF As Integer = 256 -Public Const SOL_SOCKET As Long = 65535 -Public Const SO_SNDBUF As Long = &H1001& -Public Const SO_RCVBUF As Long = &H1002& -Public Const SO_MAX_MSG_SIZE As Long = &H2003 -Public Const SO_BROADCAST As Long = &H20 -Public Const FIONREAD As Long = &H4004667F -'============================================================================== -'ERROR CODES -'============================================================================== -Public Const WSABASEERR As Long = 10000 -Public Const WSAEINTR As Long = (WSABASEERR + 4) -Public Const WSAEACCES As Long = (WSABASEERR + 13) -Public Const WSAEFAULT As Long = (WSABASEERR + 14) -Public Const WSAEINVAL As Long = (WSABASEERR + 22) -Public Const WSAEMFILE As Long = (WSABASEERR + 24) -Public Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35) -Public Const WSAEINPROGRESS As Long = (WSABASEERR + 36) -Public Const WSAEALREADY As Long = (WSABASEERR + 37) -Public Const WSAENOTSOCK As Long = (WSABASEERR + 38) -Public Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39) -Public Const WSAEMSGSIZE As Long = (WSABASEERR + 40) -Public Const WSAEPROTOTYPE As Long = (WSABASEERR + 41) -Public Const WSAENOPROTOOPT As Long = (WSABASEERR + 42) -Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43) -Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44) -Public Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45) -Public Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46) -Public Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47) -Public Const WSAEADDRINUSE As Long = (WSABASEERR + 48) -Public Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49) -Public Const WSAENETDOWN As Long = (WSABASEERR + 50) -Public Const WSAENETUNREACH As Long = (WSABASEERR + 51) -Public Const WSAENETRESET As Long = (WSABASEERR + 52) -Public Const WSAECONNABORTED As Long = (WSABASEERR + 53) -Public Const WSAECONNRESET As Long = (WSABASEERR + 54) -Public Const WSAENOBUFS As Long = (WSABASEERR + 55) -Public Const WSAEISCONN As Long = (WSABASEERR + 56) -Public Const WSAENOTCONN As Long = (WSABASEERR + 57) -Public Const WSAESHUTDOWN As Long = (WSABASEERR + 58) -Public Const WSAETIMEDOUT As Long = (WSABASEERR + 60) -Public Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65) -Public Const WSAECONNREFUSED As Long = (WSABASEERR + 61) -Public Const WSAEPROCLIM As Long = (WSABASEERR + 67) -Public Const WSASYSNOTREADY As Long = (WSABASEERR + 91) -Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92) -Public Const WSANOTINITIALISED As Long = (WSABASEERR + 93) -Public Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001) -Public Const WSATRY_AGAIN As Long = (WSABASEERR + 1002) -Public Const WSANO_RECOVERY As Long = (WSABASEERR + 1003) -Public Const WSANO_DATA As Long = (WSABASEERR + 1004) -'============================================================================== -'WINSOCK CONTROL ERROR CODES -'============================================================================== -Public Const sckOutOfMemory As Long = 7 -Public Const sckBadState As Long = 40006 -Public Const sckInvalidArg As Long = 40014 -Public Const sckUnsupported As Long = 40018 -Public Const sckInvalidOp As Long = 40020 -'============================================================================== -'STRUCTURES -'============================================================================== -Private Type WSAData - wVersion As Integer - wHighVersion As Integer - szDescription As String * WSADESCRIPTION_LEN - szSystemStatus As String * WSASYS_STATUS_LEN - iMaxSockets As Integer - iMaxUdpDg As Integer - lpVendorInfo As Long -End Type -Public Type HOSTENT - hName As Long - hAliases As Long - hAddrType As Integer - hLength As Integer - hAddrList As Long -End Type -Public Type sockaddr_in - sin_family As Integer - sin_port As Integer - sin_addr As Long - sin_zero(1 To 8) As Byte -End Type -'============================================================================== -'MEMBER VARIABLES -'============================================================================== -Private m_blnInitiated As Boolean 'specify if winsock service was initiated -Private m_lngSocksQuantity As Long 'number of instances created -Private m_colSocketsInst As Collection 'sockets list and instance owner -Private m_colAcceptList As Collection 'sockets in queue that need to be accepted -Private m_lngWindowHandle As Long 'message window handle -'============================================================================== -'SUBCLASSING DECLARATIONS -'by Paul Caton -'============================================================================== -Private Declare Function api_IsWindow _ - Lib "user32" _ - Alias "IsWindow" (ByVal hWnd As Long) As Long -Private Declare Function api_GetWindowLong _ - Lib "user32" _ - Alias "GetWindowLongA" (ByVal hWnd As Long, _ - ByVal nIndex As Long) As Long -Private Declare Function api_SetWindowLong _ - Lib "user32" _ - Alias "SetWindowLongA" (ByVal hWnd As Long, _ - ByVal nIndex As Long, _ - ByVal dwNewLong As Long) As Long -Private Declare Function api_GetModuleHandle _ - Lib "kernel32" _ - Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long -Private Declare Function api_GetProcAddress _ - Lib "kernel32" _ - Alias "GetProcAddress" (ByVal hModule As Long, _ - ByVal lpProcName As String) As Long -Private Const PATCH_06 As Long = 106 -Private Const PATCH_09 As Long = 137 -Private Const GWL_WNDPROC As Long = (-4) -Private Const WM_APP As Long = 32768 '0x8000 -Public Const RESOLVE_MESSAGE As Long = WM_APP -Public Const SOCKET_MESSAGE As Long = WM_APP + 1 -Private lngMsgCntA As Long 'TableA entry count -Private lngMsgCntB As Long 'TableB entry count -Private lngTableA1() As Long 'TableA1: list of async handles -Private lngTableA2() As Long 'TableA2: list of async handles owners -Private lngTableB1() As Long 'TableB1: list of sockets -Private lngTableB2() As Long 'TableB2: list of sockets owners -Private hWndSub As Long 'window handle subclassed -Private nAddrSubclass As Long 'address of our WndProc -Private nAddrOriginal As Long 'address of original WndProc - -'Once we are done with the class instance we call this -'function to discount it and finish winsock service if -'it was the last one. -'Returns 0 if it has success. -Public Function FinalizeProcesses() As Long - ' - On Error GoTo FinalizeProcesses_Err - ' -100 FinalizeProcesses = 0 -101 m_lngSocksQuantity = m_lngSocksQuantity - 1 - - 'if the service was initiated and there's no more instances - 'of the class then we finish the service -102 If m_blnInitiated And m_lngSocksQuantity = 0 Then -103 If FinalizeService = SOCKET_ERROR Then - Dim lngErrorCode As Long -104 lngErrorCode = Err.LastDllError -105 FinalizeProcesses = lngErrorCode -106 Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode) - Else - '114 Debug.Print "OK Winsock service finalized" - End If - -107 Subclass_Terminate -108 m_blnInitiated = False - End If - - ' - Exit Function -FinalizeProcesses_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeProcesses.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Return the accept instance class from a socket. -Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster - ' - On Error GoTo GetAcceptClass_Err - ' -100 Set GetAcceptClass = m_colAcceptList("S" & lngSocket) - ' - Exit Function -GetAcceptClass_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetAcceptClass.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'This function receives a number that represents an error -'and returns the corresponding description string. -Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String - ' - On Error GoTo GetErrorDescription_Err - - ' -100 Select Case lngErrorCode - - Case WSAEACCES -101 GetErrorDescription = "Permission denied." - -102 Case WSAEADDRINUSE -103 GetErrorDescription = "Address already in use." - -104 Case WSAEADDRNOTAVAIL -105 GetErrorDescription = "Cannot assign requested address." - -106 Case WSAEAFNOSUPPORT -107 GetErrorDescription = "Address family not supported by protocol family." - -108 Case WSAEALREADY -109 GetErrorDescription = "Operation already in progress." - -110 Case WSAECONNABORTED -111 GetErrorDescription = "Software caused connection abort." - -112 Case WSAECONNREFUSED -113 GetErrorDescription = "Connection refused." - -114 Case WSAECONNRESET -115 GetErrorDescription = "Connection reset by peer." - -116 Case WSAEDESTADDRREQ -117 GetErrorDescription = "Destination address required." - -118 Case WSAEFAULT -119 GetErrorDescription = "Bad address." - -120 Case WSAEHOSTUNREACH -121 GetErrorDescription = "No route to host." - -122 Case WSAEINPROGRESS -123 GetErrorDescription = "Operation now in progress." - -124 Case WSAEINTR -125 GetErrorDescription = "Interrupted function call." - -126 Case WSAEINVAL -127 GetErrorDescription = "Invalid argument." - -128 Case WSAEISCONN -129 GetErrorDescription = "Socket is already connected." - -130 Case WSAEMFILE -131 GetErrorDescription = "Too many open files." - -132 Case WSAEMSGSIZE -133 GetErrorDescription = "Message too long." - -134 Case WSAENETDOWN -135 GetErrorDescription = "Network is down." - -136 Case WSAENETRESET -137 GetErrorDescription = "Network dropped connection on reset." - -138 Case WSAENETUNREACH -139 GetErrorDescription = "Network is unreachable." - -140 Case WSAENOBUFS -141 GetErrorDescription = "No buffer space available." - -142 Case WSAENOPROTOOPT -143 GetErrorDescription = "Bad protocol option." - -144 Case WSAENOTCONN -145 GetErrorDescription = "Socket is not connected." - -146 Case WSAENOTSOCK -147 GetErrorDescription = "Socket operation on nonsocket." - -148 Case WSAEOPNOTSUPP -149 GetErrorDescription = "Operation not supported." - -150 Case WSAEPFNOSUPPORT -151 GetErrorDescription = "Protocol family not supported." - -152 Case WSAEPROCLIM -153 GetErrorDescription = "Too many processes." - -154 Case WSAEPROTONOSUPPORT -155 GetErrorDescription = "Protocol not supported." - -156 Case WSAEPROTOTYPE -157 GetErrorDescription = "Protocol wrong type for socket." - -158 Case WSAESHUTDOWN -159 GetErrorDescription = "Cannot send after socket shutdown." - -160 Case WSAESOCKTNOSUPPORT -161 GetErrorDescription = "Socket type not supported." - -162 Case WSAETIMEDOUT -163 GetErrorDescription = "Connection timed out." - -164 Case WSAEWOULDBLOCK -165 GetErrorDescription = "Resource temporarily unavailable." - -166 Case WSAHOST_NOT_FOUND -167 GetErrorDescription = "Host not found." - -168 Case WSANOTINITIALISED -169 GetErrorDescription = "Successful WSAStartup not yet performed." - -170 Case WSANO_DATA -171 GetErrorDescription = "Valid name, no data record of requested type." - -172 Case WSANO_RECOVERY -173 GetErrorDescription = "This is a nonrecoverable error." - -174 Case WSASYSNOTREADY -175 GetErrorDescription = "Network subsystem is unavailable." - -176 Case WSATRY_AGAIN -177 GetErrorDescription = "Non authoritative host not found." - -178 Case WSAVERNOTSUPPORTED -179 GetErrorDescription = "Winsock.dll version out of range." - -180 Case Else -181 GetErrorDescription = "Unknown error." - End Select - - ' - Exit Function -GetErrorDescription_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetErrorDescription.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Returns the hi word from a double word. -Public Function HiWord(lngValue As Long) As Long - ' - On Error GoTo HiWord_Err - - ' -100 If (lngValue And &H80000000) = &H80000000 Then -101 HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000& - Else -102 HiWord = (lngValue And &HFFFF0000) \ &H10000 - End If - - ' - Exit Function -HiWord_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.HiWord.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'This function initiates the processes needed to keep -'control of sockets. Returns 0 if it has success. -Public Function InitiateProcesses() As Long - ' - On Error GoTo InitiateProcesses_Err - ' -100 InitiateProcesses = 0 -101 m_lngSocksQuantity = m_lngSocksQuantity + 1 - - 'if the service wasn't initiated yet we do it now -102 If Not m_blnInitiated Then -103 Subclass_Initialize -104 m_blnInitiated = True - Dim lngResult As Long -105 lngResult = InitiateService - -106 If lngResult = 0 Then - 'Debug.Print "OK Winsock service initiated" - Else -107 Debug.Print "ERROR trying to initiate winsock service" -108 Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult) -109 InitiateProcesses = lngResult - End If - End If - - ' - Exit Function -InitiateProcesses_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateProcesses.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'The function takes a Long containing a value in the range  -'of an unsigned Integer and returns an Integer that you  -'can pass to an API that requires an unsigned Integer -Public Function IntegerToUnsigned(Value As Integer) As Long - ' - On Error GoTo IntegerToUnsigned_Err - - ' -100 If Value < 0 Then -101 IntegerToUnsigned = Value + OFFSET_2 - Else -102 IntegerToUnsigned = Value - End If - - ' - Exit Function -IntegerToUnsigned_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IntegerToUnsigned.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Returns True is lngSocket is registered on the -'accept list. -Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean - ' - On Error GoTo IsAcceptRegistered_Err - ' - On Error GoTo Error_Handler -100 m_colAcceptList.Item ("S" & lngSocket) -101 IsAcceptRegistered = True - Exit Function -Error_Handler: -102 IsAcceptRegistered = False - ' - Exit Function -IsAcceptRegistered_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsAcceptRegistered.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Returns TRUE si the socket that is passed is registered -'in the colSocketsInst collection. -Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean - ' - On Error GoTo IsSocketRegistered_Err - ' - On Error GoTo Error_Handler -100 m_colSocketsInst.Item ("S" & lngSocket) -101 IsSocketRegistered = True - Exit Function -Error_Handler: -102 IsSocketRegistered = False - ' - Exit Function -IsSocketRegistered_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsSocketRegistered.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Returns the low word from a double word. -Public Function LoWord(lngValue As Long) As Long - ' - On Error GoTo LoWord_Err - ' -100 LoWord = (lngValue And &HFFFF&) - ' - Exit Function -LoWord_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.LoWord.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Assing a temporal instance of CSocketMaster to a -'socket and register this socket to the accept list. -Public Sub RegisterAccept(ByVal lngSocket As Long) - ' - On Error GoTo RegisterAccept_Err - - ' -100 If m_colAcceptList Is Nothing Then -101 Set m_colAcceptList = New Collection - End If - - Dim Socket As CSocketMaster -102 Set Socket = New CSocketMaster -103 Socket.Accept lngSocket -104 m_colAcceptList.Add Socket, "S" & lngSocket - ' - Exit Sub -RegisterAccept_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterAccept.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Sub - -'Adds the socket to the m_colSocketsInst collection, and -'registers that socket with WSAAsyncSelect Winsock API -'function to receive network events for the socket. -'If this socket is the first one to be registered, the -'window and collection will be created in this function as well. -Public Function RegisterSocket(ByVal lngSocket As Long, _ - ByVal lngObjectPointer As Long, _ - ByVal blnEvents As Boolean) As Boolean - ' - On Error GoTo RegisterSocket_Err - - ' -100 If m_colSocketsInst Is Nothing Then -101 Set m_colSocketsInst = New Collection - -102 If CreateWinsockMessageWindow <> 0 Then -103 Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory" - End If - -104 Subclass_Subclass (m_lngWindowHandle) - End If - -105 Subclass_AddSocketMessage lngSocket, lngObjectPointer - - 'Do we need to register socket events? -106 If blnEvents Then - Dim lngEvents As Long - Dim lngResult As Long - Dim lngErrorCode As Long -107 lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE -108 lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents) - -109 If lngResult = SOCKET_ERROR Then -110 Debug.Print "ERROR trying to register events from socket " & lngSocket -111 lngErrorCode = Err.LastDllError -112 Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode) - End If - End If - -113 m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket -114 RegisterSocket = True - ' - Exit Function -RegisterSocket_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterSocket.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'When a socket needs to resolve a hostname in asynchronous way -'it calls this function. If it has success it returns a nonzero -'number that represents the async task handle and register this -'number in the TableA list. -'Returns 0 if it fails. -Public Function ResolveHost(ByVal strHost As String, _ - ByVal lngHOSTENBuf As Long, _ - ByVal lngObjectPointer As Long) As Long - ' - On Error GoTo ResolveHost_Err - ' - Dim lngAsynHandle As Long -100 lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT) - -101 If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer -102 ResolveHost = lngAsynHandle - ' - Exit Function -ResolveHost_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.ResolveHost.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Receives a string pointer and it turns it into a regular string. -Public Function StringFromPointer(ByVal lPointer As Long) As String - ' - On Error GoTo StringFromPointer_Err - ' - Dim strTemp As String - Dim lRetVal As Long -100 strTemp = String$(api_lstrlen(ByVal lPointer), 0) -101 lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer) - -102 If lRetVal Then StringFromPointer = strTemp - ' - Exit Function -StringFromPointer_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.StringFromPointer.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Unregister lngSocket from the accept list. -Public Sub UnregisterAccept(ByVal lngSocket As Long) - ' - On Error GoTo UnregisterAccept_Err - ' -100 m_colAcceptList.Remove "S" & lngSocket - -101 If m_colAcceptList.Count = 0 Then -102 Set m_colAcceptList = Nothing - End If - - ' - Exit Sub -UnregisterAccept_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterAccept.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Sub - -'When ResolveHost is called an async task handle is added -'to TableA list. Use this function to remove that record. -Public Sub UnregisterResolution(ByVal lngAsynHandle As Long) - ' - On Error GoTo UnregisterResolution_Err - ' -100 Subclass_DelResolveMessage lngAsynHandle - ' - Exit Sub -UnregisterResolution_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterResolution.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Sub - -'Removes the socket from the m_colSocketsInst collection -'If it is the last socket in that collection, the window -'and colection will be destroyed as well. -Public Sub UnregisterSocket(ByVal lngSocket As Long) - ' - On Error GoTo UnregisterSocket_Err - ' -100 Subclass_DelSocketMessage lngSocket - On Error Resume Next -101 m_colSocketsInst.Remove "S" & lngSocket - -102 If m_colSocketsInst.Count = 0 Then -103 Set m_colSocketsInst = Nothing -104 Subclass_UnSubclass -105 DestroyWinsockMessageWindow - End If - - ' - Exit Sub -UnregisterSocket_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterSocket.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Sub - -'The function takes an unsigned Integer from and API and  -'converts it to a Long for display or arithmetic purposes -Public Function UnsignedToInteger(Value As Long) As Integer - ' - On Error GoTo UnsignedToInteger_Err - - ' -100 If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow -101 If Value <= MAXINT_2 Then -102 UnsignedToInteger = Value - Else -103 UnsignedToInteger = Value - OFFSET_2 - End If - - ' - Exit Function -UnsignedToInteger_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnsignedToInteger.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Create a window that is used to capture sockets messages. -'Returns 0 if it has success. -Private Function CreateWinsockMessageWindow() As Long - ' - On Error GoTo CreateWinsockMessageWindow_Err - ' -100 m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&) - -101 If m_lngWindowHandle = 0 Then -102 CreateWinsockMessageWindow = sckOutOfMemory - Exit Function - Else -103 CreateWinsockMessageWindow = 0 - End If - - ' - Exit Function -CreateWinsockMessageWindow_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.CreateWinsockMessageWindow.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Destroy the window that is used to capture sockets messages. -'Returns 0 if it has success. -Private Function DestroyWinsockMessageWindow() As Long - ' - On Error GoTo DestroyWinsockMessageWindow_Err - ' -100 DestroyWinsockMessageWindow = 0 - -101 If m_lngWindowHandle = 0 Then - Exit Function - End If - - Dim lngResult As Long -102 lngResult = api_DestroyWindow(m_lngWindowHandle) - -103 If lngResult = 0 Then -104 DestroyWinsockMessageWindow = sckOutOfMemory -105 Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory" - Else - '112 Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle -106 m_lngWindowHandle = 0 - End If - - ' - Exit Function -DestroyWinsockMessageWindow_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.DestroyWinsockMessageWindow.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'Finish winsock service calling the function -'api_WSACleanup and returns the result. -Private Function FinalizeService() As Long - ' - On Error GoTo FinalizeService_Err - ' - Dim lngResultado As Long -100 lngResultado = api_WSACleanup -101 FinalizeService = lngResultado - ' - Exit Function -FinalizeService_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeService.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -'This function initiate the winsock service calling -'the api_WSAStartup funtion and returns resulting value. -Private Function InitiateService() As Long - ' - On Error GoTo InitiateService_Err - ' - Dim udtWSAData As WSAData - Dim lngResult As Long -100 lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData) -101 InitiateService = lngResult - ' - Exit Function -InitiateService_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateService.Ref 12/8/2008 : 08:11:16" - Resume Next - ' -End Function - -Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, _ - ByVal lngObjectPointer As Long) - ' - On Error GoTo Subclass_ChangeOwner_Err - ' - Dim Count As Long - -100 For Count = 1 To lngMsgCntB - -101 If lngTableB1(Count) = lngSocket Then -102 lngTableB2(Count) = lngObjectPointer - Exit Sub - End If - - Next - - ' - Exit Sub -Subclass_ChangeOwner_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_ChangeOwner.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, _ - ByVal lngObjectPointer As Long) - ' - On Error GoTo Subclass_AddResolveMessage_Err - ' - Dim Count As Long - -100 For Count = 1 To lngMsgCntA - -101 Select Case lngTableA1(Count) - - Case -1 -102 lngTableA1(Count) = lngAsync -103 lngTableA2(Count) = lngObjectPointer - Exit Sub - -104 Case lngAsync - Exit Sub - End Select - - Next - -105 lngMsgCntA = lngMsgCntA + 1 -106 ReDim Preserve lngTableA1(1 To lngMsgCntA) -107 ReDim Preserve lngTableA2(1 To lngMsgCntA) -108 lngTableA1(lngMsgCntA) = lngAsync -109 lngTableA2(lngMsgCntA) = lngObjectPointer -110 Subclass_PatchTableA - ' - Exit Sub -Subclass_AddResolveMessage_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddResolveMessage.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Return the address of the passed function in the passed dll -Private Function Subclass_AddrFunc(ByVal sDLL As String, _ - ByVal sProc As String) As Long - ' - On Error GoTo Subclass_AddrFunc_Err - ' -100 Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc) - ' - Exit Function -Subclass_AddrFunc_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrFunc.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function - -'Return the address of the low bound of the passed table array -Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long - ' - On Error GoTo Subclass_AddrMsgTbl_Err - ' - On Error Resume Next 'The table may not be dimensioned yet so we need protection -100 Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1)) 'Get the address of the first element of the passed message table - On Error GoTo Subclass_AddrMsgTbl_Err 'Switch off error protection - ' - Exit Function -Subclass_AddrMsgTbl_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrMsgTbl.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function - -Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, _ - ByVal lngObjectPointer As Long) - ' - On Error GoTo Subclass_AddSocketMessage_Err - ' - Dim Count As Long - -100 For Count = 1 To lngMsgCntB - -101 Select Case lngTableB1(Count) - - Case -1 -102 lngTableB1(Count) = lngSocket -103 lngTableB2(Count) = lngObjectPointer - Exit Sub - -104 Case lngSocket - Exit Sub - End Select - - Next - -105 lngMsgCntB = lngMsgCntB + 1 -106 ReDim Preserve lngTableB1(1 To lngMsgCntB) -107 ReDim Preserve lngTableB2(1 To lngMsgCntB) -108 lngTableB1(lngMsgCntB) = lngSocket -109 lngTableB2(lngMsgCntB) = lngObjectPointer -110 Subclass_PatchTableB - ' - Exit Sub -Subclass_AddSocketMessage_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddSocketMessage.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long) - ' - On Error GoTo Subclass_DelResolveMessage_Err - ' - Dim Count As Long - -100 For Count = 1 To lngMsgCntA - -101 If lngTableA1(Count) = lngAsync Then -102 lngTableA1(Count) = -1 -103 lngTableA2(Count) = -1 - Exit Sub - End If - - Next - - ' - Exit Sub -Subclass_DelResolveMessage_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelResolveMessage.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long) - ' - On Error GoTo Subclass_DelSocketMessage_Err - ' - Dim Count As Long - -100 For Count = 1 To lngMsgCntB - -101 If lngTableB1(Count) = lngSocket Then -102 lngTableB1(Count) = -1 -103 lngTableB2(Count) = -1 - Exit Sub - End If - - Next - - ' - Exit Sub -Subclass_DelSocketMessage_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelSocketMessage.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Return whether we're running in the IDE. Public for general utility purposes -Private Function Subclass_InIDE() As Boolean - ' - On Error GoTo Subclass_InIDE_Err - ' -100 Debug.Assert Subclass_SetTrue(Subclass_InIDE) - ' - Exit Function -Subclass_InIDE_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_InIDE.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function - -'============================================================================== -'SUBCLASSING CODE -'based on code by Paul Caton -'============================================================================== -Private Sub Subclass_Initialize() - ' - On Error GoTo Subclass_Initialize_Err - ' - Const PATCH_01 As Long = 15 'Code buffer offset to the location of the relative address to EbMode - Const PATCH_03 As Long = 76 'Relative address of SetWindowsLong - Const PATCH_05 As Long = 100 'Relative address of CallWindowProc - Const 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 - Const 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 - Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc - Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5 - Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6 - Const MOD_USER As String = "user32" 'Location of the SetWindowLong & CallWindowProc functions - Dim i As Long 'Loop index - Dim nLen As Long 'String lengths - Dim sHex As String 'Hex code string - Dim sCode As String 'Binary code string - 'Store the hex pair machine code representation in sHex -100 sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0080000074433D01800000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0" -101 nLen = Len(sHex) 'Length of hex pair string - - 'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer -102 For i = 1 To nLen Step 2 'For each pair of hex characters -103 sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2))) 'Convert a pair of hex characters to a byte and append to the ASCII string - Next 'Next pair - -104 nLen = LenB(sCode) 'Get the machine code length -105 nAddrSubclass = api_GlobalAlloc(0, nLen) 'Allocate fixed memory for machine code buffer - 'Copy the code to allocated memory -106 Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen) - -107 If Subclass_InIDE Then - 'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code -108 Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2) -109 i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll - -110 If i = 0 Then 'Found? -111 i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps, try vba5.dll - End If - -112 Debug.Assert i 'Ensure the EbMode function was found -113 Call Subclass_PatchRel(PATCH_01, i) 'Patch the relative address to the EbMode api function - End If - -114 Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)) 'Address of the SetWindowLong api function -115 Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP)) 'Address of the CallWindowProc api function - ' - Exit Sub -Subclass_Initialize_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Initialize.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Patch the machine code buffer offset with the relative address to the target address -Private Sub Subclass_PatchRel(ByVal nOffset As Long, _ - ByVal nTargetAddr As Long) - ' - On Error GoTo Subclass_PatchRel_Err - ' -100 Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4) - ' - Exit Sub -Subclass_PatchRel_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchRel.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -Private Sub Subclass_PatchTableA() - ' - On Error GoTo Subclass_PatchTableA_Err - ' - Const PATCH_07 As Long = 114 - Const PATCH_08 As Long = 130 -100 Call Subclass_PatchVal(PATCH_06, lngMsgCntA) -101 Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1)) -102 Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2)) - ' - Exit Sub -Subclass_PatchTableA_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableA.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -Private Sub Subclass_PatchTableB() - ' - On Error GoTo Subclass_PatchTableB_Err - ' - Const PATCH_0A As Long = 145 - Const PATCH_0B As Long = 161 -100 Call Subclass_PatchVal(PATCH_09, lngMsgCntB) -101 Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1)) -102 Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2)) - ' - Exit Sub -Subclass_PatchTableB_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableB.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Patch the machine code buffer offset with the passed value -Private Sub Subclass_PatchVal(ByVal nOffset As Long, _ - ByVal nValue As Long) - ' - On Error GoTo Subclass_PatchVal_Err - ' -100 Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4) - ' - Exit Sub -Subclass_PatchVal_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchVal.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Worker function for InIDE - will only be called whilst running in the IDE -Private Function Subclass_SetTrue(bValue As Boolean) As Boolean - ' - On Error GoTo Subclass_SetTrue_Err - ' -100 Subclass_SetTrue = True -101 bValue = True - ' - Exit Function -Subclass_SetTrue_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_SetTrue.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function - -'Set the window subclass -Private Function Subclass_Subclass(ByVal hWnd As Long) As Boolean - ' - On Error GoTo Subclass_Subclass_Err - ' - Const PATCH_02 As Long = 66 'Address of the previous WndProc - Const PATCH_04 As Long = 95 'Address of the previous WndProc - -100 If hWndSub = 0 Then -101 Debug.Assert api_IsWindow(hWnd) 'Invalid window handle -102 hWndSub = hWnd 'Store the window handle - 'Get the original window proc -103 nAddrOriginal = api_GetWindowLong(hWnd, GWL_WNDPROC) -104 Call Subclass_PatchVal(PATCH_02, nAddrOriginal) 'Original WndProc address for CallWindowProc, call the original WndProc -105 Call Subclass_PatchVal(PATCH_04, nAddrOriginal) 'Original WndProc address for SetWindowLong, unsubclass on IDE stop - 'Set our WndProc in place of the original -106 nAddrOriginal = api_SetWindowLong(hWnd, GWL_WNDPROC, nAddrSubclass) - -107 If nAddrOriginal <> 0 Then -108 nAddrOriginal = 0 -109 Subclass_Subclass = True 'Success - End If - End If - -110 Debug.Assert Subclass_Subclass - ' - Exit Function -Subclass_Subclass_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Subclass.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function - -'UnSubclass and release the allocated memory -Private Sub Subclass_Terminate() - ' - On Error GoTo Subclass_Terminate_Err - ' -100 Call Subclass_UnSubclass 'UnSubclass if the Subclass thunk is active -101 Call api_GlobalFree(nAddrSubclass) 'Release the allocated memory -102 nAddrSubclass = 0 -103 ReDim lngTableA1(1 To 1) -104 ReDim lngTableA2(1 To 1) -105 ReDim lngTableB1(1 To 1) -106 ReDim lngTableB2(1 To 1) - ' - Exit Sub -Subclass_Terminate_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Terminate.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Sub - -'Stop subclassing the window -Private Function Subclass_UnSubclass() As Boolean - ' - On Error GoTo Subclass_UnSubclass_Err - - ' -100 If hWndSub <> 0 Then -101 lngMsgCntA = 0 -102 lngMsgCntB = 0 -103 Call Subclass_PatchVal(PATCH_06, lngMsgCntA) 'Patch the TableA entry count to ensure no further Proc callbacks -104 Call Subclass_PatchVal(PATCH_09, lngMsgCntB) 'Patch the TableB entry count to ensure no further Proc callbacks - 'Restore the original WndProc -105 Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal) -106 hWndSub = 0 'Indicate the subclasser is inactive -107 Subclass_UnSubclass = True 'Success - End If - - ' - Exit Function -Subclass_UnSubclass_Err: - Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_UnSubclass.Ref 12/8/2008 : 08:11:15" - Resume Next - ' -End Function +Attribute VB_Name = "modSocketMaster" +'************************************************************************************** +' +'modSocketMaster module 1.2 +'Copyright (c) 2004 by Emiliano Scavuzzo +' +'Rosario, Argentina +' +'************************************************************************************** +'This module contains API declarations and helper functions for the CSocketMaster class +'************************************************************************************** +Option Explicit +'============================================================================== +'API FUNCTIONS +'============================================================================== +'Public Declare Function api_WSAGetLastError Lib "ws2_32.dll" Alias "WSAGetLastError" () As Long +Public Declare Sub api_CopyMemory _ + Lib "kernel32" _ + Alias "RtlMoveMemory" (Destination As Any, _ + Source As Any, _ + ByVal Length As Long) +Public Declare Function api_GlobalAlloc _ + Lib "kernel32" _ + Alias "GlobalAlloc" (ByVal wFlags As Long, _ + ByVal dwBytes As Long) As Long +Public Declare Function api_GlobalFree _ + Lib "kernel32" _ + Alias "GlobalFree" (ByVal hMem As Long) As Long +Private Declare Function api_WSAStartup _ + Lib "ws2_32.dll" _ + Alias "WSAStartup" (ByVal wVersionRequired As Long, _ + lpWSADATA As WSAData) As Long +Private Declare Function api_WSACleanup _ + Lib "ws2_32.dll" _ + Alias "WSACleanup" () As Long +Private 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 +Private Declare Function api_WSAAsyncSelect _ + Lib "ws2_32.dll" _ + Alias "WSAAsyncSelect" (ByVal s As Long, _ + ByVal hWnd As Long, _ + ByVal wMsg As Long, _ + ByVal lEvent As Long) As Long +Private 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 +Private Declare Function api_DestroyWindow _ + Lib "user32" _ + Alias "DestroyWindow" (ByVal hWnd As Long) As Long +Private Declare Function api_lstrlen _ + Lib "kernel32" _ + Alias "lstrlenA" (ByVal lpString As Any) As Long +Private Declare Function api_lstrcpy _ + Lib "kernel32" _ + Alias "lstrcpyA" (ByVal lpString1 As String, _ + ByVal lpString2 As Long) As Long +'============================================================================== +'CONSTANTS +'============================================================================== +Public Const SOCKET_ERROR As Integer = -1 +Public Const INVALID_SOCKET As Integer = -1 +Public Const INADDR_NONE As Long = &HFFFF +Private Const WSADESCRIPTION_LEN As Integer = 257 +Private Const WSASYS_STATUS_LEN As Integer = 129 +Private Enum WinsockVersion + SOCKET_VERSION_11 = &H101 + SOCKET_VERSION_22 = &H202 +End Enum +Public Const MAXGETHOSTSTRUCT As Long = 1024 +Public Const AF_INET As Long = 2 +Public Const SOCK_STREAM As Long = 1 +Public Const SOCK_DGRAM As Long = 2 +Public Const IPPROTO_TCP As Long = 6 +Public Const IPPROTO_UDP As Long = 17 +Public Const FD_READ As Integer = &H1& +Public Const FD_WRITE As Integer = &H2& +Public Const FD_ACCEPT As Integer = &H8& +Public Const FD_CONNECT As Integer = &H10& +Public Const FD_CLOSE As Integer = &H20& +Private Const OFFSET_2 As Long = 65536 +Private Const MAXINT_2 As Long = 32767 +Public Const GMEM_FIXED As Integer = &H0 +Public Const LOCAL_HOST_BUFF As Integer = 256 +Public Const SOL_SOCKET As Long = 65535 +Public Const SO_SNDBUF As Long = &H1001& +Public Const SO_RCVBUF As Long = &H1002& +Public Const SO_MAX_MSG_SIZE As Long = &H2003 +Public Const SO_BROADCAST As Long = &H20 +Public Const FIONREAD As Long = &H4004667F +'============================================================================== +'ERROR CODES +'============================================================================== +Public Const WSABASEERR As Long = 10000 +Public Const WSAEINTR As Long = (WSABASEERR + 4) +Public Const WSAEACCES As Long = (WSABASEERR + 13) +Public Const WSAEFAULT As Long = (WSABASEERR + 14) +Public Const WSAEINVAL As Long = (WSABASEERR + 22) +Public Const WSAEMFILE As Long = (WSABASEERR + 24) +Public Const WSAEWOULDBLOCK As Long = (WSABASEERR + 35) +Public Const WSAEINPROGRESS As Long = (WSABASEERR + 36) +Public Const WSAEALREADY As Long = (WSABASEERR + 37) +Public Const WSAENOTSOCK As Long = (WSABASEERR + 38) +Public Const WSAEDESTADDRREQ As Long = (WSABASEERR + 39) +Public Const WSAEMSGSIZE As Long = (WSABASEERR + 40) +Public Const WSAEPROTOTYPE As Long = (WSABASEERR + 41) +Public Const WSAENOPROTOOPT As Long = (WSABASEERR + 42) +Public Const WSAEPROTONOSUPPORT As Long = (WSABASEERR + 43) +Public Const WSAESOCKTNOSUPPORT As Long = (WSABASEERR + 44) +Public Const WSAEOPNOTSUPP As Long = (WSABASEERR + 45) +Public Const WSAEPFNOSUPPORT As Long = (WSABASEERR + 46) +Public Const WSAEAFNOSUPPORT As Long = (WSABASEERR + 47) +Public Const WSAEADDRINUSE As Long = (WSABASEERR + 48) +Public Const WSAEADDRNOTAVAIL As Long = (WSABASEERR + 49) +Public Const WSAENETDOWN As Long = (WSABASEERR + 50) +Public Const WSAENETUNREACH As Long = (WSABASEERR + 51) +Public Const WSAENETRESET As Long = (WSABASEERR + 52) +Public Const WSAECONNABORTED As Long = (WSABASEERR + 53) +Public Const WSAECONNRESET As Long = (WSABASEERR + 54) +Public Const WSAENOBUFS As Long = (WSABASEERR + 55) +Public Const WSAEISCONN As Long = (WSABASEERR + 56) +Public Const WSAENOTCONN As Long = (WSABASEERR + 57) +Public Const WSAESHUTDOWN As Long = (WSABASEERR + 58) +Public Const WSAETIMEDOUT As Long = (WSABASEERR + 60) +Public Const WSAEHOSTUNREACH As Long = (WSABASEERR + 65) +Public Const WSAECONNREFUSED As Long = (WSABASEERR + 61) +Public Const WSAEPROCLIM As Long = (WSABASEERR + 67) +Public Const WSASYSNOTREADY As Long = (WSABASEERR + 91) +Public Const WSAVERNOTSUPPORTED As Long = (WSABASEERR + 92) +Public Const WSANOTINITIALISED As Long = (WSABASEERR + 93) +Public Const WSAHOST_NOT_FOUND As Long = (WSABASEERR + 1001) +Public Const WSATRY_AGAIN As Long = (WSABASEERR + 1002) +Public Const WSANO_RECOVERY As Long = (WSABASEERR + 1003) +Public Const WSANO_DATA As Long = (WSABASEERR + 1004) +'============================================================================== +'WINSOCK CONTROL ERROR CODES +'============================================================================== +Public Const sckOutOfMemory As Long = 7 +Public Const sckBadState As Long = 40006 +Public Const sckInvalidArg As Long = 40014 +Public Const sckUnsupported As Long = 40018 +Public Const sckInvalidOp As Long = 40020 +'============================================================================== +'STRUCTURES +'============================================================================== +Private Type WSAData + wVersion As Integer + wHighVersion As Integer + szDescription As String * WSADESCRIPTION_LEN + szSystemStatus As String * WSASYS_STATUS_LEN + iMaxSockets As Integer + iMaxUdpDg As Integer + lpVendorInfo As Long +End Type +Public Type HOSTENT + hName As Long + hAliases As Long + hAddrType As Integer + hLength As Integer + hAddrList As Long +End Type +Public Type sockaddr_in + sin_family As Integer + sin_port As Integer + sin_addr As Long + sin_zero(1 To 8) As Byte +End Type +'============================================================================== +'MEMBER VARIABLES +'============================================================================== +Private m_blnInitiated As Boolean 'specify if winsock service was initiated +Private m_lngSocksQuantity As Long 'number of instances created +Private m_colSocketsInst As Collection 'sockets list and instance owner +Private m_colAcceptList As Collection 'sockets in queue that need to be accepted +Private m_lngWindowHandle As Long 'message window handle +'============================================================================== +'SUBCLASSING DECLARATIONS +'by Paul Caton +'============================================================================== +Private Declare Function api_IsWindow _ + Lib "user32" _ + Alias "IsWindow" (ByVal hWnd As Long) As Long +Private Declare Function api_GetWindowLong _ + Lib "user32" _ + Alias "GetWindowLongA" (ByVal hWnd As Long, _ + ByVal nIndex As Long) As Long +Private Declare Function api_SetWindowLong _ + Lib "user32" _ + Alias "SetWindowLongA" (ByVal hWnd As Long, _ + ByVal nIndex As Long, _ + ByVal dwNewLong As Long) As Long +Private Declare Function api_GetModuleHandle _ + Lib "kernel32" _ + Alias "GetModuleHandleA" (ByVal lpModuleName As String) As Long +Private Declare Function api_GetProcAddress _ + Lib "kernel32" _ + Alias "GetProcAddress" (ByVal hModule As Long, _ + ByVal lpProcName As String) As Long +Private Const PATCH_06 As Long = 106 +Private Const PATCH_09 As Long = 137 +Private Const GWL_WNDPROC As Long = (-4) +Private Const WM_APP As Long = 32768 '0x8000 +Public Const RESOLVE_MESSAGE As Long = WM_APP +Public Const SOCKET_MESSAGE As Long = WM_APP + 1 +Private lngMsgCntA As Long 'TableA entry count +Private lngMsgCntB As Long 'TableB entry count +Private lngTableA1() As Long 'TableA1: list of async handles +Private lngTableA2() As Long 'TableA2: list of async handles owners +Private lngTableB1() As Long 'TableB1: list of sockets +Private lngTableB2() As Long 'TableB2: list of sockets owners +Private hWndSub As Long 'window handle subclassed +Private nAddrSubclass As Long 'address of our WndProc +Private nAddrOriginal As Long 'address of original WndProc + +'Once we are done with the class instance we call this +'function to discount it and finish winsock service if +'it was the last one. +'Returns 0 if it has success. +Public Function FinalizeProcesses() As Long + ' + On Error GoTo FinalizeProcesses_Err + ' + FinalizeProcesses = 0 + m_lngSocksQuantity = m_lngSocksQuantity - 1 + + 'if the service was initiated and there's no more instances + 'of the class then we finish the service + If m_blnInitiated And m_lngSocksQuantity = 0 Then + If FinalizeService = SOCKET_ERROR Then + Dim lngErrorCode As Long + lngErrorCode = Err.LastDllError + FinalizeProcesses = lngErrorCode + Err.Raise lngErrorCode, "modSocketMaster.FinalizeProcesses", GetErrorDescription(lngErrorCode) + Else + '114 Debug.Print "OK Winsock service finalized" + End If + + Subclass_Terminate + m_blnInitiated = False + End If + + ' + Exit Function +FinalizeProcesses_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeProcesses" + Resume Next + ' +End Function + +'Return the accept instance class from a socket. +Public Function GetAcceptClass(ByVal lngSocket As Long) As CSocketMaster + ' + On Error GoTo GetAcceptClass_Err + ' + Set GetAcceptClass = m_colAcceptList("S" & lngSocket) + ' + Exit Function +GetAcceptClass_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetAcceptClass" + Resume Next + ' +End Function + +'This function receives a number that represents an error +'and returns the corresponding description string. +Public Function GetErrorDescription(ByVal lngErrorCode As Long) As String + ' + On Error GoTo GetErrorDescription_Err + + ' + Select Case lngErrorCode + + Case WSAEACCES + GetErrorDescription = "Permission denied." + + Case WSAEADDRINUSE + GetErrorDescription = "Address already in use." + + Case WSAEADDRNOTAVAIL + GetErrorDescription = "Cannot assign requested address." + + Case WSAEAFNOSUPPORT + GetErrorDescription = "Address family not supported by protocol family." + + Case WSAEALREADY + GetErrorDescription = "Operation already in progress." + + Case WSAECONNABORTED + GetErrorDescription = "Software caused connection abort." + + Case WSAECONNREFUSED + GetErrorDescription = "Connection refused." + + Case WSAECONNRESET + GetErrorDescription = "Connection reset by peer." + + Case WSAEDESTADDRREQ + GetErrorDescription = "Destination address required." + + Case WSAEFAULT + GetErrorDescription = "Bad address." + + Case WSAEHOSTUNREACH + GetErrorDescription = "No route to host." + + Case WSAEINPROGRESS + GetErrorDescription = "Operation now in progress." + + Case WSAEINTR + GetErrorDescription = "Interrupted function call." + + Case WSAEINVAL + GetErrorDescription = "Invalid argument." + + Case WSAEISCONN + GetErrorDescription = "Socket is already connected." + + Case WSAEMFILE + GetErrorDescription = "Too many open files." + + Case WSAEMSGSIZE + GetErrorDescription = "Message too long." + + Case WSAENETDOWN + GetErrorDescription = "Network is down." + + Case WSAENETRESET + GetErrorDescription = "Network dropped connection on reset." + + Case WSAENETUNREACH + GetErrorDescription = "Network is unreachable." + + Case WSAENOBUFS + GetErrorDescription = "No buffer space available." + + Case WSAENOPROTOOPT + GetErrorDescription = "Bad protocol option." + + Case WSAENOTCONN + GetErrorDescription = "Socket is not connected." + + Case WSAENOTSOCK + GetErrorDescription = "Socket operation on nonsocket." + + Case WSAEOPNOTSUPP + GetErrorDescription = "Operation not supported." + + Case WSAEPFNOSUPPORT + GetErrorDescription = "Protocol family not supported." + + Case WSAEPROCLIM + GetErrorDescription = "Too many processes." + + Case WSAEPROTONOSUPPORT + GetErrorDescription = "Protocol not supported." + + Case WSAEPROTOTYPE + GetErrorDescription = "Protocol wrong type for socket." + + Case WSAESHUTDOWN + GetErrorDescription = "Cannot send after socket shutdown." + + Case WSAESOCKTNOSUPPORT + GetErrorDescription = "Socket type not supported." + + Case WSAETIMEDOUT + GetErrorDescription = "Connection timed out." + + Case WSAEWOULDBLOCK + GetErrorDescription = "Resource temporarily unavailable." + + Case WSAHOST_NOT_FOUND + GetErrorDescription = "Host not found." + + Case WSANOTINITIALISED + GetErrorDescription = "Successful WSAStartup not yet performed." + + Case WSANO_DATA + GetErrorDescription = "Valid name, no data record of requested type." + + Case WSANO_RECOVERY + GetErrorDescription = "This is a nonrecoverable error." + + Case WSASYSNOTREADY + GetErrorDescription = "Network subsystem is unavailable." + + Case WSATRY_AGAIN + GetErrorDescription = "Non authoritative host not found." + + Case WSAVERNOTSUPPORTED + GetErrorDescription = "Winsock.dll version out of range." + + Case Else + GetErrorDescription = "Unknown error." + End Select + + ' + Exit Function +GetErrorDescription_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.GetErrorDescription" + Resume Next + ' +End Function + +'Returns the hi word from a double word. +Public Function HiWord(lngValue As Long) As Long + ' + On Error GoTo HiWord_Err + + ' + If (lngValue And &H80000000) = &H80000000 Then + HiWord = ((lngValue And &H7FFF0000) \ &H10000) Or &H8000& + Else + HiWord = (lngValue And &HFFFF0000) \ &H10000 + End If + + ' + Exit Function +HiWord_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.HiWord" + Resume Next + ' +End Function + +'This function initiates the processes needed to keep +'control of sockets. Returns 0 if it has success. +Public Function InitiateProcesses() As Long + ' + On Error GoTo InitiateProcesses_Err + ' + InitiateProcesses = 0 + m_lngSocksQuantity = m_lngSocksQuantity + 1 + + 'if the service wasn't initiated yet we do it now + If Not m_blnInitiated Then + Subclass_Initialize + m_blnInitiated = True + Dim lngResult As Long + lngResult = InitiateService + + If lngResult = 0 Then + 'Debug.Print "OK Winsock service initiated" + Else + Debug.Print "ERROR trying to initiate winsock service" + Err.Raise lngResult, "modSocketMaster.InitiateProcesses", GetErrorDescription(lngResult) + InitiateProcesses = lngResult + End If + End If + + ' + Exit Function +InitiateProcesses_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateProcesses" + Resume Next + ' +End Function + +'The function takes a Long containing a value in the range  +'of an unsigned Integer and returns an Integer that you  +'can pass to an API that requires an unsigned Integer +Public Function IntegerToUnsigned(Value As Integer) As Long + ' + On Error GoTo IntegerToUnsigned_Err + + ' + If Value < 0 Then + IntegerToUnsigned = Value + OFFSET_2 + Else + IntegerToUnsigned = Value + End If + + ' + Exit Function +IntegerToUnsigned_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IntegerToUnsigned" + Resume Next + ' +End Function + +'Returns True is lngSocket is registered on the +'accept list. +Public Function IsAcceptRegistered(ByVal lngSocket As Long) As Boolean + ' + On Error GoTo IsAcceptRegistered_Err + ' + On Error GoTo Error_Handler + m_colAcceptList.Item ("S" & lngSocket) + IsAcceptRegistered = True + Exit Function +Error_Handler: + IsAcceptRegistered = False + ' + Exit Function +IsAcceptRegistered_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsAcceptRegistered" + Resume Next + ' +End Function + +'Returns TRUE si the socket that is passed is registered +'in the colSocketsInst collection. +Public Function IsSocketRegistered(ByVal lngSocket As Long) As Boolean + ' + On Error GoTo IsSocketRegistered_Err + ' + On Error GoTo Error_Handler + m_colSocketsInst.Item ("S" & lngSocket) + IsSocketRegistered = True + Exit Function +Error_Handler: + IsSocketRegistered = False + ' + Exit Function +IsSocketRegistered_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.IsSocketRegistered" + Resume Next + ' +End Function + +'Returns the low word from a double word. +Public Function LoWord(lngValue As Long) As Long + ' + On Error GoTo LoWord_Err + ' + LoWord = (lngValue And &HFFFF&) + ' + Exit Function +LoWord_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.LoWord" + Resume Next + ' +End Function + +'Assing a temporal instance of CSocketMaster to a +'socket and register this socket to the accept list. +Public Sub RegisterAccept(ByVal lngSocket As Long) + ' + On Error GoTo RegisterAccept_Err + + ' + If m_colAcceptList Is Nothing Then + Set m_colAcceptList = New Collection + End If + + Dim Socket As CSocketMaster + Set Socket = New CSocketMaster + Socket.Accept lngSocket + m_colAcceptList.Add Socket, "S" & lngSocket + ' + Exit Sub +RegisterAccept_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterAccept" + Resume Next + ' +End Sub + +'Adds the socket to the m_colSocketsInst collection, and +'registers that socket with WSAAsyncSelect Winsock API +'function to receive network events for the socket. +'If this socket is the first one to be registered, the +'window and collection will be created in this function as well. +Public Function RegisterSocket(ByVal lngSocket As Long, _ + ByVal lngObjectPointer As Long, _ + ByVal blnEvents As Boolean) As Boolean + ' + On Error GoTo RegisterSocket_Err + + ' + If m_colSocketsInst Is Nothing Then + Set m_colSocketsInst = New Collection + + If CreateWinsockMessageWindow <> 0 Then + Err.Raise sckOutOfMemory, "modSocketMaster.RegisterSocket", "Out of memory" + End If + + Subclass_Subclass (m_lngWindowHandle) + End If + + Subclass_AddSocketMessage lngSocket, lngObjectPointer + + 'Do we need to register socket events? + If blnEvents Then + Dim lngEvents As Long + Dim lngResult As Long + Dim lngErrorCode As Long + lngEvents = FD_READ Or FD_WRITE Or FD_ACCEPT Or FD_CONNECT Or FD_CLOSE + lngResult = api_WSAAsyncSelect(lngSocket, m_lngWindowHandle, SOCKET_MESSAGE, lngEvents) + + If lngResult = SOCKET_ERROR Then + Debug.Print "ERROR trying to register events from socket " & lngSocket + lngErrorCode = Err.LastDllError + Err.Raise lngErrorCode, "modSocketMaster.RegisterSocket", GetErrorDescription(lngErrorCode) + End If + End If + + m_colSocketsInst.Add lngObjectPointer, "S" & lngSocket + RegisterSocket = True + ' + Exit Function +RegisterSocket_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.RegisterSocket" + Resume Next + ' +End Function + +'When a socket needs to resolve a hostname in asynchronous way +'it calls this function. If it has success it returns a nonzero +'number that represents the async task handle and register this +'number in the TableA list. +'Returns 0 if it fails. +Public Function ResolveHost(ByVal strHost As String, _ + ByVal lngHOSTENBuf As Long, _ + ByVal lngObjectPointer As Long) As Long + ' + On Error GoTo ResolveHost_Err + ' + Dim lngAsynHandle As Long + lngAsynHandle = api_WSAAsyncGetHostByName(m_lngWindowHandle, RESOLVE_MESSAGE, strHost, ByVal lngHOSTENBuf, MAXGETHOSTSTRUCT) + + If lngAsynHandle <> 0 Then Subclass_AddResolveMessage lngAsynHandle, lngObjectPointer + ResolveHost = lngAsynHandle + ' + Exit Function +ResolveHost_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.ResolveHost" + Resume Next + ' +End Function + +'Receives a string pointer and it turns it into a regular string. +Public Function StringFromPointer(ByVal lPointer As Long) As String + ' + On Error GoTo StringFromPointer_Err + ' + Dim strTemp As String + Dim lRetVal As Long + strTemp = String$(api_lstrlen(ByVal lPointer), 0) + lRetVal = api_lstrcpy(ByVal strTemp, ByVal lPointer) + + If lRetVal Then StringFromPointer = strTemp + ' + Exit Function +StringFromPointer_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.StringFromPointer" + Resume Next + ' +End Function + +'Unregister lngSocket from the accept list. +Public Sub UnregisterAccept(ByVal lngSocket As Long) + ' + On Error GoTo UnregisterAccept_Err + ' + m_colAcceptList.Remove "S" & lngSocket + + If m_colAcceptList.Count = 0 Then + Set m_colAcceptList = Nothing + End If + + ' + Exit Sub +UnregisterAccept_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterAccept" + Resume Next + ' +End Sub + +'When ResolveHost is called an async task handle is added +'to TableA list. Use this function to remove that record. +Public Sub UnregisterResolution(ByVal lngAsynHandle As Long) + ' + On Error GoTo UnregisterResolution_Err + ' + Subclass_DelResolveMessage lngAsynHandle + ' + Exit Sub +UnregisterResolution_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterResolution" + Resume Next + ' +End Sub + +'Removes the socket from the m_colSocketsInst collection +'If it is the last socket in that collection, the window +'and colection will be destroyed as well. +Public Sub UnregisterSocket(ByVal lngSocket As Long) + ' + On Error GoTo UnregisterSocket_Err + ' + Subclass_DelSocketMessage lngSocket + On Error Resume Next + m_colSocketsInst.Remove "S" & lngSocket + + If m_colSocketsInst.Count = 0 Then + Set m_colSocketsInst = Nothing + Subclass_UnSubclass + DestroyWinsockMessageWindow + End If + + ' + Exit Sub +UnregisterSocket_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnregisterSocket" + Resume Next + ' +End Sub + +'The function takes an unsigned Integer from and API and  +'converts it to a Long for display or arithmetic purposes +Public Function UnsignedToInteger(Value As Long) As Integer + ' + On Error GoTo UnsignedToInteger_Err + + ' + If Value < 0 Or Value >= OFFSET_2 Then Error 6 ' Overflow + If Value <= MAXINT_2 Then + UnsignedToInteger = Value + Else + UnsignedToInteger = Value - OFFSET_2 + End If + + ' + Exit Function +UnsignedToInteger_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.UnsignedToInteger" + Resume Next + ' +End Function + +'Create a window that is used to capture sockets messages. +'Returns 0 if it has success. +Private Function CreateWinsockMessageWindow() As Long + ' + On Error GoTo CreateWinsockMessageWindow_Err + ' + m_lngWindowHandle = api_CreateWindowEx(0&, "STATIC", "SOCKET_WINDOW", 0&, 0&, 0&, 0&, 0&, 0&, 0&, App.hInstance, ByVal 0&) + + If m_lngWindowHandle = 0 Then + CreateWinsockMessageWindow = sckOutOfMemory + Exit Function + Else + CreateWinsockMessageWindow = 0 + End If + + ' + Exit Function +CreateWinsockMessageWindow_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.CreateWinsockMessageWindow" + Resume Next + ' +End Function + +'Destroy the window that is used to capture sockets messages. +'Returns 0 if it has success. +Private Function DestroyWinsockMessageWindow() As Long + ' + On Error GoTo DestroyWinsockMessageWindow_Err + ' + DestroyWinsockMessageWindow = 0 + + If m_lngWindowHandle = 0 Then + Exit Function + End If + + Dim lngResult As Long + lngResult = api_DestroyWindow(m_lngWindowHandle) + + If lngResult = 0 Then + DestroyWinsockMessageWindow = sckOutOfMemory + Err.Raise sckOutOfMemory, "modSocketMaster.DestroyWinsockMessageWindow", "Out of memory" + Else + '112 Debug.Print "OK Destroyed winsock message window " & m_lngWindowHandle + m_lngWindowHandle = 0 + End If + + ' + Exit Function +DestroyWinsockMessageWindow_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.DestroyWinsockMessageWindow" + Resume Next + ' +End Function + +'Finish winsock service calling the function +'api_WSACleanup and returns the result. +Private Function FinalizeService() As Long + ' + On Error GoTo FinalizeService_Err + ' + Dim lngResultado As Long + lngResultado = api_WSACleanup + FinalizeService = lngResultado + ' + Exit Function +FinalizeService_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.FinalizeService" + Resume Next + ' +End Function + +'This function initiate the winsock service calling +'the api_WSAStartup funtion and returns resulting value. +Private Function InitiateService() As Long + ' + On Error GoTo InitiateService_Err + ' + Dim udtWSAData As WSAData + Dim lngResult As Long + lngResult = api_WSAStartup(SOCKET_VERSION_11, udtWSAData) + InitiateService = lngResult + ' + Exit Function +InitiateService_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.InitiateService" + Resume Next + ' +End Function + +Public Sub Subclass_ChangeOwner(ByVal lngSocket As Long, _ + ByVal lngObjectPointer As Long) + ' + On Error GoTo Subclass_ChangeOwner_Err + ' + Dim Count As Long + + For Count = 1 To lngMsgCntB + + If lngTableB1(Count) = lngSocket Then + lngTableB2(Count) = lngObjectPointer + Exit Sub + End If + + Next + + ' + Exit Sub +Subclass_ChangeOwner_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_ChangeOwner" + Resume Next + ' +End Sub + +Private Sub Subclass_AddResolveMessage(ByVal lngAsync As Long, _ + ByVal lngObjectPointer As Long) + ' + On Error GoTo Subclass_AddResolveMessage_Err + ' + Dim Count As Long + + For Count = 1 To lngMsgCntA + + Select Case lngTableA1(Count) + + Case -1 + lngTableA1(Count) = lngAsync + lngTableA2(Count) = lngObjectPointer + Exit Sub + + Case lngAsync + Exit Sub + End Select + + Next + + lngMsgCntA = lngMsgCntA + 1 + ReDim Preserve lngTableA1(1 To lngMsgCntA) + ReDim Preserve lngTableA2(1 To lngMsgCntA) + lngTableA1(lngMsgCntA) = lngAsync + lngTableA2(lngMsgCntA) = lngObjectPointer + Subclass_PatchTableA + ' + Exit Sub +Subclass_AddResolveMessage_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddResolveMessage" + Resume Next + ' +End Sub + +'Return the address of the passed function in the passed dll +Private Function Subclass_AddrFunc(ByVal sDLL As String, _ + ByVal sProc As String) As Long + ' + On Error GoTo Subclass_AddrFunc_Err + ' + Subclass_AddrFunc = api_GetProcAddress(api_GetModuleHandle(sDLL), sProc) + ' + Exit Function +Subclass_AddrFunc_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrFunc" + Resume Next + ' +End Function + +'Return the address of the low bound of the passed table array +Private Function Subclass_AddrMsgTbl(ByRef aMsgTbl() As Long) As Long + ' + On Error GoTo Subclass_AddrMsgTbl_Err + ' + On Error Resume Next 'The table may not be dimensioned yet so we need protection + Subclass_AddrMsgTbl = VarPtr(aMsgTbl(1)) 'Get the address of the first element of the passed message table + On Error GoTo Subclass_AddrMsgTbl_Err 'Switch off error protection + ' + Exit Function +Subclass_AddrMsgTbl_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddrMsgTbl" + Resume Next + ' +End Function + +Private Sub Subclass_AddSocketMessage(ByVal lngSocket As Long, _ + ByVal lngObjectPointer As Long) + ' + On Error GoTo Subclass_AddSocketMessage_Err + ' + Dim Count As Long + + For Count = 1 To lngMsgCntB + + Select Case lngTableB1(Count) + + Case -1 + lngTableB1(Count) = lngSocket + lngTableB2(Count) = lngObjectPointer + Exit Sub + + Case lngSocket + Exit Sub + End Select + + Next + + lngMsgCntB = lngMsgCntB + 1 + ReDim Preserve lngTableB1(1 To lngMsgCntB) + ReDim Preserve lngTableB2(1 To lngMsgCntB) + lngTableB1(lngMsgCntB) = lngSocket + lngTableB2(lngMsgCntB) = lngObjectPointer + Subclass_PatchTableB + ' + Exit Sub +Subclass_AddSocketMessage_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_AddSocketMessage" + Resume Next + ' +End Sub + +Private Sub Subclass_DelResolveMessage(ByVal lngAsync As Long) + ' + On Error GoTo Subclass_DelResolveMessage_Err + ' + Dim Count As Long + + For Count = 1 To lngMsgCntA + + If lngTableA1(Count) = lngAsync Then + lngTableA1(Count) = -1 + lngTableA2(Count) = -1 + Exit Sub + End If + + Next + + ' + Exit Sub +Subclass_DelResolveMessage_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelResolveMessage" + Resume Next + ' +End Sub + +Private Sub Subclass_DelSocketMessage(ByVal lngSocket As Long) + ' + On Error GoTo Subclass_DelSocketMessage_Err + ' + Dim Count As Long + + For Count = 1 To lngMsgCntB + + If lngTableB1(Count) = lngSocket Then + lngTableB1(Count) = -1 + lngTableB2(Count) = -1 + Exit Sub + End If + + Next + + ' + Exit Sub +Subclass_DelSocketMessage_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_DelSocketMessage" + Resume Next + ' +End Sub + +'Return whether we're running in the IDE. Public for general utility purposes +Private Function Subclass_InIDE() As Boolean + ' + On Error GoTo Subclass_InIDE_Err + ' + Debug.Assert Subclass_SetTrue(Subclass_InIDE) + ' + Exit Function +Subclass_InIDE_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_InIDE" + Resume Next + ' +End Function + +'============================================================================== +'SUBCLASSING CODE +'based on code by Paul Caton +'============================================================================== +Private Sub Subclass_Initialize() + ' + On Error GoTo Subclass_Initialize_Err + ' + Const PATCH_01 As Long = 15 'Code buffer offset to the location of the relative address to EbMode + Const PATCH_03 As Long = 76 'Relative address of SetWindowsLong + Const PATCH_05 As Long = 100 'Relative address of CallWindowProc + Const 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 + Const 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 + Const FUNC_CWP As String = "CallWindowProcA" 'We use CallWindowProc to call the original WndProc + Const MOD_VBA5 As String = "vba5" 'Location of the EbMode function if running VB5 + Const MOD_VBA6 As String = "vba6" 'Location of the EbMode function if running VB6 + Const MOD_USER As String = "user32" 'Location of the SetWindowLong & CallWindowProc functions + Dim i As Long 'Loop index + Dim nLen As Long 'String lengths + Dim sHex As String 'Hex code string + Dim sCode As String 'Binary code string + 'Store the hex pair machine code representation in sHex + sHex = "5850505589E55753515231C0EB0EE8xxxxx01x83F802742285C074258B45103D0080000074433D01800000745BE8200000005A595B5FC9C21400E813000000EBF168xxxxx02x6AFCFF750CE8xxxxx03xEBE0FF7518FF7514FF7510FF750C68xxxxx04xE8xxxxx05xC3BBxxxxx06x8B4514BFxxxxx07x89D9F2AF75B629CB4B8B1C9Dxxxxx08xEB1DBBxxxxx09x8B4514BFxxxxx0Ax89D9F2AF759729CB4B8B1C9Dxxxxx0Bx895D088B1B8B5B1C89D85A595B5FC9FFE0" + nLen = Len(sHex) 'Length of hex pair string + + 'Convert the string from hex pairs to bytes and store in the ASCII string opcode buffer + For i = 1 To nLen Step 2 'For each pair of hex characters + sCode = sCode & ChrB$(Val("&H" & Mid$(sHex, i, 2))) 'Convert a pair of hex characters to a byte and append to the ASCII string + Next 'Next pair + + nLen = LenB(sCode) 'Get the machine code length + nAddrSubclass = api_GlobalAlloc(0, nLen) 'Allocate fixed memory for machine code buffer + 'Copy the code to allocated memory + Call api_CopyMemory(ByVal nAddrSubclass, ByVal StrPtr(sCode), nLen) + + If Subclass_InIDE Then + 'Patch the jmp (EB0E) with two nop's (90) enabling the IDE breakpoint/stop checking code + Call api_CopyMemory(ByVal nAddrSubclass + 12, &H9090, 2) + i = Subclass_AddrFunc(MOD_VBA6, FUNC_EBM) 'Get the address of EbMode in vba6.dll + + If i = 0 Then 'Found? + i = Subclass_AddrFunc(MOD_VBA5, FUNC_EBM) 'VB5 perhaps, try vba5.dll + End If + + Debug.Assert i 'Ensure the EbMode function was found + Call Subclass_PatchRel(PATCH_01, i) 'Patch the relative address to the EbMode api function + End If + + Call Subclass_PatchRel(PATCH_03, Subclass_AddrFunc(MOD_USER, FUNC_SWL)) 'Address of the SetWindowLong api function + Call Subclass_PatchRel(PATCH_05, Subclass_AddrFunc(MOD_USER, FUNC_CWP)) 'Address of the CallWindowProc api function + ' + Exit Sub +Subclass_Initialize_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Initialize" + Resume Next + ' +End Sub + +'Patch the machine code buffer offset with the relative address to the target address +Private Sub Subclass_PatchRel(ByVal nOffset As Long, _ + ByVal nTargetAddr As Long) + ' + On Error GoTo Subclass_PatchRel_Err + ' + Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nTargetAddr - nAddrSubclass - nOffset - 4, 4) + ' + Exit Sub +Subclass_PatchRel_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchRel" + Resume Next + ' +End Sub + +Private Sub Subclass_PatchTableA() + ' + On Error GoTo Subclass_PatchTableA_Err + ' + Const PATCH_07 As Long = 114 + Const PATCH_08 As Long = 130 + Call Subclass_PatchVal(PATCH_06, lngMsgCntA) + Call Subclass_PatchVal(PATCH_07, Subclass_AddrMsgTbl(lngTableA1)) + Call Subclass_PatchVal(PATCH_08, Subclass_AddrMsgTbl(lngTableA2)) + ' + Exit Sub +Subclass_PatchTableA_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableA" + Resume Next + ' +End Sub + +Private Sub Subclass_PatchTableB() + ' + On Error GoTo Subclass_PatchTableB_Err + ' + Const PATCH_0A As Long = 145 + Const PATCH_0B As Long = 161 + Call Subclass_PatchVal(PATCH_09, lngMsgCntB) + Call Subclass_PatchVal(PATCH_0A, Subclass_AddrMsgTbl(lngTableB1)) + Call Subclass_PatchVal(PATCH_0B, Subclass_AddrMsgTbl(lngTableB2)) + ' + Exit Sub +Subclass_PatchTableB_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchTableB" + Resume Next + ' +End Sub + +'Patch the machine code buffer offset with the passed value +Private Sub Subclass_PatchVal(ByVal nOffset As Long, _ + ByVal nValue As Long) + ' + On Error GoTo Subclass_PatchVal_Err + ' + Call api_CopyMemory(ByVal (nAddrSubclass + nOffset), nValue, 4) + ' + Exit Sub +Subclass_PatchVal_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_PatchVal" + Resume Next + ' +End Sub + +'Worker function for InIDE - will only be called whilst running in the IDE +Private Function Subclass_SetTrue(bValue As Boolean) As Boolean + ' + On Error GoTo Subclass_SetTrue_Err + ' + Subclass_SetTrue = True + bValue = True + ' + Exit Function +Subclass_SetTrue_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_SetTrue" + Resume Next + ' +End Function + +'Set the window subclass +Private Function Subclass_Subclass(ByVal hWnd As Long) As Boolean + ' + On Error GoTo Subclass_Subclass_Err + ' + Const PATCH_02 As Long = 66 'Address of the previous WndProc + Const PATCH_04 As Long = 95 'Address of the previous WndProc + + If hWndSub = 0 Then + Debug.Assert api_IsWindow(hWnd) 'Invalid window handle + hWndSub = hWnd 'Store the window handle + 'Get the original window proc + nAddrOriginal = api_GetWindowLong(hWnd, GWL_WNDPROC) + Call Subclass_PatchVal(PATCH_02, nAddrOriginal) 'Original WndProc address for CallWindowProc, call the original WndProc + Call Subclass_PatchVal(PATCH_04, nAddrOriginal) 'Original WndProc address for SetWindowLong, unsubclass on IDE stop + 'Set our WndProc in place of the original + nAddrOriginal = api_SetWindowLong(hWnd, GWL_WNDPROC, nAddrSubclass) + + If nAddrOriginal <> 0 Then + nAddrOriginal = 0 + Subclass_Subclass = True 'Success + End If + End If + + Debug.Assert Subclass_Subclass + ' + Exit Function +Subclass_Subclass_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Subclass" + Resume Next + ' +End Function + +'UnSubclass and release the allocated memory +Private Sub Subclass_Terminate() + ' + On Error GoTo Subclass_Terminate_Err + ' + Call Subclass_UnSubclass 'UnSubclass if the Subclass thunk is active + Call api_GlobalFree(nAddrSubclass) 'Release the allocated memory + nAddrSubclass = 0 + ReDim lngTableA1(1 To 1) + ReDim lngTableA2(1 To 1) + ReDim lngTableB1(1 To 1) + ReDim lngTableB2(1 To 1) + ' + Exit Sub +Subclass_Terminate_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_Terminate" + Resume Next + ' +End Sub + +'Stop subclassing the window +Private Function Subclass_UnSubclass() As Boolean + ' + On Error GoTo Subclass_UnSubclass_Err + + ' + If hWndSub <> 0 Then + lngMsgCntA = 0 + lngMsgCntB = 0 + Call Subclass_PatchVal(PATCH_06, lngMsgCntA) 'Patch the TableA entry count to ensure no further Proc callbacks + Call Subclass_PatchVal(PATCH_09, lngMsgCntB) 'Patch the TableB entry count to ensure no further Proc callbacks + 'Restore the original WndProc + Call api_SetWindowLong(hWndSub, GWL_WNDPROC, nAddrOriginal) + hWndSub = 0 'Indicate the subclasser is inactive + Subclass_UnSubclass = True 'Success + End If + + ' + Exit Function +Subclass_UnSubclass_Err: + Controlar_Error Erl, Err.Description, "Reseter.modSocketMaster.Subclass_UnSubclass" + Resume Next + ' +End Function diff --git a/Reseter.vbp b/Reseter.vbp index ba87970..2920e88 100755 --- a/Reseter.vbp +++ b/Reseter.vbp @@ -31,7 +31,7 @@ HelpContextID="0" CompatibleMode="0" MajorVer=4 MinorVer=0 -RevisionVer=17 +RevisionVer=18 AutoIncrementVer=1 ServerSupportFiles=0 VersionComments="Hecho en El Salvador" diff --git a/bas/Ajustes.bas b/bas/Ajustes.bas index 903407b..5043c30 100755 --- a/bas/Ajustes.bas +++ b/bas/Ajustes.bas @@ -25,34 +25,34 @@ Public ModoLinux As Boolean Public Function LeerINI(nSeccion As String, _ nClave As String, _ Optional nValor As String = vbNullString) As String - ' - On Error GoTo LeerINI_Err - ' - Dim Buffer As String * 32767 - Dim Lgt As Long -100 Buffer = String$(32767, vbNullChar) -101 Lgt = GetPrivateProfileString(nSeccion, nClave, nValor, Buffer, Len(Buffer), rINI_OPCIONES) + ' + On Error GoTo LeerINI_Err + ' + Dim Buffer As String * 32767 + Dim Lgt As Long + Buffer = String$(32767, vbNullChar) + Lgt = GetPrivateProfileString(nSeccion, nClave, nValor, Buffer, Len(Buffer), rINI_OPCIONES) -102 If Lgt Then LeerINI = Left$(Buffer, Lgt) Else LeerINI = vbNullString - ' - Exit Function + If Lgt Then LeerINI = Left$(Buffer, Lgt) Else LeerINI = vbNullString + ' + Exit Function LeerINI_Err: - Controlar_Error Erl, Err.Description, "Reseter.Ajustes.LeerINI.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.Ajustes.LeerINI" + Resume Next + ' End Function Public Sub EscribirINI(nSeccion As String, _ nClave As String, _ ByVal nValor As String) - ' - On Error GoTo EscribirINI_Err - ' -100 WritePrivateProfileString nSeccion, nClave, nValor, rINI_OPCIONES - ' - Exit Sub + ' + On Error GoTo EscribirINI_Err + ' + WritePrivateProfileString nSeccion, nClave, nValor, rINI_OPCIONES + ' + Exit Sub EscribirINI_Err: - Controlar_Error Erl, Err.Description, "Reseter.Ajustes.EscribirINI.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.Ajustes.EscribirINI" + Resume Next + ' End Sub diff --git a/bas/ConfIO.bas b/bas/ConfIO.bas index 92af9c6..a31f419 100755 --- a/bas/ConfIO.bas +++ b/bas/ConfIO.bas @@ -29,125 +29,125 @@ Private Declare Function GetPrivateProfileSection _ Private Const IO_codigo As String = "Codigo" Public Sub Obtener_Lista_Externa() - 'Lista - ' - On Error GoTo Obtener_Lista_Externa_Err - ' - Dim Modelos() As String - Dim szBuf As String, lLen As Integer -100 'Registrar "Cargando perfiles de dispositivos soportados..." - 'Obtenemos los nombres de todas las secciones, vienen separadas por NullChar Chr(0) -101 szBuf = String$(32767, vbNullChar) 'Creamos el buffer -102 lLen = GetPrivateProfileSectionNames(szBuf, Len(szBuf), rINI_ROUTERS) 'Obtenemos el largo del la lectura -103 szBuf = Left$(szBuf, lLen) 'Cortamos lo innecesario + 'Lista + ' + On Error GoTo Obtener_Lista_Externa_Err + ' + Dim Modelos() As String + Dim szBuf As String, lLen As Integer + 'Registrar "Cargando perfiles de dispositivos soportados..." + 'Obtenemos los nombres de todas las secciones, vienen separadas por NullChar Chr(0) + szBuf = String$(32767, vbNullChar) 'Creamos el buffer + lLen = GetPrivateProfileSectionNames(szBuf, Len(szBuf), rINI_ROUTERS) 'Obtenemos el largo del la lectura + szBuf = Left$(szBuf, lLen) 'Cortamos lo innecesario -104 If szBuf = vbNullString Then - Exit Sub - End If + If szBuf = vbNullString Then + Exit Sub + End If -105 Modelos = Split(szBuf, vbNullChar) -106 ReDim Preserve Modelos(UBound(Modelos) - 1) As String - Dim i As Long 'Para el contador - Dim a As Long 'Total de modelos -107 a = UBound(Modelos) + Modelos = Split(szBuf, vbNullChar) + ReDim Preserve Modelos(UBound(Modelos) - 1) As String + Dim i As Long 'Para el contador + Dim a As Long 'Total de modelos + a = UBound(Modelos) -108 For i = 0 To a -109 frmPrincipal.ComReset.AddItem Modelos(i) - Next + For i = 0 To a + frmPrincipal.ComReset.AddItem Modelos(i) + Next -110 Registrar "+" & a & " perfiles cargados" - ' - Exit Sub + Registrar "+" & a & " perfiles cargados" + ' + Exit Sub Obtener_Lista_Externa_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Obtener_Lista_Externa.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Obtener_Lista_Externa" + Resume Next + ' End Sub Public Sub Memoria_IO(nRouter As String) - 'De la memoria al archivo - ' - On Error GoTo Memoria_IO_Err + 'De la memoria al archivo + ' + On Error GoTo Memoria_IO_Err - ' -100 With frmPrincipal -101 Escribir nRouter, IO_codigo, m_Datos.codigo - End With + ' + With frmPrincipal + Escribir nRouter, IO_codigo, m_Datos.codigo + End With - ' - Exit Sub + ' + Exit Sub Memoria_IO_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Memoria_IO.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Memoria_IO" + Resume Next + ' End Sub Public Sub IO_Memoria(nRouter As String) - 'Del archivo a la memoria - ' - On Error GoTo IO_Memoria_Err + 'Del archivo a la memoria + ' + On Error GoTo IO_Memoria_Err - ' -100 With frmPrincipal -101 m_Datos.codigo = Leer(nRouter, IO_codigo) - End With + ' + With frmPrincipal + m_Datos.codigo = Leer(nRouter, IO_codigo) + End With -102 Mostrar_Datos - ' - Exit Sub + Mostrar_Datos + ' + Exit Sub IO_Memoria_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.IO_Memoria.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.IO_Memoria" + Resume Next + ' End Sub Private Function Leer(nRouter As String, _ nEspecificacion As String, _ Optional nValor As String = vbNullString) As String - ' - On Error GoTo Leer_Err - ' - Dim Buffer As String * 32767 - Dim Lgt As Long -100 Buffer = String$(32767, vbNullChar) -101 Lgt = GetPrivateProfileString(nRouter, nEspecificacion, nValor, Buffer, Len(Buffer), rINI_ROUTERS) + ' + On Error GoTo Leer_Err + ' + Dim Buffer As String * 32767 + Dim Lgt As Long + Buffer = String$(32767, vbNullChar) + Lgt = GetPrivateProfileString(nRouter, nEspecificacion, nValor, Buffer, Len(Buffer), rINI_ROUTERS) -102 If Lgt Then Leer = Left$(Buffer, Lgt) Else Leer = vbNullString - ' - Exit Function + If Lgt Then Leer = Left$(Buffer, Lgt) Else Leer = vbNullString + ' + Exit Function Leer_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Leer.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Leer" + Resume Next + ' End Function Private Sub Escribir(nRouter As String, _ nEspecificacion As String, _ ByVal nValor As String) - ' - On Error GoTo Escribir_Err - ' -100 WritePrivateProfileString nRouter, nEspecificacion, nValor, rINI_ROUTERS - ' - Exit Sub + ' + On Error GoTo Escribir_Err + ' + WritePrivateProfileString nRouter, nEspecificacion, nValor, rINI_ROUTERS + ' + Exit Sub Escribir_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Escribir.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Escribir" + Resume Next + ' End Sub Public Function Existe_Seccion(nRouter As String) As Boolean - '28/04/07 -> nRouter definido como String en lugar de Variant - ' - On Error GoTo Existe_Seccion_Err - ' - Dim Buffer As String -100 Buffer = String$(32767, Chr$(0)) -101 Existe_Seccion = GetPrivateProfileSection(nRouter, Buffer, Len(Buffer), rINI_ROUTERS) - ' - Exit Function + '28/04/07 -> nRouter definido como String en lugar de Variant + ' + On Error GoTo Existe_Seccion_Err + ' + Dim Buffer As String + Buffer = String$(32767, Chr$(0)) + Existe_Seccion = GetPrivateProfileSection(nRouter, Buffer, Len(Buffer), rINI_ROUTERS) + ' + Exit Function Existe_Seccion_Err: - Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Existe_Seccion.Ref 12/8/2008 : 08:11:20" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.ConfIO.Existe_Seccion" + Resume Next + ' End Function diff --git a/bas/DIBUJO.bas b/bas/DIBUJO.bas dissimilarity index 88% index 839f0a0..aca9997 100755 --- a/bas/DIBUJO.bas +++ b/bas/DIBUJO.bas @@ -1,227 +1,227 @@ -Attribute VB_Name = "GUI" -Option Explicit -' Este archivo es parte del programa "reseter", el cúal es pertenece a SVCommunity.org y a Todosv.com -' Mantenedores principales: -' *Vlad -Rem Detener la actualización de las ventanas -Public Declare Function LockWindowUpdate _ - Lib "user32" (ByVal hwndLock As Long) As Long -Private Type tagInitCommonControlsEx - lngSize As Long - lngICC As Long -End Type -Private Declare Function InitCommonControlsEx _ - Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean -Private Const ICC_USEREX_CLASSES = &H200 - -Public Sub Colorear(Destino As Object) - ' - On Error GoTo Colorear_Err - ' - Dim c As Control - Dim cControles As Object -100 LockWindowUpdate Destino.hdc -101 Destino.BackColor = vbWhite -102 Set cControles = Destino.Controls - -103 With c - -104 For Each c In cControles - -105 If c.Tag = -1 Then GoTo NoProcesar - -106 Select Case TypeName(c) - - Case "Label" - -107 Select Case c.Tag - - Case "" -108 c.ForeColor = &HC00000 -109 c.BackColor = vbWhite -110 c.BorderStyle = 0 -111 c.Font = "Verdana" -112 c.FontBold = True -113 c.FontSize = 12 -114 c.BackStyle = 0 - -115 Case 1 -116 c.ForeColor = &H777777 -117 c.BackColor = vbWhite -118 c.BorderStyle = 0 -119 c.Font = "Arial" -120 c.FontBold = False -121 c.FontSize = 10 - -122 Case 2 -123 c.ForeColor = vbBlack -124 c.BackColor = vbWhite -125 c.BorderStyle = 1 -126 c.Font = "Courier New" -127 c.FontBold = False -128 c.FontSize = 8 - -129 Case 3 -130 c.ForeColor = vbBlack -131 c.BackColor = vbWhite -132 c.BorderStyle = 0 -133 c.Font = "Courier New" -134 c.FontBold = False -135 c.FontSize = 8 - -136 Case 4 -137 c.ForeColor = vbBlue -138 c.BackColor = vbWhite -139 c.BorderStyle = 0 -140 c.Font = "MS Sans Serif" -141 c.FontBold = True -142 c.FontSize = 8 - -143 Case 5 -144 c.ForeColor = vbBlack -145 c.BackColor = vbWhite -146 c.BorderStyle = 0 -147 c.Font = "Arial" -148 c.FontBold = False -149 c.FontSize = 8 - End Select - -150 Case "CheckBox" -151 c.Alignment = 1 -152 c.Appearance = 1 -153 c.BackColor = vbWhite - -154 Case "OptionButton" -155 c.Alignment = 1 -156 c.Appearance = 1 -157 c.BackColor = vbWhite - -158 Case "CommandButton" - -159 Select Case c.Tag - - Case "" -160 c.BackColor = &HAAAAAA -161 c.Font = "Courier New" -162 c.FontBold = True -163 c.Font.Size = 10 - -164 Case 1 -165 c.Font = "Courier New" -166 c.FontBold = False -167 c.Font.Size = 8 - End Select - -168 Case "TextBox" - -169 Select Case c.Tag - - Case "" -170 c.Font = "Courier New" -171 c.FontSize = 10 -172 c.FontBold = False -173 c.ForeColor = &HC00000 -174 c.BackColor = &HFFFAFA -175 c.BorderStyle = 1 - -176 Case 1 -177 c.ForeColor = vbRed -178 c.BackColor = &HFFFAFA -179 c.BorderStyle = 1 -180 c.Appearance = 1 -181 c.Font = "Courier New" -182 c.FontBold = False -183 c.FontSize = 8 - End Select - -184 Case "Frame" -185 c.Font = "Arial" -186 c.BorderStyle = 1 -187 c.ForeColor = &HC00000 -188 c.BackColor = vbWhite -189 c.FontSize = 12 -190 c.FontBold = False - -191 Case "ListView" -192 c.Font = "Courier New" -193 c.Font.Size = 9 -194 c.Font.Bold = False -195 c.ForeColor = &HC00000 -196 c.BackColor = &HFFFAFA -197 c.BorderStyle = 1 - -198 Case "PictureBox" -199 c.BackColor = vbWhite - -200 Case "ComboBox" -201 c.ForeColor = &H777777 -202 c.BackColor = vbWhite -203 c.Font = "Arial" -204 c.FontBold = False -205 c.FontSize = 10 - End Select - -NoProcesar: - Next - - End With - -206 LockWindowUpdate 0 - ' - Exit Sub -Colorear_Err: - Controlar_Error Erl, Err.Description, "Reseter.GUI.Colorear.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Public Sub Mostrar_Datos() - ' - On Error GoTo Mostrar_Datos_Err - - ' -100 With frmPrincipal -101 .txtCodigos.Text = Replace(m_Datos.codigo, Chr(254), vbNewLine) - End With - - ' - Exit Sub -Mostrar_Datos_Err: - Controlar_Error Erl, Err.Description, "Reseter.GUI.Mostrar_Datos.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Public Sub lpActualizar() - ' - On Error GoTo lpActualizar_Err - ' - Dim Buff As Double -100 Buff = Tiempo.Elapsed -101 frmPrincipal.lblTW.Caption = Fix((Umbral_EsperarInternetMax - Buff) / 1000) - -102 If Buff > Umbral_EsperarInternetMax Or NetError Then pSocket.error = True - ' - Exit Sub -lpActualizar_Err: - Controlar_Error Erl, Err.Description, "Reseter.GUI.lpActualizar.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Public Sub Registrar(ByVal Texto As String, _ - Optional compat As Integer = 0) - ' - On Error GoTo Registrar_Err - - ' -100 If compat > 2 Then Exit Sub -101 frmPrincipal.txtSalida.Text = frmPrincipal.txtSalida & Time$ & " " & Texto & vbNewLine -102 frmPrincipal.txtSalida.SelStart = Len(frmPrincipal.txtSalida.Text) - ' - Exit Sub -Registrar_Err: - Controlar_Error Erl, Err.Description, "Reseter.GUI.Registrar.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub +Attribute VB_Name = "GUI" +Option Explicit +' Este archivo es parte del programa "reseter", el cúal es pertenece a SVCommunity.org y a Todosv.com +' Mantenedores principales: +' *Vlad +Rem Detener la actualización de las ventanas +Public Declare Function LockWindowUpdate _ + Lib "user32" (ByVal hwndLock As Long) As Long +Private Type tagInitCommonControlsEx + lngSize As Long + lngICC As Long +End Type +Private Declare Function InitCommonControlsEx _ + Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean +Private Const ICC_USEREX_CLASSES = &H200 + +Public Sub Colorear(Destino As Object) + ' + On Error GoTo Colorear_Err + ' + Dim c As Control + Dim cControles As Object + LockWindowUpdate Destino.hdc + Destino.BackColor = vbWhite + Set cControles = Destino.Controls + + With c + + For Each c In cControles + + If c.Tag = -1 Then GoTo NoProcesar + + Select Case TypeName(c) + + Case "Label" + + Select Case c.Tag + + Case "" + c.ForeColor = &HC00000 + c.BackColor = vbWhite + c.BorderStyle = 0 + c.Font = "Verdana" + c.FontBold = True + c.FontSize = 12 + c.BackStyle = 0 + + Case 1 + c.ForeColor = &H777777 + c.BackColor = vbWhite + c.BorderStyle = 0 + c.Font = "Arial" + c.FontBold = False + c.FontSize = 10 + + Case 2 + c.ForeColor = vbBlack + c.BackColor = vbWhite + c.BorderStyle = 1 + c.Font = "Courier New" + c.FontBold = False + c.FontSize = 8 + + Case 3 + c.ForeColor = vbBlack + c.BackColor = vbWhite + c.BorderStyle = 0 + c.Font = "Courier New" + c.FontBold = False + c.FontSize = 8 + + Case 4 + c.ForeColor = vbBlue + c.BackColor = vbWhite + c.BorderStyle = 0 + c.Font = "MS Sans Serif" + c.FontBold = True + c.FontSize = 8 + + Case 5 + c.ForeColor = vbBlack + c.BackColor = vbWhite + c.BorderStyle = 0 + c.Font = "Arial" + c.FontBold = False + c.FontSize = 8 + End Select + + Case "CheckBox" + c.Alignment = 1 + c.Appearance = 1 + c.BackColor = vbWhite + + Case "OptionButton" + c.Alignment = 1 + c.Appearance = 1 + c.BackColor = vbWhite + + Case "CommandButton" + + Select Case c.Tag + + Case "" + c.BackColor = &HAAAAAA + c.Font = "Courier New" + c.FontBold = True + c.Font.Size = 10 + + Case 1 + c.Font = "Courier New" + c.FontBold = False + c.Font.Size = 8 + End Select + + Case "TextBox" + + Select Case c.Tag + + Case "" + c.Font = "Courier New" + c.FontSize = 10 + c.FontBold = False + c.ForeColor = &HC00000 + c.BackColor = &HFFFAFA + c.BorderStyle = 1 + + Case 1 + c.ForeColor = vbRed + c.BackColor = &HFFFAFA + c.BorderStyle = 1 + c.Appearance = 1 + c.Font = "Courier New" + c.FontBold = False + c.FontSize = 8 + End Select + + Case "Frame" + c.Font = "Arial" + c.BorderStyle = 1 + c.ForeColor = &HC00000 + c.BackColor = vbWhite + c.FontSize = 12 + c.FontBold = False + + Case "ListView" + c.Font = "Courier New" + c.Font.Size = 9 + c.Font.Bold = False + c.ForeColor = &HC00000 + c.BackColor = &HFFFAFA + c.BorderStyle = 1 + + Case "PictureBox" + c.BackColor = vbWhite + + Case "ComboBox" + c.ForeColor = &H777777 + c.BackColor = vbWhite + c.Font = "Arial" + c.FontBold = False + c.FontSize = 10 + End Select + +NoProcesar: + Next + + End With + + LockWindowUpdate 0 + ' + Exit Sub +Colorear_Err: + Controlar_Error Erl, Err.Description, "Reseter.GUI.Colorear" + Resume Next + ' +End Sub + +Public Sub Mostrar_Datos() + ' + On Error GoTo Mostrar_Datos_Err + + ' + With frmPrincipal + .txtCodigos.Text = Replace(m_Datos.codigo, Chr(254), vbNewLine) + End With + + ' + Exit Sub +Mostrar_Datos_Err: + Controlar_Error Erl, Err.Description, "Reseter.GUI.Mostrar_Datos" + Resume Next + ' +End Sub + +Public Sub lpActualizar() + ' + On Error GoTo lpActualizar_Err + ' + Dim Buff As Double + Buff = Tiempo.Elapsed + frmPrincipal.lblTW.Caption = Fix((Umbral_EsperarInternetMax - Buff) / 1000) + + If Buff > Umbral_EsperarInternetMax Or NetError Then pSocket.error = True + ' + Exit Sub +lpActualizar_Err: + Controlar_Error Erl, Err.Description, "Reseter.GUI.lpActualizar" + Resume Next + ' +End Sub + +Public Sub Registrar(ByVal Texto As String, _ + Optional compat As Integer = 0) + ' + On Error GoTo Registrar_Err + + ' + If compat > 2 Then Exit Sub + frmPrincipal.txtSalida.Text = frmPrincipal.txtSalida & Time$ & " " & Texto & vbNewLine + frmPrincipal.txtSalida.SelStart = Len(frmPrincipal.txtSalida.Text) + ' + Exit Sub +Registrar_Err: + Controlar_Error Erl, Err.Description, "Reseter.GUI.Registrar" + Resume Next + ' +End Sub diff --git a/bas/Global.bas b/bas/Global.bas dissimilarity index 86% index 6d3a734..5bb53e8 100755 --- a/bas/Global.bas +++ b/bas/Global.bas @@ -1,750 +1,750 @@ -Attribute VB_Name = "Global" -Option Explicit -' "Reseter", Copyright 2006-2007 TodoSV.com -' Licencia adicional a: www.svcommunity.org y www.untercio.net -' Mantenedores principales: -' *Vlad -' *Kikeuntercio -' Para soporte, dudas, consultas, inquitudes y demás: -' http://foro.todosv.com/reseter/ -' http://www.svcommunity.org/forum/index.php?topic=25095.0 -' http://www.svcommunity.org/forum/index.php?topic=59743.0 -Private TiempoMax As Double -'Tipo -Enum e_Acceso - web - telnet - auro -End Enum -Enum e_AccionEX - ed_clic - ed_java - ed_llenar - ed_navegar -End Enum -Type t_Datos - Direccion As String 'Dirección a navegar - usuario As String 'Usuario del router - clave As String 'Clave del usuario del router - base As String 'Dirección de la puerta de enlace - puerto As Long 'Puerto de acceso - nForm As Integer - nCont As Integer - accionTipo As e_AccionEX - accionEX As String - accionEX2 As String - codigo As String 'Lista de codigos a ejecutarse - tipoAcceso As e_Acceso 'Tipo de acceso [Telnet | Web] - renovar As Boolean 'Ejecutar renovación de IP - asumirDes As Boolean 'Asumir desconexion o probar? -End Type -Public m_Datos As t_Datos -Public flag_Navegar As Boolean -Public IE As Object -Public TelnetComandos() As String -Public nComando As Integer -Public NetError As Boolean -Private Intentos_Realizados As Byte -Public pSocket As AuroNet -Public ppSocket As AuroNet -Public Tiempo As cTimer 'Uso general -Public TiempoEx As cTimer 'Uso secundario -Public TiempoEx2 As New cTimer 'Uso terciario -Public dXMR As String -Public dXMR_ok As Boolean - -Public Sub Main() - 'Activar_Temas_XP - 'Rutas de archivos - '------------------------ - ' - On Error GoTo Main_Err - ' -100 Set Tiempo = New cTimer -101 Set TiempoEx = New cTimer - 'Empezamos a medir el tiempo que tarda en iniciar el programa -102 Tiempo.StartTimer - '------------------------ - 'Iniciamos los Sockets -103 Set pSocket = New AuroNet -104 Set ppSocket = New AuroNet -105 pSocket.Direccion = PaginaIP -106 ppSocket.Direccion = "www.google.com" - '------------------------ -107 EthInfo - '------------------------ - 'Fichero INI con las opciones del programa -108 rINI_OPCIONES = App.Path & "\Reseter.ini" - 'Fichero INI con los códigos de reseteo para los routers -109 rINI_ROUTERS = App.Path & "\Routers.ini" - '------------------------ -110 Quieto = LeerINI("Opciones", "Quieto", False) - 'Será que es mejor no iniciar el Objeto IE? - 'Esto es util cuando se ha desinstalado el Explorer o en Wine -111 NoIE = LeerINI("Opciones", "NoIE", False) -112 ModoLinux = LeerINI("Opciones", "Linux:Compatibilidad", False) - '------------------------ -113 frmPrincipal.Show - -114 DoEvents - '------------------------ -115 Registrar "Iniciando Reseter: " & App.Major & "." & App.Minor & "." & App.Revision & " " & EstadoVer -116 Registrar "Propiedad de todosv.com, svcommunity.org y untercio.net" -117 Registrar "Información: http://foro.todosv.com/reseter/" -118 Registrar "IP pública gracias a " & ObtenerDominio(PaginaIP) - - '------------------------ - 'Objeto IE -119 If NoIE Then -120 Registrar "+Objeto IE: NoIE establecido." - Else -121 Crear_Objeto_IE - End If - -122 Registrar "+IP Local: " & pSocket.IpLocal -123 Registrar "+IP Gateway: " & EthGateWay -124 Cambio_IP -125 Obtener_Lista_Externa -126 frmPrincipal.ComReset.Text = Predefinido - 'Comprobando XMR - '------------------------ -128 dXMR = App.Path & "\XMR.exe" -129 dXMR_ok = (Dir$(dXMR) = vbNullString) -127 Registrar "¿XMR?... " & IIf(dXMR_ok, "¡Si!", "No...") - '------------------------ - 'Interfaz - '------------------------ -133 Registrar "Reestableciendo interfaz" -134 frmPrincipal.chkAvanzado.Value = LeerINI("Interfaz", "MAvanzado", Unchecked) -135 frmPrincipal.chkTerminal.Value = LeerINI("Interfaz", "MTerminal", Unchecked) -136 frmPrincipal.txtNumero.Text = LeerINI("Opciones", "Telefono", vbNullString) - 'variables -137 Umbral_Desconexion = 30000 - - '------------------------ - 'Verificar si hay router predefinido y proceder - '------------------------ -138 If HayPredefinido = True Then -139 Registrar "Router predefinido, 10segs. para reseteo o cancelar" -140 frmPrincipal.cmdPredefinir.Caption = "Cancelar" -141 frmPrincipal.cmdReset.Enabled = False -142 frmPrincipal.ComReset.Enabled = False -143 TiempoEx.StartTimer -144 TiempoEx2.StartTimer - - 'Esperamos los 10segs ó que la persona presione cancelar -145 Do Until TiempoEx.Elapsed > 10000 Or NetError = True -146 Esperar 0.1 -147 frmPrincipal.lblTW.Caption = Fix((10000 - TiempoEx.Elapsed) / 1000) - -148 If TiempoEx2.Elapsed > 1000 Then -149 Beep -150 TiempoEx2.StartTimer - End If - - Loop - -151 TiempoEx2.EndTimer - - 'Si no presionó cancelar -152 If Not NetError Then -153 Registrar "{[PRE]:Iniciando reseteo predefinido}" -154 Procesar_Codigo -155 Registrar "{[PRE]:Terminando programa}" -156 GuardarRegistro -157 Terminar - Else - 'Si presionó cancelar -158 Registrar "Se ha cancelado el reseteo automatico" -159 NetError = False - End If - End If - -160 TiempoEx.EndTimer -161 frmPrincipal.cmdReset.Enabled = True -162 frmPrincipal.ComReset.Enabled = True -163 Tiempo.EndTimer - '------------------------ -164 Registrar "Reseter tardó " & Round(Tiempo.Elapsed / 1000, 2) & "segs. en cargar" - ' - Exit Sub -Main_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Main.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub Reiniciar() - ' - On Error GoTo Reiniciar_Err - ' - Dim bIP As IP - Dim Detectado As Boolean - 'Reseteamos las variables. -100 NetError = False - - 'Verificamos si existe el objeto IE y verificamos si debe o no - 'de existir. -101 If IE Is Nothing And m_Datos.tipoAcceso = web Then -102 If NoIE Then -103 Registrar "!!!No hay objeto IE porque se especificó NoIE=-1" - Else -104 Registrar "!!!Por alguna causa el objeto IE no esta!" - End If - End If - - 'Verificamos el tipo de operación [Web | Telnet | AuroNet] - 'y la ejecutamos -105 Select Case m_Datos.tipoAcceso - - Case Is = e_Acceso.web -106 Registrar "+-Será un reseteo via WEB" -107 res_Web - -108 Case Is = e_Acceso.telnet -109 Registrar "+-Será un reseteo via Telnet" -110 res_Telnet - -111 Case Is = e_Acceso.auro -112 Registrar "+-Será un reseteo via WEB/AuroNet" -113 res_auro - End Select - - 'Si ocurrió algún error en el reinicio -114 If NetError = True Then -115 Registrar "!!! Ha ocurrido un error critico y el reseteo no continuará" - Exit Sub - End If - - 'Esperamos la reconexión -116 If m_Datos.asumirDes Or ModoLinux Then -117 Registrar "+--Esperando " & Fix((Umbral_Desconexion / 1000)) & "Segs. para asumir des/conexión de router" -118 Tiempo.StartTimer - - Do -119 Esperar 0.5 -120 frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) -121 Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = False - -122 Tiempo.EndTimer - -123 If NetError Then Exit Sub - Else -124 Registrar "+--Esperando " & Fix(Umbral_Desconexion / 1000) & " segundos para desconexión de router" -125 Tiempo.StartTimer - - Do -126 Esperar 0.5 -127 frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) -128 Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = False - -129 Tiempo.EndTimer - -130 If NetError Or Tiempo.Elapsed > Umbral_Desconexion Then -131 Registrar "+---El router nunca se desconectó o ocurrió otro error" -132 Error_Cel -133 NetError = True - Exit Sub - End If - -134 Registrar "+--Esperando " & Fix(Umbral_Desconexion / 1000) & "segundos para reconexión de router" -135 Tiempo.StartTimer - - Do -136 Esperar 0.5 -137 frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) -138 Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = True - -139 Tiempo.EndTimer - -140 If NetError Or Tiempo.Elapsed > Umbral_Desconexion Then -141 Registrar "+---El router nunca se conectó o ocurrió otro error" -142 Error_Cel -143 NetError = True - Exit Sub - End If - End If - - 'Esperar 5 minutos a que se recupere el internet -144 Registrar "+--Esperando recuperación de internet (máximo " & (Umbral_EsperarInternetMax / 60000) & "minutos)" -145 Tiempo.StartTimer -146 TiempoEx.StartTimer - Dim dTemporizador As Long -147 dTemporizador = SetTimer(0, 0, 1000, AddressOf lpActualizar) -148 Detectado = HayInternet - -149 If Not Detectado Then - -150 Do Until (Tiempo.Elapsed > Umbral_EsperarInternetMax) Or NetError -151 Esperar 0.5 - - 'Chequear si ya hay internet -152 If TiempoEx.Elapsed > Umbral_ChequeoInternet Then -153 Detectado = HayInternet - -154 If Detectado Then Exit Do - End If - - Loop - - End If - -155 KillTimer 0, dTemporizador -156 Tiempo.EndTimer -157 TiempoEx.EndTimer - -158 If Detectado And NetError = False Then - 'Si hay internet entonces verificamos si la IP cambió - '1: Si no cambió entonces reseteamos el router de nuevo - '2: siempre y cuando no supere cierto limite de reintentos. -159 bIP = Cambio_IP - -160 If bIP.Cambio = True Then -161 Registrar "++La IP no cambió, reintentando reseteo en " & (Umbral_Reintento / 1000) & "Segs." -162 Intentos_Realizados = Intentos_Realizados + 1 - - 'Como no cambió reintentamos el reseteo -163 If Intentos_Realizados > Intentos_Maximos Then - 'Si ya no nos quedan intentos... -164 Registrar "++-Se han hecho " & Intentos_Realizados & " intentos sin exito, deteniendo" -165 Registrar "+Se han cancelado los reintentos aútomaticos" - Exit Sub - Else - 'Si aún nos quedan intentos... -166 Tiempo.StartTimer - 'Esperar 30segs. para reintentar reseteo -167 Registrar "+Esperando " & Fix(Umbral_Reintento / 1000) & " segundos para intento #" & Intentos_Realizados + 1 - - Do -168 Esperar 0.5 -169 frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) -170 Loop Until Tiempo.Elapsed > Umbral_Reintento Or NetError - -171 If Not NetError Then -172 Procesar_Codigo - Exit Sub - End If - End If - - Else -173 Registrar "+El cambió fue satisfactorio" - -174 If dXMR_ok And frmPrincipal.txtNumero.Text <> vbNullString Then -175 Registrar "Enviando mensaje de exito a usuario" -176 XMR_Enviar frmPrincipal.txtNumero.Text, "El reseteo fue exitoso, a las " & Now & " | nueva IP: " & bIP.IP_Actual - Else -177 Registrar "No habia numero para notificacion de usuario" - End If - -178 frmPrincipal.lblTW.Caption = "Exito" - End If - - Else - 'Si no se detectó para nada el internet -179 Registrar "+El tiempo de espera se agotó y no se detecto conexión." -180 Registrar "++El servidor " & PaginaIP & " puede estar caido." -181 Registrar "+Se han cancelado los reintentos aútomaticos" -182 Error_Cel -183 frmPrincipal.lblTW.Caption = "Error" - End If - - ' Reseteamos algunas variables -184 Umbral_Desconexion = 30000 - ' - Exit Sub -Reiniciar_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Reiniciar.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Function GuardarRegistro() As String - ' - On Error GoTo GuardarRegistro_Err - ' - Dim i As Byte - Dim Buffer As String - Static ocupado As Boolean - -100 If ocupado Then Exit Function -101 ocupado = True -102 i = FreeFile -103 Buffer = frmPrincipal.txtSalida.Text -104 Open App.Path & "\" & Day(Now) & "-" & Month(Now) & ".txt" For Append Access Write As #i -105 Print #i, CStr(Now) -106 Print #i, CStr(Buffer) -107 Close #i -108 GuardarRegistro = (App.Path & "\" & Day(Now) & "-" & Month(Now) & ".txt") -109 ocupado = False - ' - Exit Function -GuardarRegistro_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.GuardarRegistro.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -'CSEH: Skip -Public Sub Controlar_Error(linea As Long, _ - descripcion As String, _ - lugar As String) -100 Registrar "¦¦¦""" & descripcion & """, erl #" & linea & " - """ & lugar & """" - -102 If Quieto Then -104 GuardarRegistro - Else - -106 If MsgBox("Ocurrió el error """ & descripcion & """, en linea #" & linea & " de """ & lugar & """" & vbNewLine & "Por favor notifica de este error al tema especifico de reseter en svcommunity.org ó todosv.com" & vbNewLine & "Se ha guardado un registro de error en """ & GuardarRegistro & """ por favor envielo a los creadores" & vbNewLine & "¿Desea terminar la aplicación?", vbCritical + vbYesNo) = vbYes Then End - End If - -End Sub - -Public Sub Predefinir(Valor As Boolean) - ' - On Error GoTo Predefinir_Err - ' -100 EscribirINI "Opciones", "BPredefinido", CStr(CInt(Valor)) -101 EscribirINI "Opciones", "Predefinido", frmPrincipal.ComReset.Text - ' - Exit Sub -Predefinir_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Predefinir.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Function Predefinido() As String - ' - On Error GoTo Predefinido_Err - ' -100 Predefinido = LeerINI("Opciones", "Predefinido", "Escoja su router/modem") - ' - Exit Function -Predefinido_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Predefinido.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Function ObtenerDominio(URL As String) As String - ' - On Error GoTo ObtenerDominio_Err - ' - Dim Buffer As Long -100 Buffer = InStr(8, URL, "/") - -101 If Buffer > 0 Then ObtenerDominio = Replace$(Mid$(URL, 1, Buffer - 1), "http://", vbNullString) Else ObtenerDominio = URL - ' - Exit Function -ObtenerDominio_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.ObtenerDominio.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Function HayPredefinido() As Boolean - ' - On Error GoTo HayPredefinido_Err - ' -100 HayPredefinido = LeerINI("Opciones", "BPredefinido", False) - ' - Exit Function -HayPredefinido_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.HayPredefinido.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Sub XMR_Enviar(Numero As String, _ - Mensaje As String) - 'Gracias a Olatin por la idea de enviar mensaje con notificaciones!. - ' - On Error GoTo XMR_Enviar_Err - ' -100 ShellExecute frmPrincipal.hWnd, "", dXMR & " /x n=" & Numero & "|m=" & Mensaje & "|f=Reseter 4.0", "", "", 0 - ' - Exit Sub -XMR_Enviar_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.XMR_Enviar.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub Error_Cel() - ' - On Error GoTo Error_Cel_Err - - ' -100 If dXMR_ok And frmPrincipal.txtNumero.Text <> vbNullString Then -101 Registrar "Enviando mensaje de error a usuario" -102 XMR_Enviar frmPrincipal.txtNumero.Text, "El reseteo NO fue exitoso, fallo ocurrido en " & Now - End If - - ' - Exit Sub -Error_Cel_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Error_Cel.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub Procesar_Codigo() - 'Primero quebramos el codigo en un array, donde cada elemento contendrá una linea de codigo básico. - ' - On Error GoTo Procesar_Codigo_Err - ' - Dim A_Codigo() As String - Dim i As Long - Dim cTimeEspera As New cTimer -100 A_Codigo = Split(m_Datos.codigo, Chr(254)) - -101 For i = 0 To UBound(A_Codigo) - - 'Saltar los comentarios -102 If Left(A_Codigo(i), 2) = "//" Then Registrar "PreProcesador: Comentario: '" & Mid$(A_Codigo(i), 3) & "'" - 'Reemplazar variables -103 A_Codigo(i) = Replace$(A_Codigo(i), "$$GATEWAY$$", EthGateWay) - - '######################################################################################### - ' Ejecutores - '######################################################################################### - 'El codigo dice que tenemos que reiniciar?, bien, "tratemos" -104 If A_Codigo(i) = "objetivo.reiniciar" Then -105 Registrar "PreProcesador: 'objetivo.reiniciar' ejecutando 'Reiniciar'" -106 Reiniciar -107 Registrar "PreProcesador: 'objetivo.reiniciar' ejecutado." - End If - - 'El codigo dice que tenemos que ejecutemos el procesador Res_web? -108 If A_Codigo(i) = "web.procesar" Then -109 Registrar "PreProcesador: 'web.procesar' ejecutando 'Res_Web'" -110 res_Web -111 Registrar "PreProcesador: 'web.procesar' ejecutado." - End If - - 'El codigo diceque tenemos que esperar X segundos antes de seguir? -112 If InStr(1, A_Codigo(i), "mi.esperar=") Then -113 TiempoMax = CDbl(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) * 1000 -114 Registrar "PreProcesador: 'mi.esperar' iniciada [" & TiempoMax & "]" -115 cTimeEspera.StartTimer - - Do -116 Esperar 0.5 -117 Loop Until cTimeEspera.Elapsed > TiempoMax - -118 Registrar "PreProcesador: comando 'mi.esperar' concluido" - End If - - '######################################################################################### - '######################################################################################### - '######################################################################################### - ' Banderas - '######################################################################################### - 'El codigo dice que tenemos que hacer clic en la direccion indicada? -119 If A_Codigo(i) = "web.accion.clic" Then -120 m_Datos.accionTipo = ed_clic -121 Registrar "PreProcesador: 'web.accion.clic' traducido a 'm_Datos.accionTipo=ed_clic'" - End If - - 'El codigo dice que solo tenemos que navegar la direccion indicada? (codigo JAVA) -122 If A_Codigo(i) = "web.accion.java" Then -123 m_Datos.accionTipo = ed_java -124 Registrar "PreProcesador: 'web.accion.java' traducido a 'm_Datos.accionTipo=ed_java'" - End If - - 'El codigo dice que solo tenemos que navegar la direccion indicada? -125 If A_Codigo(i) = "web.accion.navegar" Then -126 m_Datos.accionTipo = ed_navegar -127 Registrar "PreProcesador: 'web.accion.navegar' traducido a 'm_Datos.accionTipo=ed_navegar'" - End If - - 'El codigo dice que tenemos que llenar información en la direccion y posición indicada? -128 If InStr(1, A_Codigo(i), "web.accion.llenar") Then -129 m_Datos.accionTipo = ed_llenar -130 Registrar "PreProcesador: 'web.accion.llenar' traducido a 'm_Datos.accionTipo=ed_llenar'" - End If - - 'Debemos asumir que el router se desconectará internamente?. -131 If InStr(1, A_Codigo(i), "objetivo.asumir.desconexion=") Then -132 m_Datos.asumirDes = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) -133 Registrar "PreProcesador: 'objetivo.asumir.desconexion' traducido a 'm_Datos.asumirDes=" & m_Datos.asumirDes & "'" - End If - - 'El codigo dice que tenemos que renovar despues de la operación? -134 If InStr(1, A_Codigo(i), "red.renovar=") Then -135 m_Datos.renovar = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) -136 Registrar "PreProcesador: 'red.renovar' traducido a 'm_Datos.renovar=" & m_Datos.renovar & "'" - End If - - 'El codigo dice que no tenemos que navegar en reiniciar.res_web y en web.procesar? -137 If InStr(1, A_Codigo(i), "web.navegar=") Then -138 flag_Navegar = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) -139 Registrar "PreProcesador: 'web.navegar' traducido a 'flag_Navegar=" & flag_Navegar & "'" - End If - - 'El codigo dice que tenemos que cambiar el limite para asumir desconexion -temporal-? - 'mi.umbral.desconexion= -140 If InStr(1, A_Codigo(i), "mi.umbral.desconexion=") Then -141 Umbral_Desconexion = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) * 1000 -142 Registrar "PreProcesador: 'mi.umbral.desconexion' traducido a 'Umbral_Desconexion=" & Umbral_Desconexion & "'" - End If - - '######################################################################################### - '######################################################################################### - '######################################################################################### - ' Ajustes de parametros - '######################################################################################### - 'El codigo dice que tenemos que ajustar las opciones para procesar telnet? - 'telnet= -143 If InStr(1, A_Codigo(i), "telnet.comando=") Then -144 m_Datos.tipoAcceso = telnet -145 m_Datos.accionEX = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -146 Registrar "PreProcesador: 'telnet' traducido a 'm_Datos.accionEX=" & m_Datos.accionEX & "'" - End If - - 'El codigo dice que tenemos que ajustar las opciones para procesar web? -147 If InStr(1, A_Codigo(i), "web.url=") Then -148 m_Datos.accionEX = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -149 m_Datos.tipoAcceso = web -150 Registrar "PreProcesador: 'web.url' traducido a 'm_Datos.accionEX=" & m_Datos.accionEX & "'" - End If - - 'El codigo nos da datos para EX2 -151 If InStr(1, A_Codigo(i), "web.datos=") Then -152 m_Datos.accionEX2 = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -153 Registrar "PreProcesador: 'web.datos' traducido a 'm_Datos.accionEX2=" & m_Datos.accionEX2 & "'" - End If - - 'El codigo especifica el puerto a usar? -154 If InStr(1, A_Codigo(i), "puerto=") Then -155 m_Datos.puerto = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -156 Registrar "PreProcesador: 'puerto' traducido a 'm_Datos.puerto=" & m_Datos.puerto & "'" - End If - - 'El codigo especifica el control a usar? -157 If InStr(1, A_Codigo(i), "web.control=") Then -158 m_Datos.nCont = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -159 Registrar "PreProcesador: 'web.control' traducido a 'm_Datos.nCont=" & m_Datos.nCont & "'" - End If - - 'El codigo especifica el formulario a usar? -160 If InStr(1, A_Codigo(i), "web.formulario=") Then -161 m_Datos.nForm = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -162 Registrar "PreProcesador: 'web.formulario' traducido a 'm_Datos.nForm=" & m_Datos.nForm & "'" - End If - - 'El codigo especifica el usuario a usar? -163 If InStr(1, A_Codigo(i), "web.usuario=") Then -164 m_Datos.usuario = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -165 Registrar "PreProcesador: 'web.usuario' traducido a 'm_Datos.usuario=" & m_Datos.usuario & "'" - End If - - 'El codigo especifica la clave a usar? -166 If InStr(1, A_Codigo(i), "web.clave=") Then -167 m_Datos.clave = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -168 Registrar "PreProcesador: 'clave' traducido a 'm_Datos.clave=" & m_Datos.clave & "'" - End If - - 'El codigo especifica la dirección base a usar? -169 If InStr(1, A_Codigo(i), "objetivo.ip=") Then -170 m_Datos.base = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) -171 Registrar "PreProcesador: 'base' traducido a 'm_Datos.base=" & m_Datos.base & "'" - End If - - '######################################################################################### - '######################################################################################### - Next - - ' - Exit Sub -Procesar_Codigo_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Procesar_Codigo.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Function HayInternet() As Boolean - ' - On Error GoTo HayInternet_Err - - ' -100 If m_Datos.renovar = True Then RenovarLAN -101 Registrar "+---Chequeando conexión a internet... espere" -102 Esperar 0.5 - -103 If ppSocket.HTML_CONSULTAR Then -104 Registrar "+----Chequeo -> Se detectó internet" -105 HayInternet = True - Else -106 Registrar "+----Chequeo -> Aún no hay internet" -107 TiempoEx.StartTimer - End If - - ' - Exit Function -HayInternet_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.HayInternet.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Function - -Public Sub Restablecer_Todo() - ' - On Error GoTo Restablecer_Todo_Err - ' -100 flag_Navegar = True -101 TelnetComandos = Split("") -102 nComando = 0 -103 NetError = False -104 Intentos_Realizados = 0 - -105 With m_Datos -106 .accionEX = "" -107 .accionEX2 = "" -108 .accionTipo = ed_clic -109 .asumirDes = False -110 .base = "" -111 .clave = "" -112 .codigo = "" -113 .Direccion = "" -114 .nCont = -1 -115 .nForm = -1 -116 .puerto = 0 -117 .renovar = True -118 .tipoAcceso = web -119 .usuario = "" - End With - - ' - Exit Sub -Restablecer_Todo_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Restablecer_Todo.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub - -Public Sub Terminar() - ' - On Error GoTo Terminar_Err - ' -100 Destruir_Conexion -101 EscribirINI "Opciones", "Quieto", CStr(CInt(Quieto)) -102 EscribirINI "Opciones", "NoIE", CStr(CInt(NoIE)) -103 EscribirINI "Opciones", "Telefono", CStr(frmPrincipal.txtNumero.Text) -104 EscribirINI "Opciones", "Linux:Compatibilidad", CStr(CInt(ModoLinux)) -105 Set pSocket = Nothing -106 Set ppSocket = Nothing - Dim f As Form - -107 For Each f In Forms -108 Unload f - Next - -109 End - ' - Exit Sub -Terminar_Err: - Controlar_Error Erl, Err.Description, "Reseter.Global.Terminar.Ref 12/8/2008 : 08:11:20" - Resume Next - ' -End Sub +Attribute VB_Name = "Global" +Option Explicit +' "Reseter", Copyright 2006-2007 TodoSV.com +' Licencia adicional a: www.svcommunity.org y www.untercio.net +' Mantenedores principales: +' *Vlad +' *Kikeuntercio +' Para soporte, dudas, consultas, inquitudes y demás: +' http://foro.todosv.com/reseter/ +' http://www.svcommunity.org/forum/index.php?topic=25095.0 +' http://www.svcommunity.org/forum/index.php?topic=59743.0 +Private TiempoMax As Double +'Tipo +Enum e_Acceso + web + telnet + auro +End Enum +Enum e_AccionEX + ed_clic + ed_java + ed_llenar + ed_navegar +End Enum +Type t_Datos + Direccion As String 'Dirección a navegar + usuario As String 'Usuario del router + clave As String 'Clave del usuario del router + base As String 'Dirección de la puerta de enlace + puerto As Long 'Puerto de acceso + nForm As Integer + nCont As Integer + accionTipo As e_AccionEX + accionEX As String + accionEX2 As String + codigo As String 'Lista de codigos a ejecutarse + tipoAcceso As e_Acceso 'Tipo de acceso [Telnet | Web] + renovar As Boolean 'Ejecutar renovación de IP + asumirDes As Boolean 'Asumir desconexion o probar? +End Type +Public m_Datos As t_Datos +Public flag_Navegar As Boolean +Public IE As Object +Public TelnetComandos() As String +Public nComando As Integer +Public NetError As Boolean +Private Intentos_Realizados As Byte +Public pSocket As AuroNet +Public ppSocket As AuroNet +Public Tiempo As cTimer 'Uso general +Public TiempoEx As cTimer 'Uso secundario +Public TiempoEx2 As New cTimer 'Uso terciario +Public dXMR As String +Public dXMR_ok As Boolean + +Public Sub Main() + 'Activar_Temas_XP + 'Rutas de archivos + '------------------------ + ' + On Error GoTo Main_Err + ' + Set Tiempo = New cTimer + Set TiempoEx = New cTimer + 'Empezamos a medir el tiempo que tarda en iniciar el programa + Tiempo.StartTimer + '------------------------ + 'Iniciamos los Sockets + Set pSocket = New AuroNet + Set ppSocket = New AuroNet + pSocket.Direccion = PaginaIP + ppSocket.Direccion = "www.google.com" + '------------------------ + EthInfo + '------------------------ + 'Fichero INI con las opciones del programa + rINI_OPCIONES = App.Path & "\Reseter.ini" + 'Fichero INI con los códigos de reseteo para los routers + rINI_ROUTERS = App.Path & "\Routers.ini" + '------------------------ + Quieto = LeerINI("Opciones", "Quieto", False) + 'Será que es mejor no iniciar el Objeto IE? + 'Esto es util cuando se ha desinstalado el Explorer o en Wine + NoIE = LeerINI("Opciones", "NoIE", False) + ModoLinux = LeerINI("Opciones", "Linux:Compatibilidad", False) + '------------------------ + frmPrincipal.Show + + DoEvents + '------------------------ + Registrar "Iniciando Reseter: " & App.Major & "." & App.Minor & "." & App.Revision & " " & EstadoVer + Registrar "Propiedad de todosv.com, svcommunity.org y untercio.net" + Registrar "Información: http://foro.todosv.com/reseter/" + Registrar "IP pública gracias a " & ObtenerDominio(PaginaIP) + + '------------------------ + 'Objeto IE + If NoIE Then + Registrar "+Objeto IE: NoIE establecido." + Else + Crear_Objeto_IE + End If + + Registrar "+IP Local: " & pSocket.IpLocal + Registrar "+IP Gateway: " & EthGateWay + Cambio_IP + Obtener_Lista_Externa + frmPrincipal.ComReset.Text = Predefinido + 'Comprobando XMR + '------------------------ + dXMR = App.Path & "\XMR.exe" + dXMR_ok = (Dir$(dXMR) = vbNullString) + Registrar "¿XMR?... " & IIf(dXMR_ok, "¡Si!", "No...") + '------------------------ + 'Interfaz + '------------------------ + Registrar "Reestableciendo interfaz" + frmPrincipal.chkAvanzado.Value = LeerINI("Interfaz", "MAvanzado", Unchecked) + frmPrincipal.chkTerminal.Value = LeerINI("Interfaz", "MTerminal", Unchecked) + frmPrincipal.txtNumero.Text = LeerINI("Opciones", "Telefono", vbNullString) + 'variables + Umbral_Desconexion = 30000 + + '------------------------ + 'Verificar si hay router predefinido y proceder + '------------------------ + If HayPredefinido = True Then + Registrar "Router predefinido, 10segs. para reseteo o cancelar" + frmPrincipal.cmdPredefinir.Caption = "Cancelar" + frmPrincipal.cmdReset.Enabled = False + frmPrincipal.ComReset.Enabled = False + TiempoEx.StartTimer + TiempoEx2.StartTimer + + 'Esperamos los 10segs ó que la persona presione cancelar + Do Until TiempoEx.Elapsed > 10000 Or NetError = True + Esperar 0.1 + frmPrincipal.lblTW.Caption = Fix((10000 - TiempoEx.Elapsed) / 1000) + + If TiempoEx2.Elapsed > 1000 Then + Beep + TiempoEx2.StartTimer + End If + + Loop + + TiempoEx2.EndTimer + + 'Si no presionó cancelar + If Not NetError Then + Registrar "{[PRE]:Iniciando reseteo predefinido}" + Procesar_Codigo + Registrar "{[PRE]:Terminando programa}" + GuardarRegistro + Terminar + Else + 'Si presionó cancelar + Registrar "Se ha cancelado el reseteo automatico" + NetError = False + End If + End If + + TiempoEx.EndTimer + frmPrincipal.cmdReset.Enabled = True + frmPrincipal.ComReset.Enabled = True + Tiempo.EndTimer + '------------------------ + Registrar "Reseter tardó " & Round(Tiempo.Elapsed / 1000, 2) & "segs. en cargar" + ' + Exit Sub +Main_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Main" + Resume Next + ' +End Sub + +Public Sub Reiniciar() + ' + On Error GoTo Reiniciar_Err + ' + Dim bIP As IP + Dim Detectado As Boolean + 'Reseteamos las variables. + NetError = False + + 'Verificamos si existe el objeto IE y verificamos si debe o no + 'de existir. + If IE Is Nothing And m_Datos.tipoAcceso = web Then + If NoIE Then + Registrar "!!!No hay objeto IE porque se especificó NoIE=-1" + Else + Registrar "!!!Por alguna causa el objeto IE no esta!" + End If + End If + + 'Verificamos el tipo de operación [Web | Telnet | AuroNet] + 'y la ejecutamos + Select Case m_Datos.tipoAcceso + + Case Is = e_Acceso.web + Registrar "+-Será un reseteo via WEB" + res_Web + + Case Is = e_Acceso.telnet + Registrar "+-Será un reseteo via Telnet" + res_Telnet + + Case Is = e_Acceso.auro + Registrar "+-Será un reseteo via WEB/AuroNet" + res_auro + End Select + + 'Si ocurrió algún error en el reinicio + If NetError = True Then + Registrar "!!! Ha ocurrido un error critico y el reseteo no continuará" + Exit Sub + End If + + 'Esperamos la reconexión + If m_Datos.asumirDes Or ModoLinux Then + Registrar "+--Esperando " & Fix((Umbral_Desconexion / 1000)) & "Segs. para asumir des/conexión de router" + Tiempo.StartTimer + + Do + Esperar 0.5 + frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) + Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = False + + Tiempo.EndTimer + + If NetError Then Exit Sub + Else + Registrar "+--Esperando " & Fix(Umbral_Desconexion / 1000) & " segundos para desconexión de router" + Tiempo.StartTimer + + Do + Esperar 0.5 + frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) + Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = False + + Tiempo.EndTimer + + If NetError Or Tiempo.Elapsed > Umbral_Desconexion Then + Registrar "+---El router nunca se desconectó o ocurrió otro error" + Error_Cel + NetError = True + Exit Sub + End If + + Registrar "+--Esperando " & Fix(Umbral_Desconexion / 1000) & "segundos para reconexión de router" + Tiempo.StartTimer + + Do + Esperar 0.5 + frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) + Loop Until Tiempo.Elapsed > Umbral_Desconexion Or NetError Or GetNetConnectString = True + + Tiempo.EndTimer + + If NetError Or Tiempo.Elapsed > Umbral_Desconexion Then + Registrar "+---El router nunca se conectó o ocurrió otro error" + Error_Cel + NetError = True + Exit Sub + End If + End If + + 'Esperar 5 minutos a que se recupere el internet + Registrar "+--Esperando recuperación de internet (máximo " & (Umbral_EsperarInternetMax / 60000) & "minutos)" + Tiempo.StartTimer + TiempoEx.StartTimer + Dim dTemporizador As Long + dTemporizador = SetTimer(0, 0, 1000, AddressOf lpActualizar) + Detectado = HayInternet + + If Not Detectado Then + + Do Until (Tiempo.Elapsed > Umbral_EsperarInternetMax) Or NetError + Esperar 0.5 + + 'Chequear si ya hay internet + If TiempoEx.Elapsed > Umbral_ChequeoInternet Then + Detectado = HayInternet + + If Detectado Then Exit Do + End If + + Loop + + End If + + KillTimer 0, dTemporizador + Tiempo.EndTimer + TiempoEx.EndTimer + + If Detectado And NetError = False Then + 'Si hay internet entonces verificamos si la IP cambió + '1: Si no cambió entonces reseteamos el router de nuevo + '2: siempre y cuando no supere cierto limite de reintentos. + bIP = Cambio_IP + + If bIP.Cambio = True Then + Registrar "++La IP no cambió, reintentando reseteo en " & (Umbral_Reintento / 1000) & "Segs." + Intentos_Realizados = Intentos_Realizados + 1 + + 'Como no cambió reintentamos el reseteo + If Intentos_Realizados > Intentos_Maximos Then + 'Si ya no nos quedan intentos... + Registrar "++-Se han hecho " & Intentos_Realizados & " intentos sin exito, deteniendo" + Registrar "+Se han cancelado los reintentos aútomaticos" + Exit Sub + Else + 'Si aún nos quedan intentos... + Tiempo.StartTimer + 'Esperar 30segs. para reintentar reseteo + Registrar "+Esperando " & Fix(Umbral_Reintento / 1000) & " segundos para intento #" & Intentos_Realizados + 1 + + Do + Esperar 0.5 + frmPrincipal.lblTW.Caption = Fix((Umbral_Desconexion - Tiempo.Elapsed) / 1000) + Loop Until Tiempo.Elapsed > Umbral_Reintento Or NetError + + If Not NetError Then + Procesar_Codigo + Exit Sub + End If + End If + + Else + Registrar "+El cambió fue satisfactorio" + + If dXMR_ok And frmPrincipal.txtNumero.Text <> vbNullString Then + Registrar "Enviando mensaje de exito a usuario" + XMR_Enviar frmPrincipal.txtNumero.Text, "El reseteo fue exitoso, a las " & Now & " | nueva IP: " & bIP.IP_Actual + Else + Registrar "No habia numero para notificacion de usuario" + End If + + frmPrincipal.lblTW.Caption = "Exito" + End If + + Else + 'Si no se detectó para nada el internet + Registrar "+El tiempo de espera se agotó y no se detecto conexión." + Registrar "++El servidor " & PaginaIP & " puede estar caido." + Registrar "+Se han cancelado los reintentos aútomaticos" + Error_Cel + frmPrincipal.lblTW.Caption = "Error" + End If + + ' Reseteamos algunas variables + Umbral_Desconexion = 30000 + ' + Exit Sub +Reiniciar_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Reiniciar" + Resume Next + ' +End Sub + +Public Function GuardarRegistro() As String + ' + On Error GoTo GuardarRegistro_Err + ' + Dim i As Byte + Dim Buffer As String + Static ocupado As Boolean + + If ocupado Then Exit Function + ocupado = True + i = FreeFile + Buffer = frmPrincipal.txtSalida.Text + Open App.Path & "\" & Day(Now) & "-" & Month(Now) & ".txt" For Append Access Write As #i + Print #i, CStr(Now) + Print #i, CStr(Buffer) + Close #i + GuardarRegistro = (App.Path & "\" & Day(Now) & "-" & Month(Now) & ".txt") + ocupado = False + ' + Exit Function +GuardarRegistro_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.GuardarRegistro" + Resume Next + ' +End Function + +'CSEH: Skip +Public Sub Controlar_Error(linea As Long, _ + descripcion As String, _ + lugar As String) +100 Registrar "¦¦¦""" & descripcion & """, erl #" & linea & " - """ & lugar & """" + +102 If Quieto Then +104 GuardarRegistro + Else + +106 If MsgBox("Ocurrió el error """ & descripcion & """, en linea #" & linea & " de """ & lugar & """" & vbNewLine & "Por favor notifica de este error al tema especifico de reseter en svcommunity.org ó todosv.com" & vbNewLine & "Se ha guardado un registro de error en """ & GuardarRegistro & """ por favor envielo a los creadores" & vbNewLine & "¿Desea terminar la aplicación?", vbCritical + vbYesNo) = vbYes Then End + End If + +End Sub + +Public Sub Predefinir(Valor As Boolean) + ' + On Error GoTo Predefinir_Err + ' + EscribirINI "Opciones", "BPredefinido", CStr(CInt(Valor)) + EscribirINI "Opciones", "Predefinido", frmPrincipal.ComReset.Text + ' + Exit Sub +Predefinir_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Predefinir" + Resume Next + ' +End Sub + +Public Function Predefinido() As String + ' + On Error GoTo Predefinido_Err + ' + Predefinido = LeerINI("Opciones", "Predefinido", "Escoja su router/modem") + ' + Exit Function +Predefinido_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Predefinido" + Resume Next + ' +End Function + +Public Function ObtenerDominio(URL As String) As String + ' + On Error GoTo ObtenerDominio_Err + ' + Dim Buffer As Long + Buffer = InStr(8, URL, "/") + + If Buffer > 0 Then ObtenerDominio = Replace$(Mid$(URL, 1, Buffer - 1), "http://", vbNullString) Else ObtenerDominio = URL + ' + Exit Function +ObtenerDominio_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.ObtenerDominio" + Resume Next + ' +End Function + +Public Function HayPredefinido() As Boolean + ' + On Error GoTo HayPredefinido_Err + ' + HayPredefinido = LeerINI("Opciones", "BPredefinido", False) + ' + Exit Function +HayPredefinido_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.HayPredefinido" + Resume Next + ' +End Function + +Public Sub XMR_Enviar(Numero As String, _ + Mensaje As String) + 'Gracias a Olatin por la idea de enviar mensaje con notificaciones!. + ' + On Error GoTo XMR_Enviar_Err + ' + ShellExecute frmPrincipal.hWnd, "", dXMR & " /x n=" & Numero & "|m=" & Mensaje & "|f=Reseter 4.0", "", "", 0 + ' + Exit Sub +XMR_Enviar_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.XMR_Enviar" + Resume Next + ' +End Sub + +Public Sub Error_Cel() + ' + On Error GoTo Error_Cel_Err + + ' + If dXMR_ok And frmPrincipal.txtNumero.Text <> vbNullString Then + Registrar "Enviando mensaje de error a usuario" + XMR_Enviar frmPrincipal.txtNumero.Text, "El reseteo NO fue exitoso, fallo ocurrido en " & Now + End If + + ' + Exit Sub +Error_Cel_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Error_Cel" + Resume Next + ' +End Sub + +Public Sub Procesar_Codigo() + 'Primero quebramos el codigo en un array, donde cada elemento contendrá una linea de codigo básico. + ' + On Error GoTo Procesar_Codigo_Err + ' + Dim A_Codigo() As String + Dim i As Long + Dim cTimeEspera As New cTimer + A_Codigo = Split(m_Datos.codigo, Chr(254)) + + For i = 0 To UBound(A_Codigo) + + 'Saltar los comentarios + If Left(A_Codigo(i), 2) = "//" Then Registrar "PreProcesador: Comentario: '" & Mid$(A_Codigo(i), 3) & "'" + 'Reemplazar variables + A_Codigo(i) = Replace$(A_Codigo(i), "$$GATEWAY$$", EthGateWay) + + '######################################################################################### + ' Ejecutores + '######################################################################################### + 'El codigo dice que tenemos que reiniciar?, bien, "tratemos" + If A_Codigo(i) = "objetivo.reiniciar" Then + Registrar "PreProcesador: 'objetivo.reiniciar' ejecutando 'Reiniciar'" + Reiniciar + Registrar "PreProcesador: 'objetivo.reiniciar' ejecutado." + End If + + 'El codigo dice que tenemos que ejecutemos el procesador Res_web? + If A_Codigo(i) = "web.procesar" Then + Registrar "PreProcesador: 'web.procesar' ejecutando 'Res_Web'" + res_Web + Registrar "PreProcesador: 'web.procesar' ejecutado." + End If + + 'El codigo diceque tenemos que esperar X segundos antes de seguir? + If InStr(1, A_Codigo(i), "mi.esperar=") Then + TiempoMax = CDbl(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) * 1000 + Registrar "PreProcesador: 'mi.esperar' iniciada [" & TiempoMax & "]" + cTimeEspera.StartTimer + + Do + Esperar 0.5 + Loop Until cTimeEspera.Elapsed > TiempoMax + + Registrar "PreProcesador: comando 'mi.esperar' concluido" + End If + + '######################################################################################### + '######################################################################################### + '######################################################################################### + ' Banderas + '######################################################################################### + 'El codigo dice que tenemos que hacer clic en la direccion indicada? + If A_Codigo(i) = "web.accion.clic" Then + m_Datos.accionTipo = ed_clic + Registrar "PreProcesador: 'web.accion.clic' traducido a 'm_Datos.accionTipo=ed_clic'" + End If + + 'El codigo dice que solo tenemos que navegar la direccion indicada? (codigo JAVA) + If A_Codigo(i) = "web.accion.java" Then + m_Datos.accionTipo = ed_java + Registrar "PreProcesador: 'web.accion.java' traducido a 'm_Datos.accionTipo=ed_java'" + End If + + 'El codigo dice que solo tenemos que navegar la direccion indicada? + If A_Codigo(i) = "web.accion.navegar" Then + m_Datos.accionTipo = ed_navegar + Registrar "PreProcesador: 'web.accion.navegar' traducido a 'm_Datos.accionTipo=ed_navegar'" + End If + + 'El codigo dice que tenemos que llenar información en la direccion y posición indicada? + If InStr(1, A_Codigo(i), "web.accion.llenar") Then + m_Datos.accionTipo = ed_llenar + Registrar "PreProcesador: 'web.accion.llenar' traducido a 'm_Datos.accionTipo=ed_llenar'" + End If + + 'Debemos asumir que el router se desconectará internamente?. + If InStr(1, A_Codigo(i), "objetivo.asumir.desconexion=") Then + m_Datos.asumirDes = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) + Registrar "PreProcesador: 'objetivo.asumir.desconexion' traducido a 'm_Datos.asumirDes=" & m_Datos.asumirDes & "'" + End If + + 'El codigo dice que tenemos que renovar despues de la operación? + If InStr(1, A_Codigo(i), "red.renovar=") Then + m_Datos.renovar = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) + Registrar "PreProcesador: 'red.renovar' traducido a 'm_Datos.renovar=" & m_Datos.renovar & "'" + End If + + 'El codigo dice que no tenemos que navegar en reiniciar.res_web y en web.procesar? + If InStr(1, A_Codigo(i), "web.navegar=") Then + flag_Navegar = CBool(Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1)) + Registrar "PreProcesador: 'web.navegar' traducido a 'flag_Navegar=" & flag_Navegar & "'" + End If + + 'El codigo dice que tenemos que cambiar el limite para asumir desconexion -temporal-? + 'mi.umbral.desconexion= + If InStr(1, A_Codigo(i), "mi.umbral.desconexion=") Then + Umbral_Desconexion = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) * 1000 + Registrar "PreProcesador: 'mi.umbral.desconexion' traducido a 'Umbral_Desconexion=" & Umbral_Desconexion & "'" + End If + + '######################################################################################### + '######################################################################################### + '######################################################################################### + ' Ajustes de parametros + '######################################################################################### + 'El codigo dice que tenemos que ajustar las opciones para procesar telnet? + 'telnet= + If InStr(1, A_Codigo(i), "telnet.comando=") Then + m_Datos.tipoAcceso = telnet + m_Datos.accionEX = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'telnet' traducido a 'm_Datos.accionEX=" & m_Datos.accionEX & "'" + End If + + 'El codigo dice que tenemos que ajustar las opciones para procesar web? + If InStr(1, A_Codigo(i), "web.url=") Then + m_Datos.accionEX = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + m_Datos.tipoAcceso = web + Registrar "PreProcesador: 'web.url' traducido a 'm_Datos.accionEX=" & m_Datos.accionEX & "'" + End If + + 'El codigo nos da datos para EX2 + If InStr(1, A_Codigo(i), "web.datos=") Then + m_Datos.accionEX2 = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'web.datos' traducido a 'm_Datos.accionEX2=" & m_Datos.accionEX2 & "'" + End If + + 'El codigo especifica el puerto a usar? + If InStr(1, A_Codigo(i), "puerto=") Then + m_Datos.puerto = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'puerto' traducido a 'm_Datos.puerto=" & m_Datos.puerto & "'" + End If + + 'El codigo especifica el control a usar? + If InStr(1, A_Codigo(i), "web.control=") Then + m_Datos.nCont = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'web.control' traducido a 'm_Datos.nCont=" & m_Datos.nCont & "'" + End If + + 'El codigo especifica el formulario a usar? + If InStr(1, A_Codigo(i), "web.formulario=") Then + m_Datos.nForm = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'web.formulario' traducido a 'm_Datos.nForm=" & m_Datos.nForm & "'" + End If + + 'El codigo especifica el usuario a usar? + If InStr(1, A_Codigo(i), "web.usuario=") Then + m_Datos.usuario = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'web.usuario' traducido a 'm_Datos.usuario=" & m_Datos.usuario & "'" + End If + + 'El codigo especifica la clave a usar? + If InStr(1, A_Codigo(i), "web.clave=") Then + m_Datos.clave = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'clave' traducido a 'm_Datos.clave=" & m_Datos.clave & "'" + End If + + 'El codigo especifica la dirección base a usar? + If InStr(1, A_Codigo(i), "objetivo.ip=") Then + m_Datos.base = Mid$(A_Codigo(i), InStr(1, A_Codigo(i), "=") + 1) + Registrar "PreProcesador: 'base' traducido a 'm_Datos.base=" & m_Datos.base & "'" + End If + + '######################################################################################### + '######################################################################################### + Next + + ' + Exit Sub +Procesar_Codigo_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Procesar_Codigo" + Resume Next + ' +End Sub + +Public Function HayInternet() As Boolean + ' + On Error GoTo HayInternet_Err + + ' + If m_Datos.renovar = True Then RenovarLAN + Registrar "+---Chequeando conexión a internet... espere" + Esperar 0.5 + + If ppSocket.HTML_CONSULTAR Then + Registrar "+----Chequeo -> Se detectó internet" + HayInternet = True + Else + Registrar "+----Chequeo -> Aún no hay internet" + TiempoEx.StartTimer + End If + + ' + Exit Function +HayInternet_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.HayInternet" + Resume Next + ' +End Function + +Public Sub Restablecer_Todo() + ' + On Error GoTo Restablecer_Todo_Err + ' + flag_Navegar = True + TelnetComandos = Split("") + nComando = 0 + NetError = False + Intentos_Realizados = 0 + + With m_Datos + .accionEX = "" + .accionEX2 = "" + .accionTipo = ed_clic + .asumirDes = False + .base = "" + .clave = "" + .codigo = "" + .Direccion = "" + .nCont = -1 + .nForm = -1 + .puerto = 0 + .renovar = True + .tipoAcceso = web + .usuario = "" + End With + + ' + Exit Sub +Restablecer_Todo_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Restablecer_Todo" + Resume Next + ' +End Sub + +Public Sub Terminar() + ' + On Error GoTo Terminar_Err + ' + Destruir_Conexion + EscribirINI "Opciones", "Quieto", CStr(CInt(Quieto)) + EscribirINI "Opciones", "NoIE", CStr(CInt(NoIE)) + EscribirINI "Opciones", "Telefono", CStr(frmPrincipal.txtNumero.Text) + EscribirINI "Opciones", "Linux:Compatibilidad", CStr(CInt(ModoLinux)) + Set pSocket = Nothing + Set ppSocket = Nothing + Dim f As Form + + For Each f In Forms + Unload f + Next + + End + ' + Exit Sub +Terminar_Err: + Controlar_Error Erl, Err.Description, "Reseter.Global.Terminar" + Resume Next + ' +End Sub diff --git a/bas/NET.bas b/bas/NET.bas dissimilarity index 83% index ec660f9..2eb539b 100755 --- a/bas/NET.bas +++ b/bas/NET.bas @@ -1,287 +1,287 @@ -Attribute VB_Name = "NET" -Option Explicit -Dim hpObjetoIE As Long -Type IP - Cambio As Boolean - IP_Actual As String -End Type -Public Declare Function InternetGetConnectedState _ - Lib "wininet.dll" (ByRef lpdwFlags As Long, _ - ByVal dwReserved As Long) As Long -'Local system uses a LAN to connect to the Internet. -Public Const INTERNET_CONNECTION_LAN As Long = &H2 -'Offline -Public Const INTERNET_CONNECTION_OFFLINE As Long = &H20 - -Public Function GetNetConnectString() As Boolean - ' - On Error GoTo GetNetConnectString_Err - ' - Dim dwflags As Long - Dim msg As String - -100 If InternetGetConnectedState(dwflags, 0&) Then -101 If dwflags And INTERNET_CONNECTION_LAN Then -102 GetNetConnectString = True - End If - -103 If dwflags And INTERNET_CONNECTION_OFFLINE Then -104 GetNetConnectString = False - End If - - Else -105 GetNetConnectString = False - End If - - ' - Exit Function -GetNetConnectString_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.GetNetConnectString.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Function Cambio_IP() As IP - 'Idea original de sortux, implementado por Vlad y hosting por No-IP - 'Cambio: 22/03/07 - '1.0.16 -> Eliminado un "registrar "Enviando datos" innecesario - 'Cambio: 03/04/07 - '1.0.19 -> Detectar cambios - ' Ahora es función y devuelve del cambio de ip - ' Forzar recarga de pagina - ' - On Error GoTo Cambio_IP_Err - ' - Static AntiguaIp As String - Dim ActualIp As String -100 ActualIp = Trim$(pSocket.HTML_GET) - -101 If Len(ActualIp) > 16 Or Len(ActualIp) < 8 Then -102 Registrar "+IP Pública: imposible obtener." -103 Cambio_IP.Cambio = True - Exit Function - End If - -104 Cambio_IP.IP_Actual = ActualIp -105 Cambio_IP.Cambio = (ActualIp = AntiguaIp) - -106 If AntiguaIp = vbNullString Then AntiguaIp = GetSetting("Reseter4.0", "Datos", "UltimaIP", vbNullString) -107 Registrar "+IP Pública: " & ActualIp & IIf(ActualIp = AntiguaIp, " (La IP no cambió)", IIf(AntiguaIp = vbNullString, vbNullString, " (OK, antes era: " & AntiguaIp & ")")) -108 AntiguaIp = ActualIp -109 SaveSetting "Reseter4.0", "Datos", "UltimaIP", ActualIp - ' - Exit Function -Cambio_IP_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.Cambio_IP.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Sub Crear_Objeto_IE() - ' - On Error GoTo Crear_Objeto_IE_Err - ' -'100 Registrar "+Objeto IE: creando..." -101 hpObjetoIE = SetTimer(0, 0, 0, AddressOf lpObjetoIE) - ' - Exit Sub -Crear_Objeto_IE_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.Crear_Objeto_IE.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub Destruir_Conexion() - ' - On Error GoTo Destruir_Conexion_Err - ' -100 Set IE = Nothing - ' - Exit Sub -Destruir_Conexion_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.Destruir_Conexion.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Function RenovarLAN() As Long - ' - On Error GoTo RenovarLAN_Err - ' -100 RenovarLAN = ShellExecute(frmPrincipal.hWnd, "", "ipconfig /renew all", "", "", 0) -101 Registrar "~Renovación concluyó en " & RenovarLAN - ' - Exit Function -RenovarLAN_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.RenovarLAN.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Sub res_Web() - ' - On Error GoTo res_Web_Err - ' - On Error GoTo subError - 'Reseteo via pagina web -100 Registrar "+-[MODO WEB] Enviando datos" - - ' Si es reseteo WEB lo primero que tenemos que hacer es armar la direccion a la que - ' vamos a navegar en base a los datos del preprocesador -101 With IE - - 'Procesamos la dirección a navegar en base al tipo de acción. -102 Select Case m_Datos.accionTipo - - Case Is = ed_java - 'Si solo vamos a ejecutar Java, solo tenemos que pasar el comando como la dirección -103 m_Datos.Direccion = m_Datos.accionEX - -104 Case Else - 'En el caso de que vayamos a navegar o hacer clic, tenemos que contruir la direción -105 m_Datos.Direccion = "http://" & IIf(Len(m_Datos.usuario) <> 0, m_Datos.usuario & ":", vbNullString) & IIf(Len(m_Datos.clave) <> 0, m_Datos.clave & "@", vbNullString) & m_Datos.base & ":" & IIf(IsNumeric(m_Datos.puerto), m_Datos.puerto, 80) & m_Datos.accionEX - End Select - -106 If flag_Navegar Then .Navigate m_Datos.Direccion -107 Registrar "Res_Web => armado: '" & m_Datos.Direccion & "'" - -108 Do While .Busy -109 Esperar 0.1 - Loop - -110 Do While .ReadyState <> 4 -111 Esperar 0.1 - Loop - -112 frmWeb.txtLog.Text = "!!! " & m_Datos.Direccion - -113 Select Case m_Datos.accionTipo - - Case ed_clic - -114 If m_Datos.nForm = -1 And m_Datos.nCont = -1 Then -115 Registrar "# de Formulario y Control invalido." - Else - -116 If (.Document.Forms.Length - 1) >= m_Datos.nForm Then -117 If .Document.Forms(m_Datos.nForm).Length - 1 >= m_Datos.nCont Then -118 .Document.Forms(m_Datos.nForm)(m_Datos.nCont).Click -119 Registrar "Res_Web: Datos enviados [" & m_Datos.nForm & ", " & m_Datos.nCont & "]" - Else -120 Registrar "Res_Web: Err -> No existian suficientes controles" -121 NetError = True - End If - - Else -122 Registrar "Res_Web: Err -> No existian suficientes formularios" -123 NetError = True - End If - End If - -124 Case ed_llenar - -125 If m_Datos.nForm = -1 And m_Datos.nCont = -1 Then -126 Registrar "Sin datos, saltando de Llenado" - Else - -127 If (.Document.Forms.Length - 1) >= m_Datos.nForm Then -128 If .Document.Forms(m_Datos.nForm).Length - 1 >= m_Datos.nCont Then -129 .Document.Forms(m_Datos.nForm)(m_Datos.nCont).Value = m_Datos.accionEX2 -130 Registrar "Res_Web: Texto llenado" - Else -131 Registrar "Res_Web: Err -> No existian suficientes controles" -132 NetError = True - End If - - Else -133 Registrar "Res_Web: Err -> No existian suficientes formularios" -134 NetError = True - End If - End If - -135 Case ed_java -136 Registrar "Res_Web: JAVA excutado" - -137 Case ed_navegar - 'No hacer nada - End Select - - End With - - Exit Sub -subError: -138 NetError = True - -139 Select Case Err.Number - - Case 91 -140 Registrar "++Error -> probablemente el router es incorrecto" - -141 Case Else -142 Registrar "++Error -> se desconoce la causa para un error #" & Err.Number - End Select - - ' - Exit Sub -res_Web_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.res_Web.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub res_Telnet() - 'Reseteo via telnet - '28/04/07 - 2.0.4: Unido con "Iniciar_Telnet", "Iniciar_Telnet" eliminado - ' - On Error GoTo res_Telnet_Err - ' -100 Registrar "+-[MODO TELNET] Enviando datos" - '102 MsgBox "Telnet Iniciado" -101 TelnetComandos() = Split(m_Datos.accionEX, ";") -102 Registrar "No. de comandos a enviar: " & UBound(TelnetComandos) + 1 -103 nComando = 0 -104 Call frmTelnet.ProcTelnet - ' - Exit Sub -res_Telnet_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.res_Telnet.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -'CSEH: Skip -Public Sub lpObjetoIE() - On Error Resume Next - KillTimer 0, hpObjetoIE - Set IE = CreateObject("InternetExplorer.Application") - - If IE Is Nothing Then - Registrar "+Objeto IE: no creado" - Exit Sub - End If - - IE.RegisterAsBrowser = True - IE.Visible = False - IE.Offline = False - IE.Silent = False - Registrar "+Objeto IE: creado" -End Sub - -Public Sub res_auro() - 'Reseteo via pagina web - ' - On Error GoTo res_auro_Err - ' -100 Registrar "+-[MODO WEB/AURONET] Enviando datos" - -101 With ppSocket -102 .Direccion = m_Datos.Direccion - End With - - ' - Exit Sub -res_auro_Err: - Controlar_Error Erl, Err.Description, "Reseter.NET.res_auro.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub +Attribute VB_Name = "NET" +Option Explicit +Dim hpObjetoIE As Long +Type IP + Cambio As Boolean + IP_Actual As String +End Type +Public Declare Function InternetGetConnectedState _ + Lib "wininet.dll" (ByRef lpdwFlags As Long, _ + ByVal dwReserved As Long) As Long +'Local system uses a LAN to connect to the Internet. +Public Const INTERNET_CONNECTION_LAN As Long = &H2 +'Offline +Public Const INTERNET_CONNECTION_OFFLINE As Long = &H20 + +Public Function GetNetConnectString() As Boolean + ' + On Error GoTo GetNetConnectString_Err + ' + Dim dwflags As Long + Dim msg As String + + If InternetGetConnectedState(dwflags, 0&) Then + If dwflags And INTERNET_CONNECTION_LAN Then + GetNetConnectString = True + End If + + If dwflags And INTERNET_CONNECTION_OFFLINE Then + GetNetConnectString = False + End If + + Else + GetNetConnectString = False + End If + + ' + Exit Function +GetNetConnectString_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.GetNetConnectString" + Resume Next + ' +End Function + +Public Function Cambio_IP() As IP + 'Idea original de sortux, implementado por Vlad y hosting por No-IP + 'Cambio: 22/03/07 + '1.0.16 -> Eliminado un "registrar "Enviando datos" innecesario + 'Cambio: 03/04/07 + '1.0.19 -> Detectar cambios + ' Ahora es función y devuelve del cambio de ip + ' Forzar recarga de pagina + ' + On Error GoTo Cambio_IP_Err + ' + Static AntiguaIp As String + Dim ActualIp As String + ActualIp = Trim$(pSocket.HTML_GET) + + If Len(ActualIp) > 16 Or Len(ActualIp) < 8 Then + Registrar "+IP Pública: imposible obtener." + Cambio_IP.Cambio = True + Exit Function + End If + + Cambio_IP.IP_Actual = ActualIp + Cambio_IP.Cambio = (ActualIp = AntiguaIp) + + If AntiguaIp = vbNullString Then AntiguaIp = GetSetting("Reseter4.0", "Datos", "UltimaIP", vbNullString) + Registrar "+IP Pública: " & ActualIp & IIf(ActualIp = AntiguaIp, " (La IP no cambió)", IIf(AntiguaIp = vbNullString, vbNullString, " (OK, antes era: " & AntiguaIp & ")")) + AntiguaIp = ActualIp + SaveSetting "Reseter4.0", "Datos", "UltimaIP", ActualIp + ' + Exit Function +Cambio_IP_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.Cambio_IP" + Resume Next + ' +End Function + +Public Sub Crear_Objeto_IE() + '100 Registrar "+Objeto IE: creando..." + ' + On Error GoTo Crear_Objeto_IE_Err + ' + hpObjetoIE = SetTimer(0, 0, 0, AddressOf lpObjetoIE) + ' + Exit Sub +Crear_Objeto_IE_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.Crear_Objeto_IE" + Resume Next + ' +End Sub + +Public Sub Destruir_Conexion() + ' + On Error GoTo Destruir_Conexion_Err + ' + Set IE = Nothing + ' + Exit Sub +Destruir_Conexion_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.Destruir_Conexion" + Resume Next + ' +End Sub + +Public Function RenovarLAN() As Long + ' + On Error GoTo RenovarLAN_Err + ' + RenovarLAN = ShellExecute(frmPrincipal.hWnd, "", "ipconfig /renew all", "", "", 0) + Registrar "~Renovación concluyó en " & RenovarLAN + ' + Exit Function +RenovarLAN_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.RenovarLAN" + Resume Next + ' +End Function + +Public Sub res_Web() + ' + On Error GoTo res_Web_Err + ' + On Error GoTo subError + 'Reseteo via pagina web + Registrar "+-[MODO WEB] Enviando datos" + + ' Si es reseteo WEB lo primero que tenemos que hacer es armar la direccion a la que + ' vamos a navegar en base a los datos del preprocesador + With IE + + 'Procesamos la dirección a navegar en base al tipo de acción. + Select Case m_Datos.accionTipo + + Case Is = ed_java + 'Si solo vamos a ejecutar Java, solo tenemos que pasar el comando como la dirección + m_Datos.Direccion = m_Datos.accionEX + + Case Else + 'En el caso de que vayamos a navegar o hacer clic, tenemos que contruir la direción + m_Datos.Direccion = "http://" & IIf(Len(m_Datos.usuario) <> 0, m_Datos.usuario & ":", vbNullString) & IIf(Len(m_Datos.clave) <> 0, m_Datos.clave & "@", vbNullString) & m_Datos.base & ":" & IIf(IsNumeric(m_Datos.puerto), m_Datos.puerto, 80) & m_Datos.accionEX + End Select + + If flag_Navegar Then .Navigate m_Datos.Direccion + Registrar "Res_Web => armado: '" & m_Datos.Direccion & "'" + + Do While .Busy + Esperar 0.1 + Loop + + Do While .ReadyState <> 4 + Esperar 0.1 + Loop + + frmWeb.txtLog.Text = "!!! " & m_Datos.Direccion + + Select Case m_Datos.accionTipo + + Case ed_clic + + If m_Datos.nForm = -1 And m_Datos.nCont = -1 Then + Registrar "# de Formulario y Control invalido." + Else + + If (.Document.Forms.Length - 1) >= m_Datos.nForm Then + If .Document.Forms(m_Datos.nForm).Length - 1 >= m_Datos.nCont Then + .Document.Forms(m_Datos.nForm)(m_Datos.nCont).Click + Registrar "Res_Web: Datos enviados [" & m_Datos.nForm & ", " & m_Datos.nCont & "]" + Else + Registrar "Res_Web: Err -> No existian suficientes controles" + NetError = True + End If + + Else + Registrar "Res_Web: Err -> No existian suficientes formularios" + NetError = True + End If + End If + + Case ed_llenar + + If m_Datos.nForm = -1 And m_Datos.nCont = -1 Then + Registrar "Sin datos, saltando de Llenado" + Else + + If (.Document.Forms.Length - 1) >= m_Datos.nForm Then + If .Document.Forms(m_Datos.nForm).Length - 1 >= m_Datos.nCont Then + .Document.Forms(m_Datos.nForm)(m_Datos.nCont).Value = m_Datos.accionEX2 + Registrar "Res_Web: Texto llenado" + Else + Registrar "Res_Web: Err -> No existian suficientes controles" + NetError = True + End If + + Else + Registrar "Res_Web: Err -> No existian suficientes formularios" + NetError = True + End If + End If + + Case ed_java + Registrar "Res_Web: JAVA excutado" + + Case ed_navegar + 'No hacer nada + End Select + + End With + + Exit Sub +subError: + NetError = True + + Select Case Err.Number + + Case 91 + Registrar "++Error -> probablemente el router es incorrecto" + + Case Else + Registrar "++Error -> se desconoce la causa para un error #" & Err.Number + End Select + + ' + Exit Sub +res_Web_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.res_Web" + Resume Next + ' +End Sub + +Public Sub res_Telnet() + 'Reseteo via telnet + '28/04/07 - 2.0.4: Unido con "Iniciar_Telnet", "Iniciar_Telnet" eliminado + ' + On Error GoTo res_Telnet_Err + ' + Registrar "+-[MODO TELNET] Enviando datos" + '102 MsgBox "Telnet Iniciado" + TelnetComandos() = Split(m_Datos.accionEX, ";") + Registrar "No. de comandos a enviar: " & UBound(TelnetComandos) + 1 + nComando = 0 + Call frmTelnet.ProcTelnet + ' + Exit Sub +res_Telnet_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.res_Telnet" + Resume Next + ' +End Sub + +'CSEH: Skip +Public Sub lpObjetoIE() + On Error Resume Next + KillTimer 0, hpObjetoIE + Set IE = CreateObject("InternetExplorer.Application") + + If IE Is Nothing Then + Registrar "+Objeto IE: no creado" + Exit Sub + End If + + IE.RegisterAsBrowser = True + IE.Visible = False + IE.Offline = False + IE.Silent = False + Registrar "+Objeto IE: creado" +End Sub + +Public Sub res_auro() + 'Reseteo via pagina web + ' + On Error GoTo res_auro_Err + ' + Registrar "+-[MODO WEB/AURONET] Enviando datos" + + With ppSocket + .Direccion = m_Datos.Direccion + End With + + ' + Exit Sub +res_auro_Err: + Controlar_Error Erl, Err.Description, "Reseter.NET.res_auro" + Resume Next + ' +End Sub diff --git a/bas/Vt100.bas b/bas/Vt100.bas dissimilarity index 80% index f3d7456..8361808 100755 --- a/bas/Vt100.bas +++ b/bas/Vt100.bas @@ -1,1044 +1,1044 @@ -Attribute VB_Name = "vt100" -Option Explicit -'Windows RECT structure -Private Type RECT - Left As Long - Top As Long - Right As Long - bottom As Long -End Type -Private Declare Function ScrollDC _ - Lib "user32" (ByVal hdc As Long, _ - ByVal dx As Long, _ - ByVal dy As Long, _ - lprcScroll As RECT, _ - lprcClip As RECT, _ - ByVal hRgnUpdate As Long, _ - lprcUpdate As RECT) As Long -Private Declare Function PatBlt _ - Lib "gdi32" (ByVal hdc As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ - ByVal nWidth As Long, _ - ByVal nHeight As Long, _ - ByVal dwRop As Long) As Long -Private Declare Function SetBkMode _ - Lib "gdi32" (ByVal hdc As Long, _ - ByVal nBkMode As Long) As Long -Private Declare Function TextOut _ - Lib "gdi32" _ - Alias "TextOutA" (ByVal hdc As Long, _ - ByVal x As Long, _ - ByVal y As Long, _ - ByVal lpString As String, _ - ByVal nCount As Long) As Long -Private Declare Function SetBkColor _ - Lib "gdi32" (ByVal hdc As Long, _ - ByVal crColor As Long) As Long -Private Declare Function GetBkColor _ - Lib "gdi32" (ByVal hdc As Long) As Long -Private Declare Function GetTextColor _ - Lib "gdi32" (ByVal hdc As Long) As Long -Private Declare Function SetTextColor _ - Lib "gdi32" (ByVal hdc As Long, _ - ByVal newcolor As Long) As Long -Private Declare Function IsCharAlpha _ - Lib "user32" _ - Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long -'=================== Ternary raster operations ============ -'Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern -'Private Const PATPAINT = &HFB0A09 ' (DWORD) dest = DPSnoo -'Private Const PATINVERT = &H5A0049 ' (DWORD) dest = pattern XOR dest -Private Const DSTINVERT = &H550009 ' (DWORD) dest = (NOT dest) -'Private Const BLACKNESS = &H42& ' (DWORD) dest = BLACK -'Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE -'Private Const TRANSPARENT = 1 -Private Const OPAQUE = 2 -Private Const GO_IAC1 = 6 -Private Const LinesPerPage = 25 -Private Const CharsPerLine = 80 -Private Const TabsPerPage = 20 -Private Const LastLine = LinesPerPage - 1 -Private Const LastChar = CharsPerLine - 1 -'Private Const LastTab = 19 -Private ScrImage(LinesPerPage) As String * CharsPerLine -Private ScrAttr(LinesPerPage) As String * CharsPerLine -Private Norm_Attr As String * CharsPerLine -Private Blank_Line As String * CharsPerLine -Private TermTextColor As Long -Private TermBkColor As Long -Private tabno As Integer -Private tab_table(TabsPerPage) As Integer -Private curattr As String -Private lprcScroll As RECT -Private lprcClip As RECT -Private hRgnUpdate As Integer -Private lprcUpdate As RECT -' -' Current Buffered Text waiting for output on screen -' -'Private outlen As Integer -' -' Flag to indicate that we're ready to run -' -Private FlagInit As Integer -Private CurX As Integer -Private CurY As Integer -Private SavecurX As Integer -Private SavecurY As Integer -Private InEscape As Boolean ' Processing an escape seq? -Private EscString As String ' String so far -Private charheight As Single -Private charWidth As Single -Private CurState As Boolean - -Public Function term_process_char(CH As Byte) - ' - On Error GoTo term_process_char_Err - - ' -100 If (InEscape) Then -101 Call term_escapeProcess(CH) - Else - -102 Select Case CH - - Case 0 - -103 Case 7 -104 Beep - -105 Case 8 - -106 If CurX > 0 Then ' if not at line begin -107 CurX = CurX - 1 ' adjust back 1 spc - End If - -108 Case 9 - Dim tY As Integer - -109 For tY = 0 To 19 - -110 If CurY < tab_table(tY) Then - Exit For - End If - - Next - -111 CurY = tab_table(tY) - -112 Case 10, 11, 12 - -113 If (CurY = LastLine) Then ' if line left on scrn -114 Call term_scroll_up ' .. scroll upwards -115 CurY = LastLine ' .. use blank line - Else -116 CurY = CurY + 1 ' goto next line - End If - -117 Case 13 -118 CurX = 0 - -119 Case 27 -120 InEscape = True -121 EscString = "" - -122 Case 255 -123 term_process_char = GO_IAC1 - -124 Case Else - ' if (CH > 31) Then ' And (CH < 128) -125 term_write CH -126 Mid$(ScrImage(CurY + 1), CurX, 1) = Chr$(CH) -127 Mid$(ScrAttr(CurY + 1), CurX, 1) = curattr - ' End If - End Select - - End If - - ' - Exit Function -term_process_char_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_process_char.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Public Sub term_CaretControl(TurnOff As Boolean) - ' - On Error GoTo term_CaretControl_Err - ' - Static SaveState As Boolean - -100 If TurnOff = True Then -101 SaveState = CurState -102 term_Carethide - Else - -103 If SaveState = True Then -104 term_Caretshow - End If - End If - - ' - Exit Sub -term_CaretControl_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_CaretControl.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_Carethide() - ' - On Error GoTo term_Carethide_Err - - ' -100 If CurState = True Then -101 If frmTelnet.WindowState <> 1 Then PatBlt frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT -102 CurState = False - End If - - ' - Exit Sub -term_Carethide_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_Carethide.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_Caretshow() - '------------------------------------------------------------------------ - ' term_CaretShow - ' - ' display the inverted block cursor on the screen. - ' currently uses PatBlt. - '------------------------------------------------------------------------ - ' - On Error GoTo term_Caretshow_Err - - ' -100 If frmTelnet.WindowState <> 1 Then PatBlt frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT -101 CurState = True - ' - Exit Sub -term_Caretshow_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_Caretshow.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Public Sub term_DriveCursor() - ' - On Error GoTo term_DriveCursor_Err - - ' -100 If CurState = False Then -101 Call term_Caretshow - Else -102 Call term_Carethide - End If - - ' - Exit Sub -term_DriveCursor_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_DriveCursor.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseBOL() - '------------------------------------------------------------------------ - ' term_eraseBOL - ' erase from beginning of current line - '------------------------------------------------------------------------ - ' - On Error GoTo term_eraseBOL_Err - - ' -100 If frmTelnet.WindowState <> 1 Then - ' PatBlt(frmTelnet.hdc, 0, CurY * charheight, curX * charWidth, charheight, BLACKNESS) -101 TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine - End If - -102 Mid$(ScrImage(CurY + 1), 1, CurX + 1) = Space$(CurX + 1) -103 Mid$(ScrAttr(CurY + 1), 1, CurX + 1) = String$(CurX + 1, "0") - ' - Exit Sub -term_eraseBOL_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBOL.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseBOS() - '------------------------------------------------------------------------ - ' term_eraseBOS - ' erase all lines from beginning of screen to and including current - '------------------------------------------------------------------------ - ' - On Error GoTo term_eraseBOS_Err - ' - Dim y As Integer - 'Erase the current line first -100 Call term_eraseBOL - - 'Erase everything up to current line -101 If (CurY > 0) Then -102 If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, 0, Space$(CharsPerLine * CurY + CurX), CharsPerLine * CurY + CurX - - ' reset screen buffer contents -103 For y = 1 To CurY -104 ScrImage(y) = Blank_Line -105 ScrAttr(y) = Norm_Attr - Next - - End If - - ' - Exit Sub -term_eraseBOS_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBOS.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseBUFFER() - ' - On Error GoTo term_eraseBUFFER_Err - ' - Dim i As Integer - -100 For i = 1 To LinesPerPage -101 ScrImage(i) = Blank_Line -102 ScrAttr(i) = Norm_Attr - Next - - ' - Exit Sub -term_eraseBUFFER_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBUFFER.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseEOL() - ' - ' Erase to End of Line - ' - ' - On Error GoTo term_eraseEOL_Err - - ' -100 If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, CurX * charWidth, CurY * charheight, Space$(CharsPerLine - CurX), CharsPerLine - CurX - 'Update screen buffer -101 Mid$(ScrImage(CurY + 1), CurX + 1, CharsPerLine - CurX) = Space$(CharsPerLine - CurX) -102 Mid$(ScrAttr(CurY + 1), CurX + 1, CharsPerLine - CurX) = String$(CharsPerLine - CurX, "0") - ' - Exit Sub -term_eraseEOL_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseEOL.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseEOS() - ' - ' Erase to end of screen - ' - ' - On Error GoTo term_eraseEOS_Err - ' - Dim y As Integer -100 Call term_eraseEOL - -101 If (CurY <> LastLine) Then -102 If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, (CurY + 1) * charheight, Space$((LastLine - CurY) * CharsPerLine), (LastLine - CurY) * CharsPerLine - -103 For y = CurY + 2 To LinesPerPage -104 ScrImage(y) = Blank_Line -105 ScrAttr(y) = Norm_Attr - Next - - End If - - ' - Exit Sub -term_eraseEOS_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseEOS.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseLINE() - ' Erase Line - ' - On Error GoTo term_eraseLINE_Err - - ' -100 If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine -101 ScrImage(CurY + 1) = Blank_Line -102 ScrAttr(CurY + 1) = Norm_Attr - ' - Exit Sub -term_eraseLINE_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseLINE.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub term_eraseSCREEN() - 'Assume that they want to repaint using the latest background color - ' - On Error GoTo term_eraseSCREEN_Err - ' -100 TermBkColor = GetBkColor(frmTelnet.hdc) -101 TermTextColor = GetTextColor(frmTelnet.hdc) -102 frmTelnet.BackColor = TermBkColor -103 frmTelnet.ForeColor = TermTextColor -104 term_eraseBUFFER -105 frmTelnet.Cls -106 CurX = 0 -107 CurY = 0 - ' - Exit Sub -term_eraseSCREEN_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseSCREEN.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Function term_escapeParseArg(s As String) As String - ' - ' PopArg takes the next argument (digits up to a ;) and - ' returns it. It also removes the arg and the ; from - ' the "s" - ' - On Error GoTo term_escapeParseArg_Err - ' - Dim i As Integer -100 i = InStr(s, ";") - -101 If i = 0 Then -102 term_escapeParseArg = s -103 s = "" - Else -104 term_escapeParseArg = Left$(s, i - 1) -105 s = Mid$(s, i + 1) - End If - - ' - Exit Function -term_escapeParseArg_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_escapeParseArg.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Sub term_escapeProcess(CH As Byte) - ' - On Error GoTo term_escapeProcess_Err - ' - Dim c As String - Dim yDiff As Integer - Dim xDiff As Integer -100 c = Chr$(CH) - -101 If EscString = "" Then - - 'No start character yet -102 Select Case c - - Case "[" - -103 Case "(" - -104 Case ")" - -105 Case "#" - -106 Case Chr$(8) ' embedded backspace -107 CurX = CurX - 1 -108 term_validatecurX -109 InEscape = False - -110 Case "7" ' save cursor - 'Save cursor position -111 SavecurX = CurX -112 SavecurY = CurY -113 InEscape = False - -114 Case "8" ' restore cursor - 'restore cursor position -115 CurX = SavecurX -116 CurY = SavecurY -117 InEscape = False - -118 Case "c" ' look at VSIreset() - -119 Case "D" ' cursor down -120 CurY = CurY + 1 -121 term_validatecurY -122 InEscape = False - -123 Case "E" ' next line -124 CurY = CurY + 1 -125 CurX = 0 -126 term_validatecurY -127 term_validatecurX -128 InEscape = False - -129 Case "H" ' set tab -130 tab_table(tabno) = CurY -131 tabno = tabno + 1 -132 InEscape = False - -133 Case "I" ' look at bp_ESC_I() -134 InEscape = False - -135 Case "M" ' cursor up -136 CurY = CurY - 1 -137 term_validatecurY - -138 Case "Z" ' send ident -139 InEscape = False - -140 Case Else -141 InEscape = False - Exit Sub - End Select - - End If - -142 EscString = EscString & c - -143 If IsCharAlpha(CH) = 0 Then - - ' Not a character ... -144 If Len(EscString) > 15 Then -145 InEscape = False - End If - - Exit Sub - End If - -146 Select Case c - - Case "A" - ' A ==> move cursor up -147 EscString = Mid$(EscString, 2) -148 yDiff = Val(term_escapeParseArg(EscString)) - -149 If yDiff = 0 Then -150 yDiff = 1 - End If - -151 CurY = CurY - yDiff -152 term_validatecurY - -153 Case "B" - ' B ==> move cursor down -154 EscString = Mid$(EscString, 2) -155 yDiff = Val(term_escapeParseArg(EscString)) - -156 If yDiff = 0 Then -157 yDiff = 1 - End If - -158 CurY = CurY + yDiff -159 term_validatecurY - -160 Case "C" - ' C ==> move cursor right -161 EscString = Mid$(EscString, 2) -162 xDiff = Val(term_escapeParseArg(EscString)) - -163 If xDiff = 0 Then -164 xDiff = 1 - End If - -165 CurX = CurX + xDiff -166 term_validatecurX - -167 Case "D" - ' D ==> move cursor left -168 EscString = Mid$(EscString, 2) -169 xDiff = Val(term_escapeParseArg(EscString)) - -170 If xDiff = 0 Then -171 xDiff = 1 - End If - -172 CurX = CurX - xDiff -173 term_validatecurX - -174 Case "H" - 'Goto cursor position indicated by escape sequence -175 EscString = Mid$(EscString, 2) -176 CurY = Val(term_escapeParseArg(EscString)) - 1 -177 term_validatecurY -178 CurX = Val(EscString) - 1 -179 term_validatecurX - -180 Case "J" - - 'Erase display -181 Select Case Val(Mid$(EscString, 2)) - - Case 0 - -182 If CurX = 0 And CurY = 0 Then -183 Call term_eraseSCREEN - Else -184 Call term_eraseEOS - End If - -185 Case 1 -186 Call term_eraseBOS - -187 Case 2 -188 Call term_eraseSCREEN - End Select - -189 Case "K" - - 'Erase line -190 Select Case Val(Mid$(EscString, 2)) - - Case 0 - 'erase to end of line -191 Call term_eraseEOL - -192 Case 1 - 'erase to end of line -193 Call term_eraseBOL - -194 Case 2 -195 Call term_eraseLINE - End Select - -196 Case "f" - 'Goto cursor position indicated by escape sequence -197 EscString = Mid$(EscString, 2) -198 CurY = Val(term_escapeParseArg(EscString)) - 1 -199 term_validatecurY -200 CurX = Val(EscString) - 1 -201 term_validatecurX - -202 Case "g" - ' clear tabs - Dim tY As Integer - -203 For tY = 0 To 19 -204 tab_table(tY) = 0 - Next - -205 Case "h" - 'restore cursor position -206 CurX = SavecurX -207 CurY = SavecurY - -208 Case "i" - - ' print though mode -209 Case "l" - 'Save cursor position -210 SavecurX = CurX -211 SavecurY = CurY - -212 Case "m" - 'Change text attributes, screen colors -213 EscString = Mid$(EscString, 2) - - Do -214 Call term_setattr(Chr$(Val(term_escapeParseArg(EscString)))) -215 Loop While EscString <> "" - -216 Case "r" - 'Set scrollable region -217 EscString = Mid$(EscString, 2) -218 lprcScroll.Top = (Val(term_escapeParseArg(EscString)) - 1) * charheight -219 lprcClip = lprcScroll - -220 Case "s" - 'Save cursor position -221 SavecurX = CurX -222 SavecurY = CurY - -223 Case "u" - 'restore cursor position -224 CurX = SavecurX -225 CurY = SavecurY - End Select - -226 InEscape = False -227 EscString = "" - ' - Exit Sub -term_escapeProcess_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_escapeProcess.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Public Sub term_init() - ' - On Error GoTo term_init_Err - - ' -100 With frmTelnet -101 .Cls - 'Get the pixel metrics of the current font -102 .FontUnderline = False -103 .FontItalic = False -104 .FontBold = False -105 .ScaleMode = 3 -106 charheight = frmTelnet.TextHeight("M") -107 charWidth = frmTelnet.TextWidth("M") - 'Set up the vt100 screen -108 .ScaleMode = 1 -109 .Height = (frmTelnet.Height - frmTelnet.ScaleHeight) + LinesPerPage * frmTelnet.TextHeight("M") -110 .Width = (frmTelnet.Width - frmTelnet.ScaleWidth) + CharsPerLine * frmTelnet.TextWidth("M") - 'Set the user scale of the display -111 .ScaleMode = 0 -112 .ScaleWidth = LinesPerPage -113 .ScaleWidth = CharsPerLine -114 .Scale 0 - LastChar, 0 - LastLine - 'Set up the scoll region and clip region structures -115 lprcScroll.Top = 0 -116 lprcScroll.Left = 0 -117 lprcScroll.Right = CharsPerLine * charWidth -118 lprcScroll.bottom = LinesPerPage * charheight -119 lprcClip = lprcScroll -120 hRgnUpdate = 0 - 'Initialize module level flags and variables -121 InEscape = False -122 CurState = False -123 curattr = "0" -124 CurX = 0 -125 CurY = 0 - 'Set the default foreground and background colors -126 SetBkMode frmTelnet.hdc, OPAQUE -127 .ForeColor = QBColor(15) -128 .BackColor = QBColor(0) -129 SetBkColor frmTelnet.hdc, frmTelnet.BackColor -130 SetTextColor frmTelnet.hdc, frmTelnet.ForeColor -131 TermTextColor = GetTextColor(frmTelnet.hdc) -132 TermBkColor = GetBkColor(frmTelnet.hdc) - 'Initialize repaint buffer -133 Norm_Attr = String$(CharsPerLine, "0") -134 Blank_Line = Space$(CharsPerLine) -135 term_eraseBUFFER -136 FlagInit = True - 'Do the cursor thing -137 term_Caretshow -138 .cursor_timer.Enabled = True - End With - - ' - Exit Sub -term_init_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_init.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Function Term_FindChange(InArray As String, _ - ByVal CurrentValue As String, _ - ByteLen As Integer) As Integer - ' - On Error GoTo Term_FindChange_Err - ' - Dim RetValue As Integer - Dim CurrentByte As Byte - Dim InByte() As Byte -100 CurrentByte = CurrentValue -101 InByte = InArray - -102 For RetValue = 1 To ByteLen - -103 If InByte(RetValue) <> CurrentByte Then - Exit For - End If - - Next - -104 Term_FindChange = RetValue - 1 - ' - Exit Function -Term_FindChange_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.Term_FindChange.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Function - -Public Sub term_redrawscreen() - ' - On Error GoTo term_redrawscreen_Err - - ' -100 If Not FlagInit Or frmTelnet.WindowState = 1 Then - Exit Sub - End If - - Dim oldcur As Boolean - Dim oldattr As String - Dim newattr As String - Dim y As Integer - Dim X1 As Integer - Dim X2 As Integer - Dim AttrChange As Integer - Dim tAttr As String * CharsPerLine - Dim tLine As String * CharsPerLine -101 oldcur = CurState -102 oldattr = curattr - -103 If Not frmTelnet.Receiving Then -104 Call term_Carethide - End If - -105 Call term_setattr("0") - -106 For y = 1 To LinesPerPage -107 tAttr = ScrAttr(y) -108 tLine = ScrImage(y) - -109 If (tAttr = Norm_Attr) Then - 'Normal Lines can be repainted directly -110 TextOut frmTelnet.hdc, 0, (y - 1) * charheight, tLine, CharsPerLine - Else - 'Complex lines must have attribute changes found using the - 'Term_function FindChange. -111 X1 = 1 'Start the scan on the complete line -112 X2 = CharsPerLine - -113 Do While (X2 > 0) -114 AttrChange = Term_FindChange(Mid$(tAttr, X1, X2), curattr, X2) -115 TextOut frmTelnet.hdc, (X1 - 1) * charWidth, (y - 1) * charheight, Mid$(tLine, X1, AttrChange), AttrChange -116 X2 = X2 - AttrChange - -117 If X2 > 0 Then -118 X1 = X1 + AttrChange -119 newattr = Mid$(tAttr, X1, 1) - -120 If newattr <> "0" Then -121 term_setattr newattr - Else -122 curattr = newattr - End If - End If - - Loop - - End If - - Next - -123 Call term_setattr(oldattr) - -124 If Not frmTelnet.Receiving Then -125 If oldcur = True Then -126 Call term_Caretshow - End If - End If - - ' - Exit Sub -term_redrawscreen_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_redrawscreen.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Sub term_scroll_up() - ' - On Error GoTo term_scroll_up_Err - ' - Dim i As Integer - Dim s As Integer - -100 If frmTelnet.WindowState <> 1 Then -101 ScrollDC frmTelnet.hdc, 0, -charheight, lprcScroll, lprcClip, hRgnUpdate, lprcUpdate -102 TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine - End If - - 'Update the redisplay buffer (only update the scrollable region) - 'Might consider making this a circular array so only one line - 'needs to be written per scroll, rather than relinking the array -103 s = (lprcScroll.Top \ charheight + 1) - -104 For i = s To LastLine -105 ScrImage(i) = ScrImage(i + 1) -106 ScrAttr(i) = ScrAttr(i + 1) - Next - -107 ScrImage(LinesPerPage) = Blank_Line -108 ScrAttr(LinesPerPage) = Norm_Attr - ' - Exit Sub -term_scroll_up_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_scroll_up.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Sub term_setattr(CH As String) - ' - On Error GoTo term_setattr_Err - - ' -100 With frmTelnet - -101 Select Case Asc(CH) - - Case 0 ' Normal - ' Attr_BitMap = Attr_Norm -102 .FontUnderline = False -103 .FontItalic = False -104 .FontBold = False -105 SetTextColor .hdc, TermTextColor -106 SetBkColor .hdc, TermBkColor - -107 Case 1 ' Bold - ' Attr_BitMap = Attr_BitMap And Attr_Norm -108 .FontBold = True - - ' SetTextColor(frmTelnet.hdc, QBColor(9)) -109 Case 5 ' Blinking - ' Attr_BitMap = Attr_BitMap And Attr_Blink -110 .FontItalic = True - - ' SetTextColor(frmTelnet.hdc, QBColor(3)) -111 Case 4 ' Underscore - ' Attr_BitMap = Attr_BitMap And Attr_Under -112 .FontUnderline = True - -113 Case 7 ' Reverse Video - ' Attr_BitMap = Attr_BitMap And ATTR_REVERSE -114 SetTextColor .hdc, TermBkColor -115 SetBkColor .hdc, TermTextColor - -116 Case 8 ' Cancel (Invisible) - 'Attr_BitMap = Attr_BitMap And ATTR_INVISIBLE -117 SetTextColor .hdc, TermBkColor -118 SetBkColor .hdc, TermBkColor - - '=============================================================== -119 Case 30 ' Black Foreground -120 SetTextColor .hdc, QBColor(0) - -121 Case 31 ' Red Foreground -122 SetTextColor .hdc, QBColor(4) - -123 Case 32 ' Green Foreground -124 SetTextColor .hdc, QBColor(2) - -125 Case 33 ' Yellow Foreground -126 SetTextColor .hdc, QBColor(14) - -127 Case 34 ' Blue Foreground -128 SetTextColor .hdc, QBColor(1) - -129 Case 35 ' Magenta Foreground -130 SetTextColor .hdc, QBColor(5) - -131 Case 36 ' Cyan Foreground -132 SetTextColor .hdc, QBColor(3) - -133 Case 37 ' White Foreground -134 SetTextColor .hdc, QBColor(15) - - '=============================================================== -135 Case 40 ' Black Background -136 SetBkColor .hdc, QBColor(0) - -137 Case 41 ' Red Background -138 SetBkColor .hdc, QBColor(4) - -139 Case 42 ' Green Background -140 SetBkColor .hdc, QBColor(2) - -141 Case 43 ' Yellow Background -142 SetBkColor .hdc, QBColor(14) - -143 Case 44 ' Blue Background -144 SetBkColor .hdc, QBColor(1) - -145 Case 45 ' Magenta Background -146 SetBkColor .hdc, QBColor(5) - -147 Case 46 ' Cyan Background -148 SetBkColor .hdc, QBColor(3) - -149 Case 47 ' White Background -150 SetBkColor .hdc, QBColor(15) - -151 Case Else - Exit Sub - End Select - - End With - -152 curattr = CH - ' - Exit Sub -term_setattr_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_setattr.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Sub term_validatecurX() - ' - On Error GoTo term_validatecurX_Err - - ' -100 If (CurX < 0) Then -101 CurX = 0 -102 ElseIf CurX > LastChar Then -103 CurX = LastChar - End If - - ' - Exit Sub -term_validatecurX_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_validatecurX.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Sub term_validatecurY() - ' - On Error GoTo term_validatecurY_Err - - ' -100 If (CurY < 0) Then -101 CurY = 0 -102 ElseIf CurY > LastLine Then -103 CurY = LastLine - End If - - ' - Exit Sub -term_validatecurY_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_validatecurY.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub - -Private Sub term_write(CH As Byte) - ' - On Error GoTo term_write_Err - - ' -100 If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, CurX * charWidth, CurY * charheight, Chr$(CH), 1 -101 If Not (CurX = LastChar) Then -102 CurX = CurX + 1 - End If - - ' - Exit Sub -term_write_Err: - Controlar_Error Erl, Err.Description, "Reseter.vt100.term_write.Ref 12/8/2008 : 08:11:21" - Resume Next - ' -End Sub +Attribute VB_Name = "vt100" +Option Explicit +'Windows RECT structure +Private Type RECT + Left As Long + Top As Long + Right As Long + bottom As Long +End Type +Private Declare Function ScrollDC _ + Lib "user32" (ByVal hdc As Long, _ + ByVal dx As Long, _ + ByVal dy As Long, _ + lprcScroll As RECT, _ + lprcClip As RECT, _ + ByVal hRgnUpdate As Long, _ + lprcUpdate As RECT) As Long +Private Declare Function PatBlt _ + Lib "gdi32" (ByVal hdc As Long, _ + ByVal x As Long, _ + ByVal y As Long, _ + ByVal nWidth As Long, _ + ByVal nHeight As Long, _ + ByVal dwRop As Long) As Long +Private Declare Function SetBkMode _ + Lib "gdi32" (ByVal hdc As Long, _ + ByVal nBkMode As Long) As Long +Private Declare Function TextOut _ + Lib "gdi32" _ + Alias "TextOutA" (ByVal hdc As Long, _ + ByVal x As Long, _ + ByVal y As Long, _ + ByVal lpString As String, _ + ByVal nCount As Long) As Long +Private Declare Function SetBkColor _ + Lib "gdi32" (ByVal hdc As Long, _ + ByVal crColor As Long) As Long +Private Declare Function GetBkColor _ + Lib "gdi32" (ByVal hdc As Long) As Long +Private Declare Function GetTextColor _ + Lib "gdi32" (ByVal hdc As Long) As Long +Private Declare Function SetTextColor _ + Lib "gdi32" (ByVal hdc As Long, _ + ByVal newcolor As Long) As Long +Private Declare Function IsCharAlpha _ + Lib "user32" _ + Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long +'=================== Ternary raster operations ============ +'Private Const PATCOPY = &HF00021 ' (DWORD) dest = pattern +'Private Const PATPAINT = &HFB0A09 ' (DWORD) dest = DPSnoo +'Private Const PATINVERT = &H5A0049 ' (DWORD) dest = pattern XOR dest +Private Const DSTINVERT = &H550009 ' (DWORD) dest = (NOT dest) +'Private Const BLACKNESS = &H42& ' (DWORD) dest = BLACK +'Private Const WHITENESS = &HFF0062 ' (DWORD) dest = WHITE +'Private Const TRANSPARENT = 1 +Private Const OPAQUE = 2 +Private Const GO_IAC1 = 6 +Private Const LinesPerPage = 25 +Private Const CharsPerLine = 80 +Private Const TabsPerPage = 20 +Private Const LastLine = LinesPerPage - 1 +Private Const LastChar = CharsPerLine - 1 +'Private Const LastTab = 19 +Private ScrImage(LinesPerPage) As String * CharsPerLine +Private ScrAttr(LinesPerPage) As String * CharsPerLine +Private Norm_Attr As String * CharsPerLine +Private Blank_Line As String * CharsPerLine +Private TermTextColor As Long +Private TermBkColor As Long +Private tabno As Integer +Private tab_table(TabsPerPage) As Integer +Private curattr As String +Private lprcScroll As RECT +Private lprcClip As RECT +Private hRgnUpdate As Integer +Private lprcUpdate As RECT +' +' Current Buffered Text waiting for output on screen +' +'Private outlen As Integer +' +' Flag to indicate that we're ready to run +' +Private FlagInit As Integer +Private CurX As Integer +Private CurY As Integer +Private SavecurX As Integer +Private SavecurY As Integer +Private InEscape As Boolean ' Processing an escape seq? +Private EscString As String ' String so far +Private charheight As Single +Private charWidth As Single +Private CurState As Boolean + +Public Function term_process_char(CH As Byte) + ' + On Error GoTo term_process_char_Err + + ' + If (InEscape) Then + Call term_escapeProcess(CH) + Else + + Select Case CH + + Case 0 + + Case 7 + Beep + + Case 8 + + If CurX > 0 Then ' if not at line begin + CurX = CurX - 1 ' adjust back 1 spc + End If + + Case 9 + Dim tY As Integer + + For tY = 0 To 19 + + If CurY < tab_table(tY) Then + Exit For + End If + + Next + + CurY = tab_table(tY) + + Case 10, 11, 12 + + If (CurY = LastLine) Then ' if line left on scrn + Call term_scroll_up ' .. scroll upwards + CurY = LastLine ' .. use blank line + Else + CurY = CurY + 1 ' goto next line + End If + + Case 13 + CurX = 0 + + Case 27 + InEscape = True + EscString = "" + + Case 255 + term_process_char = GO_IAC1 + + Case Else + ' if (CH > 31) Then ' And (CH < 128) + term_write CH + Mid$(ScrImage(CurY + 1), CurX, 1) = Chr$(CH) + Mid$(ScrAttr(CurY + 1), CurX, 1) = curattr + ' End If + End Select + + End If + + ' + Exit Function +term_process_char_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_process_char" + Resume Next + ' +End Function + +Public Sub term_CaretControl(TurnOff As Boolean) + ' + On Error GoTo term_CaretControl_Err + ' + Static SaveState As Boolean + + If TurnOff = True Then + SaveState = CurState + term_Carethide + Else + + If SaveState = True Then + term_Caretshow + End If + End If + + ' + Exit Sub +term_CaretControl_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_CaretControl" + Resume Next + ' +End Sub + +Private Sub term_Carethide() + ' + On Error GoTo term_Carethide_Err + + ' + If CurState = True Then + If frmTelnet.WindowState <> 1 Then PatBlt frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT + CurState = False + End If + + ' + Exit Sub +term_Carethide_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_Carethide" + Resume Next + ' +End Sub + +Private Sub term_Caretshow() + '------------------------------------------------------------------------ + ' term_CaretShow + ' + ' display the inverted block cursor on the screen. + ' currently uses PatBlt. + '------------------------------------------------------------------------ + ' + On Error GoTo term_Caretshow_Err + + ' + If frmTelnet.WindowState <> 1 Then PatBlt frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT + CurState = True + ' + Exit Sub +term_Caretshow_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_Caretshow" + Resume Next + ' +End Sub + +Public Sub term_DriveCursor() + ' + On Error GoTo term_DriveCursor_Err + + ' + If CurState = False Then + Call term_Caretshow + Else + Call term_Carethide + End If + + ' + Exit Sub +term_DriveCursor_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_DriveCursor" + Resume Next + ' +End Sub + +Private Sub term_eraseBOL() + '------------------------------------------------------------------------ + ' term_eraseBOL + ' erase from beginning of current line + '------------------------------------------------------------------------ + ' + On Error GoTo term_eraseBOL_Err + + ' + If frmTelnet.WindowState <> 1 Then + ' PatBlt(frmTelnet.hdc, 0, CurY * charheight, curX * charWidth, charheight, BLACKNESS) + TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine + End If + + Mid$(ScrImage(CurY + 1), 1, CurX + 1) = Space$(CurX + 1) + Mid$(ScrAttr(CurY + 1), 1, CurX + 1) = String$(CurX + 1, "0") + ' + Exit Sub +term_eraseBOL_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBOL" + Resume Next + ' +End Sub + +Private Sub term_eraseBOS() + '------------------------------------------------------------------------ + ' term_eraseBOS + ' erase all lines from beginning of screen to and including current + '------------------------------------------------------------------------ + ' + On Error GoTo term_eraseBOS_Err + ' + Dim y As Integer + 'Erase the current line first + Call term_eraseBOL + + 'Erase everything up to current line + If (CurY > 0) Then + If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, 0, Space$(CharsPerLine * CurY + CurX), CharsPerLine * CurY + CurX + + ' reset screen buffer contents + For y = 1 To CurY + ScrImage(y) = Blank_Line + ScrAttr(y) = Norm_Attr + Next + + End If + + ' + Exit Sub +term_eraseBOS_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBOS" + Resume Next + ' +End Sub + +Private Sub term_eraseBUFFER() + ' + On Error GoTo term_eraseBUFFER_Err + ' + Dim i As Integer + + For i = 1 To LinesPerPage + ScrImage(i) = Blank_Line + ScrAttr(i) = Norm_Attr + Next + + ' + Exit Sub +term_eraseBUFFER_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseBUFFER" + Resume Next + ' +End Sub + +Private Sub term_eraseEOL() + ' + ' Erase to End of Line + ' + ' + On Error GoTo term_eraseEOL_Err + + ' + If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, CurX * charWidth, CurY * charheight, Space$(CharsPerLine - CurX), CharsPerLine - CurX + 'Update screen buffer + Mid$(ScrImage(CurY + 1), CurX + 1, CharsPerLine - CurX) = Space$(CharsPerLine - CurX) + Mid$(ScrAttr(CurY + 1), CurX + 1, CharsPerLine - CurX) = String$(CharsPerLine - CurX, "0") + ' + Exit Sub +term_eraseEOL_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseEOL" + Resume Next + ' +End Sub + +Private Sub term_eraseEOS() + ' + ' Erase to end of screen + ' + ' + On Error GoTo term_eraseEOS_Err + ' + Dim y As Integer + Call term_eraseEOL + + If (CurY <> LastLine) Then + If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, (CurY + 1) * charheight, Space$((LastLine - CurY) * CharsPerLine), (LastLine - CurY) * CharsPerLine + + For y = CurY + 2 To LinesPerPage + ScrImage(y) = Blank_Line + ScrAttr(y) = Norm_Attr + Next + + End If + + ' + Exit Sub +term_eraseEOS_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseEOS" + Resume Next + ' +End Sub + +Private Sub term_eraseLINE() + ' Erase Line + ' + On Error GoTo term_eraseLINE_Err + + ' + If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine + ScrImage(CurY + 1) = Blank_Line + ScrAttr(CurY + 1) = Norm_Attr + ' + Exit Sub +term_eraseLINE_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseLINE" + Resume Next + ' +End Sub + +Private Sub term_eraseSCREEN() + 'Assume that they want to repaint using the latest background color + ' + On Error GoTo term_eraseSCREEN_Err + ' + TermBkColor = GetBkColor(frmTelnet.hdc) + TermTextColor = GetTextColor(frmTelnet.hdc) + frmTelnet.BackColor = TermBkColor + frmTelnet.ForeColor = TermTextColor + term_eraseBUFFER + frmTelnet.Cls + CurX = 0 + CurY = 0 + ' + Exit Sub +term_eraseSCREEN_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_eraseSCREEN" + Resume Next + ' +End Sub + +Private Function term_escapeParseArg(s As String) As String + ' + ' PopArg takes the next argument (digits up to a ;) and + ' returns it. It also removes the arg and the ; from + ' the "s" + ' + On Error GoTo term_escapeParseArg_Err + ' + Dim i As Integer + i = InStr(s, ";") + + If i = 0 Then + term_escapeParseArg = s + s = "" + Else + term_escapeParseArg = Left$(s, i - 1) + s = Mid$(s, i + 1) + End If + + ' + Exit Function +term_escapeParseArg_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_escapeParseArg" + Resume Next + ' +End Function + +Private Sub term_escapeProcess(CH As Byte) + ' + On Error GoTo term_escapeProcess_Err + ' + Dim c As String + Dim yDiff As Integer + Dim xDiff As Integer + c = Chr$(CH) + + If EscString = "" Then + + 'No start character yet + Select Case c + + Case "[" + + Case "(" + + Case ")" + + Case "#" + + Case Chr$(8) ' embedded backspace + CurX = CurX - 1 + term_validatecurX + InEscape = False + + Case "7" ' save cursor + 'Save cursor position + SavecurX = CurX + SavecurY = CurY + InEscape = False + + Case "8" ' restore cursor + 'restore cursor position + CurX = SavecurX + CurY = SavecurY + InEscape = False + + Case "c" ' look at VSIreset() + + Case "D" ' cursor down + CurY = CurY + 1 + term_validatecurY + InEscape = False + + Case "E" ' next line + CurY = CurY + 1 + CurX = 0 + term_validatecurY + term_validatecurX + InEscape = False + + Case "H" ' set tab + tab_table(tabno) = CurY + tabno = tabno + 1 + InEscape = False + + Case "I" ' look at bp_ESC_I() + InEscape = False + + Case "M" ' cursor up + CurY = CurY - 1 + term_validatecurY + + Case "Z" ' send ident + InEscape = False + + Case Else + InEscape = False + Exit Sub + End Select + + End If + + EscString = EscString & c + + If IsCharAlpha(CH) = 0 Then + + ' Not a character ... + If Len(EscString) > 15 Then + InEscape = False + End If + + Exit Sub + End If + + Select Case c + + Case "A" + ' A ==> move cursor up + EscString = Mid$(EscString, 2) + yDiff = Val(term_escapeParseArg(EscString)) + + If yDiff = 0 Then + yDiff = 1 + End If + + CurY = CurY - yDiff + term_validatecurY + + Case "B" + ' B ==> move cursor down + EscString = Mid$(EscString, 2) + yDiff = Val(term_escapeParseArg(EscString)) + + If yDiff = 0 Then + yDiff = 1 + End If + + CurY = CurY + yDiff + term_validatecurY + + Case "C" + ' C ==> move cursor right + EscString = Mid$(EscString, 2) + xDiff = Val(term_escapeParseArg(EscString)) + + If xDiff = 0 Then + xDiff = 1 + End If + + CurX = CurX + xDiff + term_validatecurX + + Case "D" + ' D ==> move cursor left + EscString = Mid$(EscString, 2) + xDiff = Val(term_escapeParseArg(EscString)) + + If xDiff = 0 Then + xDiff = 1 + End If + + CurX = CurX - xDiff + term_validatecurX + + Case "H" + 'Goto cursor position indicated by escape sequence + EscString = Mid$(EscString, 2) + CurY = Val(term_escapeParseArg(EscString)) - 1 + term_validatecurY + CurX = Val(EscString) - 1 + term_validatecurX + + Case "J" + + 'Erase display + Select Case Val(Mid$(EscString, 2)) + + Case 0 + + If CurX = 0 And CurY = 0 Then + Call term_eraseSCREEN + Else + Call term_eraseEOS + End If + + Case 1 + Call term_eraseBOS + + Case 2 + Call term_eraseSCREEN + End Select + + Case "K" + + 'Erase line + Select Case Val(Mid$(EscString, 2)) + + Case 0 + 'erase to end of line + Call term_eraseEOL + + Case 1 + 'erase to end of line + Call term_eraseBOL + + Case 2 + Call term_eraseLINE + End Select + + Case "f" + 'Goto cursor position indicated by escape sequence + EscString = Mid$(EscString, 2) + CurY = Val(term_escapeParseArg(EscString)) - 1 + term_validatecurY + CurX = Val(EscString) - 1 + term_validatecurX + + Case "g" + ' clear tabs + Dim tY As Integer + + For tY = 0 To 19 + tab_table(tY) = 0 + Next + + Case "h" + 'restore cursor position + CurX = SavecurX + CurY = SavecurY + + Case "i" + + ' print though mode + Case "l" + 'Save cursor position + SavecurX = CurX + SavecurY = CurY + + Case "m" + 'Change text attributes, screen colors + EscString = Mid$(EscString, 2) + + Do + Call term_setattr(Chr$(Val(term_escapeParseArg(EscString)))) + Loop While EscString <> "" + + Case "r" + 'Set scrollable region + EscString = Mid$(EscString, 2) + lprcScroll.Top = (Val(term_escapeParseArg(EscString)) - 1) * charheight + lprcClip = lprcScroll + + Case "s" + 'Save cursor position + SavecurX = CurX + SavecurY = CurY + + Case "u" + 'restore cursor position + CurX = SavecurX + CurY = SavecurY + End Select + + InEscape = False + EscString = "" + ' + Exit Sub +term_escapeProcess_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_escapeProcess" + Resume Next + ' +End Sub + +Public Sub term_init() + ' + On Error GoTo term_init_Err + + ' + With frmTelnet + .Cls + 'Get the pixel metrics of the current font + .FontUnderline = False + .FontItalic = False + .FontBold = False + .ScaleMode = 3 + charheight = frmTelnet.TextHeight("M") + charWidth = frmTelnet.TextWidth("M") + 'Set up the vt100 screen + .ScaleMode = 1 + .Height = (frmTelnet.Height - frmTelnet.ScaleHeight) + LinesPerPage * frmTelnet.TextHeight("M") + .Width = (frmTelnet.Width - frmTelnet.ScaleWidth) + CharsPerLine * frmTelnet.TextWidth("M") + 'Set the user scale of the display + .ScaleMode = 0 + .ScaleWidth = LinesPerPage + .ScaleWidth = CharsPerLine + .Scale 0 - LastChar, 0 - LastLine + 'Set up the scoll region and clip region structures + lprcScroll.Top = 0 + lprcScroll.Left = 0 + lprcScroll.Right = CharsPerLine * charWidth + lprcScroll.bottom = LinesPerPage * charheight + lprcClip = lprcScroll + hRgnUpdate = 0 + 'Initialize module level flags and variables + InEscape = False + CurState = False + curattr = "0" + CurX = 0 + CurY = 0 + 'Set the default foreground and background colors + SetBkMode frmTelnet.hdc, OPAQUE + .ForeColor = QBColor(15) + .BackColor = QBColor(0) + SetBkColor frmTelnet.hdc, frmTelnet.BackColor + SetTextColor frmTelnet.hdc, frmTelnet.ForeColor + TermTextColor = GetTextColor(frmTelnet.hdc) + TermBkColor = GetBkColor(frmTelnet.hdc) + 'Initialize repaint buffer + Norm_Attr = String$(CharsPerLine, "0") + Blank_Line = Space$(CharsPerLine) + term_eraseBUFFER + FlagInit = True + 'Do the cursor thing + term_Caretshow + .cursor_timer.Enabled = True + End With + + ' + Exit Sub +term_init_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_init" + Resume Next + ' +End Sub + +Private Function Term_FindChange(InArray As String, _ + ByVal CurrentValue As String, _ + ByteLen As Integer) As Integer + ' + On Error GoTo Term_FindChange_Err + ' + Dim RetValue As Integer + Dim CurrentByte As Byte + Dim InByte() As Byte + CurrentByte = CurrentValue + InByte = InArray + + For RetValue = 1 To ByteLen + + If InByte(RetValue) <> CurrentByte Then + Exit For + End If + + Next + + Term_FindChange = RetValue - 1 + ' + Exit Function +Term_FindChange_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.Term_FindChange" + Resume Next + ' +End Function + +Public Sub term_redrawscreen() + ' + On Error GoTo term_redrawscreen_Err + + ' + If Not FlagInit Or frmTelnet.WindowState = 1 Then + Exit Sub + End If + + Dim oldcur As Boolean + Dim oldattr As String + Dim newattr As String + Dim y As Integer + Dim X1 As Integer + Dim X2 As Integer + Dim AttrChange As Integer + Dim tAttr As String * CharsPerLine + Dim tLine As String * CharsPerLine + oldcur = CurState + oldattr = curattr + + If Not frmTelnet.Receiving Then + Call term_Carethide + End If + + Call term_setattr("0") + + For y = 1 To LinesPerPage + tAttr = ScrAttr(y) + tLine = ScrImage(y) + + If (tAttr = Norm_Attr) Then + 'Normal Lines can be repainted directly + TextOut frmTelnet.hdc, 0, (y - 1) * charheight, tLine, CharsPerLine + Else + 'Complex lines must have attribute changes found using the + 'Term_function FindChange. + X1 = 1 'Start the scan on the complete line + X2 = CharsPerLine + + Do While (X2 > 0) + AttrChange = Term_FindChange(Mid$(tAttr, X1, X2), curattr, X2) + TextOut frmTelnet.hdc, (X1 - 1) * charWidth, (y - 1) * charheight, Mid$(tLine, X1, AttrChange), AttrChange + X2 = X2 - AttrChange + + If X2 > 0 Then + X1 = X1 + AttrChange + newattr = Mid$(tAttr, X1, 1) + + If newattr <> "0" Then + term_setattr newattr + Else + curattr = newattr + End If + End If + + Loop + + End If + + Next + + Call term_setattr(oldattr) + + If Not frmTelnet.Receiving Then + If oldcur = True Then + Call term_Caretshow + End If + End If + + ' + Exit Sub +term_redrawscreen_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_redrawscreen" + Resume Next + ' +End Sub + +Private Sub term_scroll_up() + ' + On Error GoTo term_scroll_up_Err + ' + Dim i As Integer + Dim s As Integer + + If frmTelnet.WindowState <> 1 Then + ScrollDC frmTelnet.hdc, 0, -charheight, lprcScroll, lprcClip, hRgnUpdate, lprcUpdate + TextOut frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine + End If + + 'Update the redisplay buffer (only update the scrollable region) + 'Might consider making this a circular array so only one line + 'needs to be written per scroll, rather than relinking the array + s = (lprcScroll.Top \ charheight + 1) + + For i = s To LastLine + ScrImage(i) = ScrImage(i + 1) + ScrAttr(i) = ScrAttr(i + 1) + Next + + ScrImage(LinesPerPage) = Blank_Line + ScrAttr(LinesPerPage) = Norm_Attr + ' + Exit Sub +term_scroll_up_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_scroll_up" + Resume Next + ' +End Sub + +Private Sub term_setattr(CH As String) + ' + On Error GoTo term_setattr_Err + + ' + With frmTelnet + + Select Case Asc(CH) + + Case 0 ' Normal + ' Attr_BitMap = Attr_Norm + .FontUnderline = False + .FontItalic = False + .FontBold = False + SetTextColor .hdc, TermTextColor + SetBkColor .hdc, TermBkColor + + Case 1 ' Bold + ' Attr_BitMap = Attr_BitMap And Attr_Norm + .FontBold = True + + ' SetTextColor(frmTelnet.hdc, QBColor(9)) + Case 5 ' Blinking + ' Attr_BitMap = Attr_BitMap And Attr_Blink + .FontItalic = True + + ' SetTextColor(frmTelnet.hdc, QBColor(3)) + Case 4 ' Underscore + ' Attr_BitMap = Attr_BitMap And Attr_Under + .FontUnderline = True + + Case 7 ' Reverse Video + ' Attr_BitMap = Attr_BitMap And ATTR_REVERSE + SetTextColor .hdc, TermBkColor + SetBkColor .hdc, TermTextColor + + Case 8 ' Cancel (Invisible) + 'Attr_BitMap = Attr_BitMap And ATTR_INVISIBLE + SetTextColor .hdc, TermBkColor + SetBkColor .hdc, TermBkColor + + '=============================================================== + Case 30 ' Black Foreground + SetTextColor .hdc, QBColor(0) + + Case 31 ' Red Foreground + SetTextColor .hdc, QBColor(4) + + Case 32 ' Green Foreground + SetTextColor .hdc, QBColor(2) + + Case 33 ' Yellow Foreground + SetTextColor .hdc, QBColor(14) + + Case 34 ' Blue Foreground + SetTextColor .hdc, QBColor(1) + + Case 35 ' Magenta Foreground + SetTextColor .hdc, QBColor(5) + + Case 36 ' Cyan Foreground + SetTextColor .hdc, QBColor(3) + + Case 37 ' White Foreground + SetTextColor .hdc, QBColor(15) + + '=============================================================== + Case 40 ' Black Background + SetBkColor .hdc, QBColor(0) + + Case 41 ' Red Background + SetBkColor .hdc, QBColor(4) + + Case 42 ' Green Background + SetBkColor .hdc, QBColor(2) + + Case 43 ' Yellow Background + SetBkColor .hdc, QBColor(14) + + Case 44 ' Blue Background + SetBkColor .hdc, QBColor(1) + + Case 45 ' Magenta Background + SetBkColor .hdc, QBColor(5) + + Case 46 ' Cyan Background + SetBkColor .hdc, QBColor(3) + + Case 47 ' White Background + SetBkColor .hdc, QBColor(15) + + Case Else + Exit Sub + End Select + + End With + + curattr = CH + ' + Exit Sub +term_setattr_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_setattr" + Resume Next + ' +End Sub + +Private Sub term_validatecurX() + ' + On Error GoTo term_validatecurX_Err + + ' + If (CurX < 0) Then + CurX = 0 + ElseIf CurX > LastChar Then + CurX = LastChar + End If + + ' + Exit Sub +term_validatecurX_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_validatecurX" + Resume Next + ' +End Sub + +Private Sub term_validatecurY() + ' + On Error GoTo term_validatecurY_Err + + ' + If (CurY < 0) Then + CurY = 0 + ElseIf CurY > LastLine Then + CurY = LastLine + End If + + ' + Exit Sub +term_validatecurY_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_validatecurY" + Resume Next + ' +End Sub + +Private Sub term_write(CH As Byte) + ' + On Error GoTo term_write_Err + + ' + If frmTelnet.WindowState <> 1 Then TextOut frmTelnet.hdc, CurX * charWidth, CurY * charheight, Chr$(CH), 1 + If Not (CurX = LastChar) Then + CurX = CurX + 1 + End If + + ' + Exit Sub +term_write_Err: + Controlar_Error Erl, Err.Description, "Reseter.vt100.term_write" + Resume Next + ' +End Sub diff --git a/bas/modAppIcon.bas b/bas/modAppIcon.bas index 6aac160..9b044bc 100755 --- a/bas/modAppIcon.bas +++ b/bas/modAppIcon.bas @@ -30,40 +30,40 @@ Private Const ICON_BIG = 1 Private Const IDI_WINLOGO = 32517& Public Function SetAppIcon(obj As Object) As Boolean - ' - On Error GoTo SetAppIcon_Err - ' - Dim hIcon As Long - Dim hWnd As Long - Dim nRet As Long + ' + On Error GoTo SetAppIcon_Err + ' + Dim hIcon As Long + Dim hWnd As Long + Dim nRet As Long -100 If TypeOf obj Is Form Or TypeOf obj Is MDIForm Then - ' Get top-level hidden window -101 nRet = GetWindowLong(obj.hWnd, GWL_HWNDPARENT) + If TypeOf obj Is Form Or TypeOf obj Is MDIForm Then + ' Get top-level hidden window + nRet = GetWindowLong(obj.hWnd, GWL_HWNDPARENT) -102 Do While nRet -103 hWnd = nRet -104 nRet = GetWindowLong(hWnd, GWL_HWNDPARENT) - Loop + Do While nRet + hWnd = nRet + nRet = GetWindowLong(hWnd, GWL_HWNDPARENT) + Loop - ' Get a handle to icon -105 hIcon = SendMessage(obj.hWnd, WM_GETICON, ICON_BIG, ByVal 0&) + ' Get a handle to icon + hIcon = SendMessage(obj.hWnd, WM_GETICON, ICON_BIG, ByVal 0&) -106 If hIcon = 0 Then - ' Load default waving-flag logo -107 hIcon = LoadIcon(0, ByVal IDI_WINLOGO) - End If - - ' Pass form icon as new app icon -108 Call SendMessage(hWnd, WM_SETICON, ICON_BIG, ByVal hIcon) - ' See if change took -109 SetAppIcon = (hIcon = SendMessage(hWnd, WM_GETICON, ICON_BIG, ByVal 0&)) + If hIcon = 0 Then + ' Load default waving-flag logo + hIcon = LoadIcon(0, ByVal IDI_WINLOGO) End If - ' - Exit Function + ' Pass form icon as new app icon + Call SendMessage(hWnd, WM_SETICON, ICON_BIG, ByVal hIcon) + ' See if change took + SetAppIcon = (hIcon = SendMessage(hWnd, WM_GETICON, ICON_BIG, ByVal 0&)) + End If + + ' + Exit Function SetAppIcon_Err: - Controlar_Error Erl, Err.Description, "Reseter.modAppIcon.SetAppIcon.Ref 12/8/2008 : 08:11:23" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.modAppIcon.SetAppIcon" + Resume Next + ' End Function diff --git a/bas/modBasico.bas b/bas/modBasico.bas index 319d864..1809086 100755 --- a/bas/modBasico.bas +++ b/bas/modBasico.bas @@ -56,48 +56,48 @@ Public Declare Function KillTimer _ ByVal nIDEvent As Long) As Long Public Sub Esperar(lNumberOfSeconds As Single) - ' - On Error GoTo Esperar_Err - ' - Dim ft As FILETIME - Dim lBusy As Long - Dim dblDelay As Double - Dim dblDelayLow As Double - Dim dblUnits As Double - Dim hTimer As Long -100 hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer") + ' + On Error GoTo Esperar_Err + ' + Dim ft As FILETIME + Dim lBusy As Long + Dim dblDelay As Double + Dim dblDelayLow As Double + Dim dblUnits As Double + Dim hTimer As Long + hTimer = CreateWaitableTimer(0, True, App.EXEName & "Timer") -101 If Err.LastDllError <> ERROR_ALREADY_EXISTS Then -102 ft.dwLowDateTime = -1 -103 ft.dwHighDateTime = -1 -104 SetWaitableTimer hTimer, ft, 0, 0, 0, 0 - End If + If Err.LastDllError <> ERROR_ALREADY_EXISTS Then + ft.dwLowDateTime = -1 + ft.dwHighDateTime = -1 + SetWaitableTimer hTimer, ft, 0, 0, 0, 0 + End If -105 dblUnits = CDbl(&H10000) * CDbl(&H10000) -106 dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000 -107 ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1 -108 dblDelayLow = -dblUnits * (dblDelay / dblUnits - Fix(dblDelay / dblUnits)) + dblUnits = CDbl(&H10000) * CDbl(&H10000) + dblDelay = CDbl(lNumberOfSeconds) * 1000 * 10000 + ft.dwHighDateTime = -CLng(dblDelay / dblUnits) - 1 + dblDelayLow = -dblUnits * (dblDelay / dblUnits - Fix(dblDelay / dblUnits)) -109 If dblDelayLow < CDbl(&H80000000) Then -110 dblDelayLow = dblUnits + dblDelayLow -111 ft.dwHighDateTime = ft.dwHighDateTime + 1 - End If + If dblDelayLow < CDbl(&H80000000) Then + dblDelayLow = dblUnits + dblDelayLow + ft.dwHighDateTime = ft.dwHighDateTime + 1 + End If -112 ft.dwLowDateTime = CLng(dblDelayLow) -113 SetWaitableTimer hTimer, ft, 0, 0, 0, False + ft.dwLowDateTime = CLng(dblDelayLow) + SetWaitableTimer hTimer, ft, 0, 0, 0, False - Do -114 lBusy = MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT&) + Do + lBusy = MsgWaitForMultipleObjects(1, hTimer, False, INFINITE, QS_ALLINPUT&) -115 DoEvents -116 Loop Until lBusy = WAIT_OBJECT_0 + DoEvents + Loop Until lBusy = WAIT_OBJECT_0 - ' Close the handles when you are done with them. -117 CloseHandle hTimer - ' - Exit Sub + ' Close the handles when you are done with them. + CloseHandle hTimer + ' + Exit Sub Esperar_Err: - Controlar_Error Erl, Err.Description, "Reseter.modBasico.Esperar.Ref 12/8/2008 : 08:11:21" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.modBasico.Esperar" + Resume Next + ' End Sub diff --git a/bas/modEth.bas b/bas/modEth.bas dissimilarity index 64% index 2876382..3b3ca8c 100755 --- a/bas/modEth.bas +++ b/bas/modEth.bas @@ -1,193 +1,193 @@ -Attribute VB_Name = "modEth" -Option Explicit -' -Public EthGateWay As String -' -Public Const MAX_HOSTNAME_LEN = 132 -Public Const MAX_DOMAIN_NAME_LEN = 132 -Public Const MAX_SCOPE_ID_LEN = 260 -Public Const MAX_ADAPTER_NAME_LENGTH = 260 -Public Const MAX_ADAPTER_ADDRESS_LENGTH = 8 -Public Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132 -Public Const ERROR_BUFFER_OVERFLOW = 111 -Public Const MIB_IF_TYPE_ETHERNET = 1 -Public Const MIB_IF_TYPE_TOKENRING = 2 -Public Const MIB_IF_TYPE_FDDI = 3 -Public Const MIB_IF_TYPE_PPP = 4 -Public Const MIB_IF_TYPE_LOOPBACK = 5 -Public Const MIB_IF_TYPE_SLIP = 6 -Type IP_ADDR_STRING -Next As Long - -IpAddress As String * 16 -IpMask As String * 16 -Context As Long -End Type -Type IP_ADAPTER_INFO -Next As Long - -ComboIndex As Long -AdapterName As String * MAX_ADAPTER_NAME_LENGTH -Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH -AddressLength As Long -Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte -Index As Long -Type As Long - DhcpEnabled As Long - CurrentIpAddress As Long - IpAddressList As IP_ADDR_STRING - GatewayList As IP_ADDR_STRING - DhcpServer As IP_ADDR_STRING - HaveWins As Boolean - PrimaryWinsServer As IP_ADDR_STRING - SecondaryWinsServer As IP_ADDR_STRING - LeaseObtained As Long - LeaseExpires As Long -End Type -Type FIXED_INFO - HostName As String * MAX_HOSTNAME_LEN - - DomainName As String * MAX_DOMAIN_NAME_LEN - CurrentDnsServer As Long - DnsServerList As IP_ADDR_STRING - NodeType As Long - ScopeId As String * MAX_SCOPE_ID_LEN - EnableRouting As Long - EnableProxy As Long - EnableDns As Long -End Type -Public Declare Function GetNetworkParams _ - Lib "IPHlpApi" (FixedInfo As Any, _ - pOutBufLen As Long) As Long -Public Declare Function GetAdaptersInfo _ - Lib "IPHlpApi" (IpAdapterInfo As Any, _ - pOutBufLen As Long) As Long -Public Declare Sub CopyMemory _ - Lib "kernel32" _ - Alias "RtlMoveMemory" (Destination As Any, _ - Source As Any, _ - ByVal Length As Long) - -Sub EthInfo() - ' - On Error GoTo EthInfo_Err - ' - Dim error As Long - Dim FixedInfoSize As Long - Dim AdapterInfoSize As Long - Dim i As Integer - Dim PhysicalAddress As String - Dim NewTime As Date - Dim AdapterInfo As IP_ADAPTER_INFO - Dim Adapt As IP_ADAPTER_INFO - Dim AddrStr As IP_ADDR_STRING - Dim FixedInfo As FIXED_INFO - Dim Buffer As IP_ADDR_STRING - Dim pAddrStr As Long - Dim pAdapt As Long - Dim Buffer2 As IP_ADAPTER_INFO - Dim FixedInfoBuffer() As Byte - Dim AdapterInfoBuffer() As Byte - 'Get the main IP configuration information for this machine using a FIXED_INFO structure -100 FixedInfoSize = 0 -101 error = GetNetworkParams(ByVal 0&, FixedInfoSize) - -102 If error <> 0 Then -103 If error <> ERROR_BUFFER_OVERFLOW Then - ' MsgBox "GetNetworkParams sizing failed with error " & error - Exit Sub - End If - End If - -104 ReDim FixedInfoBuffer(FixedInfoSize - 1) -105 error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize) - -106 If error = 0 Then -107 CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo) - ' MsgBox "Host Name: " & FixedInfo.HostName - ' MsgBox "DNS Servers: " & FixedInfo.DnsServerList.IpAddress -108 pAddrStr = FixedInfo.DnsServerList.Next - -109 Do While pAddrStr <> 0 -110 CopyMemory Buffer, ByVal pAddrStr, Len(Buffer) - ' MsgBox "DNS Servers: " & Buffer.IpAddress -111 pAddrStr = Buffer.Next - Loop - - ' MsgBox "NetBIOS Scope ID: " & FixedInfo.ScopeId -112 If FixedInfo.EnableRouting Then - ' MsgBox "IP Routing Enabled " - Else - ' MsgBox "IP Routing not enabled" - End If - -113 If FixedInfo.EnableProxy Then - ' MsgBox "WINS Proxy Enabled " - Else - ' MsgBox "WINS Proxy not Enabled " - End If - -114 If FixedInfo.EnableDns Then - ' MsgBox "NetBIOS Resolution Uses DNS " - Else - ' MsgBox "NetBIOS Resolution Does not use DNS " - End If - - Else - ' MsgBox "GetNetworkParams failed with error " & error - Exit Sub - End If - - 'Enumerate all of the adapter specific information using the IP_ADAPTER_INFO structure. - 'Note: IP_ADAPTER_INFO contains a linked list of adapter entries. -115 AdapterInfoSize = 0 -116 error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize) - -117 If error <> 0 Then -118 If error <> ERROR_BUFFER_OVERFLOW Then - ' MsgBox "GetAdaptersInfo sizing failed with error " & error - Exit Sub - End If - End If - -119 ReDim AdapterInfoBuffer(AdapterInfoSize - 1) - ' Get actual adapter information -120 error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) - -121 If error <> 0 Then - ' MsgBox "GetAdaptersInfo failed with error " & error - Exit Sub - End If - -122 CopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo) -123 pAdapt = AdapterInfo.Next -124 CopyMemory Buffer2, AdapterInfo, Len(Buffer2) - - ' MsgBox " AdapterName: " & Buffer2.AdapterName - ' MsgBox "AdapterDescription: " & Buffer2.Description -125 For i = 0 To Buffer2.AddressLength - 1 -126 PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i)) - -127 If i < Buffer2.AddressLength - 1 Then -128 PhysicalAddress = PhysicalAddress & "-" - End If - - Next - - ' MsgBox "Physical Address: " & PhysicalAddress -129 If Buffer2.DhcpEnabled Then - ' MsgBox "DHCP Enabled " - Else - ' MsgBox "DHCP disabled" - End If - -130 pAddrStr = Buffer2.IpAddressList.Next - ' MsgBox "Default Gateway: " & Buffer2.GatewayList.IpAddress -131 EthGateWay = Replace$(Buffer2.GatewayList.IpAddress, Chr(0), "") - ' - Exit Sub -EthInfo_Err: - Controlar_Error Erl, Err.Description, "Reseter.modEth.EthInfo.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub +Attribute VB_Name = "modEth" +Option Explicit +' +Public EthGateWay As String +' +Public Const MAX_HOSTNAME_LEN = 132 +Public Const MAX_DOMAIN_NAME_LEN = 132 +Public Const MAX_SCOPE_ID_LEN = 260 +Public Const MAX_ADAPTER_NAME_LENGTH = 260 +Public Const MAX_ADAPTER_ADDRESS_LENGTH = 8 +Public Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132 +Public Const ERROR_BUFFER_OVERFLOW = 111 +Public Const MIB_IF_TYPE_ETHERNET = 1 +Public Const MIB_IF_TYPE_TOKENRING = 2 +Public Const MIB_IF_TYPE_FDDI = 3 +Public Const MIB_IF_TYPE_PPP = 4 +Public Const MIB_IF_TYPE_LOOPBACK = 5 +Public Const MIB_IF_TYPE_SLIP = 6 +Type IP_ADDR_STRING +Next As Long + +IpAddress As String * 16 +IpMask As String * 16 +Context As Long +End Type +Type IP_ADAPTER_INFO +Next As Long + +ComboIndex As Long +AdapterName As String * MAX_ADAPTER_NAME_LENGTH +Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH +AddressLength As Long +Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte +Index As Long +Type As Long + DhcpEnabled As Long + CurrentIpAddress As Long + IpAddressList As IP_ADDR_STRING + GatewayList As IP_ADDR_STRING + DhcpServer As IP_ADDR_STRING + HaveWins As Boolean + PrimaryWinsServer As IP_ADDR_STRING + SecondaryWinsServer As IP_ADDR_STRING + LeaseObtained As Long + LeaseExpires As Long +End Type +Type FIXED_INFO + HostName As String * MAX_HOSTNAME_LEN + + DomainName As String * MAX_DOMAIN_NAME_LEN + CurrentDnsServer As Long + DnsServerList As IP_ADDR_STRING + NodeType As Long + ScopeId As String * MAX_SCOPE_ID_LEN + EnableRouting As Long + EnableProxy As Long + EnableDns As Long +End Type +Public Declare Function GetNetworkParams _ + Lib "IPHlpApi" (FixedInfo As Any, _ + pOutBufLen As Long) As Long +Public Declare Function GetAdaptersInfo _ + Lib "IPHlpApi" (IpAdapterInfo As Any, _ + pOutBufLen As Long) As Long +Public Declare Sub CopyMemory _ + Lib "kernel32" _ + Alias "RtlMoveMemory" (Destination As Any, _ + Source As Any, _ + ByVal Length As Long) + +Sub EthInfo() + ' + On Error GoTo EthInfo_Err + ' + Dim error As Long + Dim FixedInfoSize As Long + Dim AdapterInfoSize As Long + Dim i As Integer + Dim PhysicalAddress As String + Dim NewTime As Date + Dim AdapterInfo As IP_ADAPTER_INFO + Dim Adapt As IP_ADAPTER_INFO + Dim AddrStr As IP_ADDR_STRING + Dim FixedInfo As FIXED_INFO + Dim Buffer As IP_ADDR_STRING + Dim pAddrStr As Long + Dim pAdapt As Long + Dim Buffer2 As IP_ADAPTER_INFO + Dim FixedInfoBuffer() As Byte + Dim AdapterInfoBuffer() As Byte + 'Get the main IP configuration information for this machine using a FIXED_INFO structure + FixedInfoSize = 0 + error = GetNetworkParams(ByVal 0&, FixedInfoSize) + + If error <> 0 Then + If error <> ERROR_BUFFER_OVERFLOW Then + ' MsgBox "GetNetworkParams sizing failed with error " & error + Exit Sub + End If + End If + + ReDim FixedInfoBuffer(FixedInfoSize - 1) + error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize) + + If error = 0 Then + CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo) + ' MsgBox "Host Name: " & FixedInfo.HostName + ' MsgBox "DNS Servers: " & FixedInfo.DnsServerList.IpAddress + pAddrStr = FixedInfo.DnsServerList.Next + + Do While pAddrStr <> 0 + CopyMemory Buffer, ByVal pAddrStr, Len(Buffer) + ' MsgBox "DNS Servers: " & Buffer.IpAddress + pAddrStr = Buffer.Next + Loop + + ' MsgBox "NetBIOS Scope ID: " & FixedInfo.ScopeId + If FixedInfo.EnableRouting Then + ' MsgBox "IP Routing Enabled " + Else + ' MsgBox "IP Routing not enabled" + End If + + If FixedInfo.EnableProxy Then + ' MsgBox "WINS Proxy Enabled " + Else + ' MsgBox "WINS Proxy not Enabled " + End If + + If FixedInfo.EnableDns Then + ' MsgBox "NetBIOS Resolution Uses DNS " + Else + ' MsgBox "NetBIOS Resolution Does not use DNS " + End If + + Else + ' MsgBox "GetNetworkParams failed with error " & error + Exit Sub + End If + + 'Enumerate all of the adapter specific information using the IP_ADAPTER_INFO structure. + 'Note: IP_ADAPTER_INFO contains a linked list of adapter entries. + AdapterInfoSize = 0 + error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize) + + If error <> 0 Then + If error <> ERROR_BUFFER_OVERFLOW Then + ' MsgBox "GetAdaptersInfo sizing failed with error " & error + Exit Sub + End If + End If + + ReDim AdapterInfoBuffer(AdapterInfoSize - 1) + ' Get actual adapter information + error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) + + If error <> 0 Then + ' MsgBox "GetAdaptersInfo failed with error " & error + Exit Sub + End If + + CopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo) + pAdapt = AdapterInfo.Next + CopyMemory Buffer2, AdapterInfo, Len(Buffer2) + + ' MsgBox " AdapterName: " & Buffer2.AdapterName + ' MsgBox "AdapterDescription: " & Buffer2.Description + For i = 0 To Buffer2.AddressLength - 1 + PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i)) + + If i < Buffer2.AddressLength - 1 Then + PhysicalAddress = PhysicalAddress & "-" + End If + + Next + + ' MsgBox "Physical Address: " & PhysicalAddress + If Buffer2.DhcpEnabled Then + ' MsgBox "DHCP Enabled " + Else + ' MsgBox "DHCP disabled" + End If + + pAddrStr = Buffer2.IpAddressList.Next + ' MsgBox "Default Gateway: " & Buffer2.GatewayList.IpAddress + EthGateWay = Replace$(Buffer2.GatewayList.IpAddress, Chr(0), "") + ' + Exit Sub +EthInfo_Err: + Controlar_Error Erl, Err.Description, "Reseter.modEth.EthInfo" + Resume Next + ' +End Sub diff --git a/bas/modNetInfo.bas b/bas/modNetInfo.bas dissimilarity index 72% index 760c560..bd8c0fd 100755 --- a/bas/modNetInfo.bas +++ b/bas/modNetInfo.bas @@ -1,282 +1,282 @@ -Attribute VB_Name = "modNetInfo" -Public Const MAX_HOSTNAME_LEN = 132 -Public Const MAX_DOMAIN_NAME_LEN = 132 -Public Const MAX_SCOPE_ID_LEN = 260 -Public Const MAX_ADAPTER_NAME_LENGTH = 260 -Public Const MAX_ADAPTER_ADDRESS_LENGTH = 8 -Public Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132 -Public Const ERROR_BUFFER_OVERFLOW = 111 -Public Const MIB_IF_TYPE_ETHERNET = 1 -Public Const MIB_IF_TYPE_TOKENRING = 2 -Public Const MIB_IF_TYPE_FDDI = 3 -Public Const MIB_IF_TYPE_PPP = 4 -Public Const MIB_IF_TYPE_LOOPBACK = 5 -Public Const MIB_IF_TYPE_SLIP = 6 -Type IP_ADDR_STRING - iNext As Long - IpAddress As String * 16 - IpMask As String * 16 - Context As Long -End Type -Type IP_ADAPTER_INFO - iNext As Long - ComboIndex As Long - AdapterName As String * MAX_ADAPTER_NAME_LENGTH - Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH - AddressLength As Long - Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte - Index As Long - Type As Long - DhcpEnabled As Long - CurrentIpAddress As Long - IpAddressList As IP_ADDR_STRING - GatewayList As IP_ADDR_STRING - DhcpServer As IP_ADDR_STRING - HaveWins As Boolean - PrimaryWinsServer As IP_ADDR_STRING - SecondaryWinsServer As IP_ADDR_STRING - LeaseObtained As Long - LeaseExpires As Long - End Type - Type FIXED_INFO - HostName As String * MAX_HOSTNAME_LEN - - DomainName As String * MAX_DOMAIN_NAME_LEN - CurrentDnsServer As Long - DnsServerList As IP_ADDR_STRING - NodeType As Long - ScopeId As String * MAX_SCOPE_ID_LEN - EnableRouting As Long - EnableProxy As Long - EnableDns As Long - End Type - Public Declare Function GetNetworkParams _ - Lib "IPHlpApi" (FixedInfo As Any, _ - pOutBufLen As Long) As Long - Public Declare Function GetAdaptersInfo _ - Lib "IPHlpApi" (IpAdapterInfo As Any, _ - pOutBufLen As Long) As Long - Public Declare Sub CopyMemory _ - Lib "kernel32" _ - Alias "RtlMoveMemory" (Destination As Any, _ - Source As Any, _ - ByVal Length As Long) - -Sub ObtenerNetInfo() - 'This example was created by George Bernier (bernig@dinomail.qc.ca) - ' - On Error GoTo ObtenerNetInfo_Err - ' - Dim error As Long - Dim FixedInfoSize As Long - Dim AdapterInfoSize As Long - Dim i As Integer - Dim PhysicalAddress As String - Dim NewTime As Date - Dim AdapterInfo As IP_ADAPTER_INFO - Dim Adapt As IP_ADAPTER_INFO - Dim AddrStr As IP_ADDR_STRING - Dim FixedInfo As FIXED_INFO - Dim Buffer As IP_ADDR_STRING - Dim pAddrStr As Long - Dim pAdapt As Long - Dim Buffer2 As IP_ADAPTER_INFO - Dim FixedInfoBuffer() As Byte - Dim AdapterInfoBuffer() As Byte - 'Get the main IP configuration information for this machine using a FIXED_INFO structure -100 FixedInfoSize = 0 -101 error = GetNetworkParams(ByVal 0&, FixedInfoSize) - -102 If error <> 0 Then -103 If error <> ERROR_BUFFER_OVERFLOW Then -104 MsgBox "GetNetworkParams sizing failed with error " & error - Exit Sub - End If - End If - -105 ReDim FixedInfoBuffer(FixedInfoSize - 1) -106 error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize) - -107 If error = 0 Then -108 CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo) -109 frm1.lblhost = FixedInfo.HostName 'host name -110 frm1.lbldns1 = FixedInfo.DnsServerList.IpAddress 'dns server IP -111 pAddrStr = FixedInfo.DnsServerList.iNext - -112 Do While pAddrStr <> 0 -113 CopyMemory Buffer, ByVal pAddrStr, Len(Buffer) -114 frm1.lbldns2 = Buffer.IpAddress 'dns server IP -115 pAddrStr = Buffer.iNext - Loop - -116 Select Case FixedInfo.NodeType 'node type - - Case 1 -117 frm1.lblnode = "Broadcast" - -118 Case 2 -119 frm1.lblnode = "Peer to peer" - -120 Case 4 -121 frm1.lblnode = "Mixed" - -122 Case 8 -123 frm1.lblnode = "Hybrid" - -124 Case Else -125 frm1.lblnode = "Unknown" - End Select - -126 If FixedInfo.ScopeId = "" Then -127 frm1.lblscope = "Not Found" - Else -128 frm1.lblscope = FixedInfo.ScopeId 'scope ID - End If - - 'routing -129 If FixedInfo.EnableRouting Then -130 frm1.lblroute = "Enabled" - Else -131 frm1.lblroute = "Disabled" - End If - - ' proxy -132 If FixedInfo.EnableProxy Then -133 frm1.lblproxy = "Enabled" - Else -134 frm1.lblproxy = "Disabled" - End If - - ' netbios -135 If FixedInfo.EnableDns Then -136 frm1.lblres = "Using DNS" - Else -137 frm1.lblres = "Not using DNS" - End If - - Else -138 frm1.lblres = error - Exit Sub - End If - - 'Enumerate all of the adapter specific information using the IP_ADAPTER_INFO structure. - 'Note: IP_ADAPTER_INFO contains a linked list of adapter entries. -139 AdapterInfoSize = 0 -140 error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize) - -141 If error <> 0 Then -142 If error <> ERROR_BUFFER_OVERFLOW Then -143 frm1.lblinfosize = error - Exit Sub - End If - End If - -144 ReDim AdapterInfoBuffer(AdapterInfoSize - 1) - ' Get actual adapter information -145 error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) - -146 If error <> 0 Then -147 MsgBox "GetAdaptersInfo failed with error " & error - Exit Sub - End If - -148 CopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo) -149 pAdapt = AdapterInfo.iNext - -150 Do While pAdapt <> 0 -151 CopyMemory Buffer2, AdapterInfo, Len(Buffer2) - -152 Select Case Buffer2.Type - - Case MIB_IF_TYPE_ETHERNET -153 frm1.lblatype = "Ethernet adapter " - -154 Case MIB_IF_TYPE_TOKENRING -155 frm1.lblatype = "Token Ring adapter " - -156 Case MIB_IF_TYPE_FDDI -157 frm1.lblatype = "FDDI adapter " - -158 Case MIB_IF_TYPE_PPP -159 frm1.lblatype = "PPP adapter" - -160 Case MIB_IF_TYPE_LOOPBACK -161 frm1.lblatype = "Loopback adapter " - -162 Case MIB_IF_TYPE_SLIP -163 frm1.lblatype = "Slip adapter " - -164 Case Else -165 frm1.lblatype = "Other adapter " - End Select - -166 frm1.lbladname = Buffer2.AdapterName -167 frm1.lbldesc = Buffer2.Description 'adatpter name - -168 For i = 0 To Buffer2.AddressLength - 1 -169 PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i)) - -170 If i < Buffer2.AddressLength - 1 Then -171 PhysicalAddress = PhysicalAddress & "-" - End If - - Next - -172 frm1.lblphy = PhysicalAddress 'mac address - -173 If Buffer2.DhcpEnabled Then -174 frm1.lbldhcpstatus = "Enabled" - Else -175 frm1.lbldhcpstatus = "Disabled" - End If - -176 pAddrStr = Buffer2.IpAddressList.iNext - -177 Do While pAddrStr <> 0 -178 frm1.lblip = Buffer.IpAddress -179 frm1.lblsub = Buffer.IpMask -180 pAddrStr = Buffer.iNext - -181 If pAddrStr <> 0 Then -182 CopyMemory Buffer2.IpAddressList, ByVal pAddrStr, Len(Buffer2.IpAddressList) - End If - - Loop - -183 frm1.lblgate = Buffer2.GatewayList.IpAddress 'Gateway -184 pAddrStr = Buffer2.GatewayList.iNext - -185 Do While pAddrStr <> 0 -186 CopyMemory Buffer, Buffer2.GatewayList, Len(Buffer) -187 frm1.lblip = "IP Address: " & Buffer.IpAddress -188 pAddrStr = Buffer.iNext - -189 If pAddrStr <> 0 Then -190 CopyMemory Buffer2.GatewayList, ByVal pAddrStr, Len(Buffer2.GatewayList) - End If - - Loop - -191 frm1.lbldhcpserver = Buffer2.DhcpServer.IpAddress -192 frm1.lblpriwins = Buffer2.PrimaryWinsServer.IpAddress -193 frm1.lblsecwins = Buffer2.SecondaryWinsServer.IpAddress - ' Display time -194 NewTime = CDate(Adapt.LeaseObtained) -195 frm1.lbldhcplease = CStr(NewTime) -196 NewTime = CDate(Adapt.LeaseExpires) -197 frm1.lbldhcpexpiration = CStr(NewTime) -198 pAdapt = Buffer2.iNext - -199 If pAdapt <> 0 Then -200 CopyMemory AdapterInfo, ByVal pAdapt, Len(AdapterInfo) - End If - - Loop - - ' - Exit Sub -ObtenerNetInfo_Err: - Controlar_Error Erl, Err.Description, "Reseter.modNetInfo.ObtenerNetInfo.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub +Attribute VB_Name = "modNetInfo" +Public Const MAX_HOSTNAME_LEN = 132 +Public Const MAX_DOMAIN_NAME_LEN = 132 +Public Const MAX_SCOPE_ID_LEN = 260 +Public Const MAX_ADAPTER_NAME_LENGTH = 260 +Public Const MAX_ADAPTER_ADDRESS_LENGTH = 8 +Public Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132 +Public Const ERROR_BUFFER_OVERFLOW = 111 +Public Const MIB_IF_TYPE_ETHERNET = 1 +Public Const MIB_IF_TYPE_TOKENRING = 2 +Public Const MIB_IF_TYPE_FDDI = 3 +Public Const MIB_IF_TYPE_PPP = 4 +Public Const MIB_IF_TYPE_LOOPBACK = 5 +Public Const MIB_IF_TYPE_SLIP = 6 +Type IP_ADDR_STRING + iNext As Long + IpAddress As String * 16 + IpMask As String * 16 + Context As Long +End Type +Type IP_ADAPTER_INFO + iNext As Long + ComboIndex As Long + AdapterName As String * MAX_ADAPTER_NAME_LENGTH + Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH + AddressLength As Long + Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte + Index As Long + Type As Long + DhcpEnabled As Long + CurrentIpAddress As Long + IpAddressList As IP_ADDR_STRING + GatewayList As IP_ADDR_STRING + DhcpServer As IP_ADDR_STRING + HaveWins As Boolean + PrimaryWinsServer As IP_ADDR_STRING + SecondaryWinsServer As IP_ADDR_STRING + LeaseObtained As Long + LeaseExpires As Long + End Type + Type FIXED_INFO + HostName As String * MAX_HOSTNAME_LEN + + DomainName As String * MAX_DOMAIN_NAME_LEN + CurrentDnsServer As Long + DnsServerList As IP_ADDR_STRING + NodeType As Long + ScopeId As String * MAX_SCOPE_ID_LEN + EnableRouting As Long + EnableProxy As Long + EnableDns As Long + End Type + Public Declare Function GetNetworkParams _ + Lib "IPHlpApi" (FixedInfo As Any, _ + pOutBufLen As Long) As Long + Public Declare Function GetAdaptersInfo _ + Lib "IPHlpApi" (IpAdapterInfo As Any, _ + pOutBufLen As Long) As Long + Public Declare Sub CopyMemory _ + Lib "kernel32" _ + Alias "RtlMoveMemory" (Destination As Any, _ + Source As Any, _ + ByVal Length As Long) + +Sub ObtenerNetInfo() + 'This example was created by George Bernier (bernig@dinomail.qc.ca) + ' + On Error GoTo ObtenerNetInfo_Err + ' + Dim error As Long + Dim FixedInfoSize As Long + Dim AdapterInfoSize As Long + Dim i As Integer + Dim PhysicalAddress As String + Dim NewTime As Date + Dim AdapterInfo As IP_ADAPTER_INFO + Dim Adapt As IP_ADAPTER_INFO + Dim AddrStr As IP_ADDR_STRING + Dim FixedInfo As FIXED_INFO + Dim Buffer As IP_ADDR_STRING + Dim pAddrStr As Long + Dim pAdapt As Long + Dim Buffer2 As IP_ADAPTER_INFO + Dim FixedInfoBuffer() As Byte + Dim AdapterInfoBuffer() As Byte + 'Get the main IP configuration information for this machine using a FIXED_INFO structure + FixedInfoSize = 0 + error = GetNetworkParams(ByVal 0&, FixedInfoSize) + + If error <> 0 Then + If error <> ERROR_BUFFER_OVERFLOW Then + MsgBox "GetNetworkParams sizing failed with error " & error + Exit Sub + End If + End If + + ReDim FixedInfoBuffer(FixedInfoSize - 1) + error = GetNetworkParams(FixedInfoBuffer(0), FixedInfoSize) + + If error = 0 Then + CopyMemory FixedInfo, FixedInfoBuffer(0), Len(FixedInfo) + frm1.lblhost = FixedInfo.HostName 'host name + frm1.lbldns1 = FixedInfo.DnsServerList.IpAddress 'dns server IP + pAddrStr = FixedInfo.DnsServerList.iNext + + Do While pAddrStr <> 0 + CopyMemory Buffer, ByVal pAddrStr, Len(Buffer) + frm1.lbldns2 = Buffer.IpAddress 'dns server IP + pAddrStr = Buffer.iNext + Loop + + Select Case FixedInfo.NodeType 'node type + + Case 1 + frm1.lblnode = "Broadcast" + + Case 2 + frm1.lblnode = "Peer to peer" + + Case 4 + frm1.lblnode = "Mixed" + + Case 8 + frm1.lblnode = "Hybrid" + + Case Else + frm1.lblnode = "Unknown" + End Select + + If FixedInfo.ScopeId = "" Then + frm1.lblscope = "Not Found" + Else + frm1.lblscope = FixedInfo.ScopeId 'scope ID + End If + + 'routing + If FixedInfo.EnableRouting Then + frm1.lblroute = "Enabled" + Else + frm1.lblroute = "Disabled" + End If + + ' proxy + If FixedInfo.EnableProxy Then + frm1.lblproxy = "Enabled" + Else + frm1.lblproxy = "Disabled" + End If + + ' netbios + If FixedInfo.EnableDns Then + frm1.lblres = "Using DNS" + Else + frm1.lblres = "Not using DNS" + End If + + Else + frm1.lblres = error + Exit Sub + End If + + 'Enumerate all of the adapter specific information using the IP_ADAPTER_INFO structure. + 'Note: IP_ADAPTER_INFO contains a linked list of adapter entries. + AdapterInfoSize = 0 + error = GetAdaptersInfo(ByVal 0&, AdapterInfoSize) + + If error <> 0 Then + If error <> ERROR_BUFFER_OVERFLOW Then + frm1.lblinfosize = error + Exit Sub + End If + End If + + ReDim AdapterInfoBuffer(AdapterInfoSize - 1) + ' Get actual adapter information + error = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) + + If error <> 0 Then + MsgBox "GetAdaptersInfo failed with error " & error + Exit Sub + End If + + CopyMemory AdapterInfo, AdapterInfoBuffer(0), Len(AdapterInfo) + pAdapt = AdapterInfo.iNext + + Do While pAdapt <> 0 + CopyMemory Buffer2, AdapterInfo, Len(Buffer2) + + Select Case Buffer2.Type + + Case MIB_IF_TYPE_ETHERNET + frm1.lblatype = "Ethernet adapter " + + Case MIB_IF_TYPE_TOKENRING + frm1.lblatype = "Token Ring adapter " + + Case MIB_IF_TYPE_FDDI + frm1.lblatype = "FDDI adapter " + + Case MIB_IF_TYPE_PPP + frm1.lblatype = "PPP adapter" + + Case MIB_IF_TYPE_LOOPBACK + frm1.lblatype = "Loopback adapter " + + Case MIB_IF_TYPE_SLIP + frm1.lblatype = "Slip adapter " + + Case Else + frm1.lblatype = "Other adapter " + End Select + + frm1.lbladname = Buffer2.AdapterName + frm1.lbldesc = Buffer2.Description 'adatpter name + + For i = 0 To Buffer2.AddressLength - 1 + PhysicalAddress = PhysicalAddress & Hex(Buffer2.Address(i)) + + If i < Buffer2.AddressLength - 1 Then + PhysicalAddress = PhysicalAddress & "-" + End If + + Next + + frm1.lblphy = PhysicalAddress 'mac address + + If Buffer2.DhcpEnabled Then + frm1.lbldhcpstatus = "Enabled" + Else + frm1.lbldhcpstatus = "Disabled" + End If + + pAddrStr = Buffer2.IpAddressList.iNext + + Do While pAddrStr <> 0 + frm1.lblip = Buffer.IpAddress + frm1.lblsub = Buffer.IpMask + pAddrStr = Buffer.iNext + + If pAddrStr <> 0 Then + CopyMemory Buffer2.IpAddressList, ByVal pAddrStr, Len(Buffer2.IpAddressList) + End If + + Loop + + frm1.lblgate = Buffer2.GatewayList.IpAddress 'Gateway + pAddrStr = Buffer2.GatewayList.iNext + + Do While pAddrStr <> 0 + CopyMemory Buffer, Buffer2.GatewayList, Len(Buffer) + frm1.lblip = "IP Address: " & Buffer.IpAddress + pAddrStr = Buffer.iNext + + If pAddrStr <> 0 Then + CopyMemory Buffer2.GatewayList, ByVal pAddrStr, Len(Buffer2.GatewayList) + End If + + Loop + + frm1.lbldhcpserver = Buffer2.DhcpServer.IpAddress + frm1.lblpriwins = Buffer2.PrimaryWinsServer.IpAddress + frm1.lblsecwins = Buffer2.SecondaryWinsServer.IpAddress + ' Display time + NewTime = CDate(Adapt.LeaseObtained) + frm1.lbldhcplease = CStr(NewTime) + NewTime = CDate(Adapt.LeaseExpires) + frm1.lbldhcpexpiration = CStr(NewTime) + pAdapt = Buffer2.iNext + + If pAdapt <> 0 Then + CopyMemory AdapterInfo, ByVal pAdapt, Len(AdapterInfo) + End If + + Loop + + ' + Exit Sub +ObtenerNetInfo_Err: + Controlar_Error Erl, Err.Description, "Reseter.modNetInfo.ObtenerNetInfo" + Resume Next + ' +End Sub diff --git a/cls/Timer Class.cls b/cls/Timer Class.cls index 69a56bf..79772b7 100755 --- a/cls/Timer Class.cls +++ b/cls/Timer Class.cls @@ -52,115 +52,115 @@ Dim nFrequency As Currency ' Frequency of the Hi-Resolution timer if it is avil Dim bRunning As Boolean ' Is the Timer running ? Public Sub EndTimer() - ' - ' Ends the Counter - ' - ' - On Error GoTo EndTimer_Err - ' -100 timElapsed = GetElapsedTime ' Store this Value -101 bRunning = False - ' - Exit Sub + ' + ' Ends the Counter + ' + ' + On Error GoTo EndTimer_Err + ' + timElapsed = GetElapsedTime ' Store this Value + bRunning = False + ' + Exit Sub EndTimer_Err: - Controlar_Error Erl, Err.Description, "Reseter.cTimer.EndTimer.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.cTimer.EndTimer" + Resume Next + ' End Sub Public Sub StartTimer() Attribute StartTimer.VB_Description = "Starts the Timer" - ' - ' Starts the Counter - ' - ' - On Error GoTo StartTimer_Err - ' -100 timElapsed = 0 ' Reset Counter -101 bRunning = True + ' + ' Starts the Counter + ' + ' + On Error GoTo StartTimer_Err + ' + timElapsed = 0 ' Reset Counter + bRunning = True -102 If nFrequency <> 0 Then -103 QueryPerformanceCounter timStart - Else -104 timStart = GetTickCount - End If + If nFrequency <> 0 Then + QueryPerformanceCounter timStart + Else + timStart = GetTickCount + End If - ' - Exit Sub + ' + Exit Sub StartTimer_Err: - Controlar_Error Erl, Err.Description, "Reseter.cTimer.StartTimer.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.cTimer.StartTimer" + Resume Next + ' End Sub Private Function GetElapsedTime() As Double - ' - ' Calculates the Elapsed Time - ' - ' - On Error GoTo GetElapsedTime_Err - ' - Dim timEnd As Currency + ' + ' Calculates the Elapsed Time + ' + ' + On Error GoTo GetElapsedTime_Err + ' + Dim timEnd As Currency -100 If nFrequency <> 0 Then -101 QueryPerformanceCounter timEnd -102 GetElapsedTime = ((timEnd - timStart) / nFrequency) * 1000 - Else -103 timEnd = GetTickCount -104 GetElapsedTime = timEnd - timStart - End If + If nFrequency <> 0 Then + QueryPerformanceCounter timEnd + GetElapsedTime = ((timEnd - timStart) / nFrequency) * 1000 + Else + timEnd = GetTickCount + GetElapsedTime = timEnd - timStart + End If - ' - Exit Function + ' + Exit Function GetElapsedTime_Err: - Controlar_Error Erl, Err.Description, "Reseter.cTimer.GetElapsedTime.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.cTimer.GetElapsedTime" + Resume Next + ' End Function Private Sub Class_Initialize() - ' - ' Check if Hi-resolution timer is available - ' - ' - On Error GoTo Class_Initialize_Err - ' - Dim APIRetVal As Long -100 APIRetVal = QueryPerformanceFrequency(nFrequency) + ' + ' Check if Hi-resolution timer is available + ' + ' + On Error GoTo Class_Initialize_Err + ' + Dim APIRetVal As Long + APIRetVal = QueryPerformanceFrequency(nFrequency) -101 If APIRetVal = 0 Then -102 nFrequency = 0 ' Zero indicates that the ordinary GetTickCount function must be used - End If + If APIRetVal = 0 Then + nFrequency = 0 ' Zero indicates that the ordinary GetTickCount function must be used + End If - ' - Exit Sub + ' + Exit Sub Class_Initialize_Err: - Controlar_Error Erl, Err.Description, "Reseter.cTimer.Class_Initialize.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.cTimer.Class_Initialize" + Resume Next + ' End Sub Public Property Get Elapsed() As Double Attribute Elapsed.VB_Description = "Returns Elapsed Time in MilliSeconds. If the Timer is running, returns Zero." - ' - ' Returns Elapsed time - ' - ' - On Error GoTo Elapsed_Err + ' + ' Returns Elapsed time + ' + ' + On Error GoTo Elapsed_Err - ' -100 If bRunning Then -101 Elapsed = GetElapsedTime ' Return Intermediate Time - Else -102 Elapsed = timElapsed ' Return the Last counter's timing - End If + ' + If bRunning Then + Elapsed = GetElapsedTime ' Return Intermediate Time + Else + Elapsed = timElapsed ' Return the Last counter's timing + End If - ' - Exit Property + ' + Exit Property Elapsed_Err: - Controlar_Error Erl, Err.Description, "Reseter.cTimer.Elapsed.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.cTimer.Elapsed" + Resume Next + ' End Property 'Public Property Get Frecuencia() As Currency ' ' diff --git a/frm/Principal.frm b/frm/Principal.frm index 621e666..8e4e3e9 100755 --- a/frm/Principal.frm +++ b/frm/Principal.frm @@ -176,173 +176,173 @@ Option Explicit ' *Vladimir Private Sub cmdGuardar_Click() - ' - On Error GoTo cmdGuardar_Click_Err - ' -100 Memoria_IO ComReset.Text -101 Call ComReset_Click - ' - Exit Sub + ' + On Error GoTo cmdGuardar_Click_Err + ' + Memoria_IO ComReset.Text + Call ComReset_Click + ' + Exit Sub cmdGuardar_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdGuardar_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdGuardar_Click" + Resume Next + ' End Sub Private Sub cmdIP_Click() - ' - On Error GoTo cmdIP_Click_Err - ' -100 Cambio_IP - ' - Exit Sub + ' + On Error GoTo cmdIP_Click_Err + ' + Cambio_IP + ' + Exit Sub cmdIP_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdIP_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdIP_Click" + Resume Next + ' End Sub Private Sub cmdPredefinir_Click() - ' - On Error GoTo cmdPredefinir_Click_Err + ' + On Error GoTo cmdPredefinir_Click_Err - ' -100 If cmdPredefinir.Caption = "Cancelar" Then -101 NetError = True -102 cmdPredefinir.Caption = "Predefinir" -103 Predefinir False - Else -104 Predefinir True - End If + ' + If cmdPredefinir.Caption = "Cancelar" Then + NetError = True + cmdPredefinir.Caption = "Predefinir" + Predefinir False + Else + Predefinir True + End If - ' - Exit Sub + ' + Exit Sub cmdPredefinir_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdPredefinir_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdPredefinir_Click" + Resume Next + ' End Sub Private Sub cmdReset_Click() - ' - On Error GoTo cmdReset_Click_Err - ' - Static pestado As Boolean + ' + On Error GoTo cmdReset_Click_Err + ' + Static pestado As Boolean -100 If pestado = False Then -101 pestado = True -102 Registrar "|--Intentando reseteo de " & ComReset.Text -103 cmdReset.Caption = "Cancelar" -104 Procesar_Codigo -105 Registrar "|--Fin de intento de reseteo para " & ComReset.Text - Else -106 NetError = True - End If + If pestado = False Then + pestado = True + Registrar "|--Intentando reseteo de " & ComReset.Text + cmdReset.Caption = "Cancelar" + Procesar_Codigo + Registrar "|--Fin de intento de reseteo para " & ComReset.Text + Else + NetError = True + End If -107 pestado = False -108 cmdReset.Caption = "Resetear" - ' - Exit Sub + pestado = False + cmdReset.Caption = "Resetear" + ' + Exit Sub cmdReset_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdReset_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdReset_Click" + Resume Next + ' End Sub Private Sub cmdRenovarLAN_Click() - 'Idea original de Kikeuntercio - ' - On Error GoTo cmdRenovarLAN_Click_Err - ' -100 RenovarLAN - ' - Exit Sub + 'Idea original de Kikeuntercio + ' + On Error GoTo cmdRenovarLAN_Click_Err + ' + RenovarLAN + ' + Exit Sub cmdRenovarLAN_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdRenovarLAN_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.cmdRenovarLAN_Click" + Resume Next + ' End Sub Private Sub ComReset_Click() - 'Tratamos de recuperar los datos de los routers - ' - On Error GoTo ComReset_Click_Err + 'Tratamos de recuperar los datos de los routers + ' + On Error GoTo ComReset_Click_Err - ' -100 If Existe_Seccion(ComReset.Text) Then 'Si el router existe -101 Restablecer_Todo -102 IO_Memoria ComReset.Text 'Cargar la configuración -103 Mostrar_Datos 'Mostrar la configuración -104 cmdPredefinir.Enabled = True -105 cmdReset.Enabled = True - Else -106 cmdPredefinir.Enabled = False -107 cmdReset.Enabled = False - End If + ' + If Existe_Seccion(ComReset.Text) Then 'Si el router existe + Restablecer_Todo + IO_Memoria ComReset.Text 'Cargar la configuración + Mostrar_Datos 'Mostrar la configuración + cmdPredefinir.Enabled = True + cmdReset.Enabled = True + Else + cmdPredefinir.Enabled = False + cmdReset.Enabled = False + End If - ' - Exit Sub + ' + Exit Sub ComReset_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.ComReset_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.ComReset_Click" + Resume Next + ' End Sub Private Sub ComReset_Change() - ' - On Error GoTo ComReset_Change_Err - ' -100 Call ComReset_Click - ' - Exit Sub + ' + On Error GoTo ComReset_Change_Err + ' + Call ComReset_Click + ' + Exit Sub ComReset_Change_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.ComReset_Change.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.ComReset_Change" + Resume Next + ' End Sub Private Sub chkAvanzado_Click() - ' - On Error GoTo chkAvanzado_Click_Err - ' -100 Height = IIf(chkAvanzado.Value = Checked, 9735, 4050) -101 EscribirINI "Interfaz", "MAvanzado", chkAvanzado.Value - ' - Exit Sub + ' + On Error GoTo chkAvanzado_Click_Err + ' + Height = IIf(chkAvanzado.Value = Checked, 9735, 4050) + EscribirINI "Interfaz", "MAvanzado", chkAvanzado.Value + ' + Exit Sub chkAvanzado_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.chkAvanzado_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.chkAvanzado_Click" + Resume Next + ' End Sub Private Sub chkTerminal_Click() - ' - On Error GoTo chkTerminal_Click_Err + ' + On Error GoTo chkTerminal_Click_Err - ' -100 If chkTerminal.Value = Checked Then frmTelnet.Show Else frmTelnet.Hide -101 EscribirINI "Interfaz", "MTerminal", chkTerminal.Value - ' - Exit Sub + ' + If chkTerminal.Value = Checked Then frmTelnet.Show Else frmTelnet.Hide + EscribirINI "Interfaz", "MTerminal", chkTerminal.Value + ' + Exit Sub chkTerminal_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.chkTerminal_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.chkTerminal_Click" + Resume Next + ' End Sub Private Sub Form_Load() - ' - On Error GoTo Form_Load_Err - ' -100 Colorear Me -101 SetAppIcon Me - ' - Exit Sub + ' + On Error GoTo Form_Load_Err + ' + Colorear Me + SetAppIcon Me + ' + Exit Sub Form_Load_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.Form_Load.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.Form_Load" + Resume Next + ' End Sub Private Sub Form_Resize() @@ -354,53 +354,53 @@ Private Sub Form_Resize() End Sub Private Sub Form_Unload(Cancel As Integer) - ' - On Error GoTo Form_Unload_Err - ' -100 Terminar - ' - Exit Sub + ' + On Error GoTo Form_Unload_Err + ' + Terminar + ' + Exit Sub Form_Unload_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.Form_Unload.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.Form_Unload" + Resume Next + ' End Sub Private Sub optTipo_Click(Index As Integer) - ' - On Error GoTo optTipo_Click_Err + ' + On Error GoTo optTipo_Click_Err - ' -100 Select Case Index + ' + Select Case Index - Case 0 -101 m_Datos.tipoAcceso = web + Case 0 + m_Datos.tipoAcceso = web -102 Case 1 -103 m_Datos.tipoAcceso = telnet + Case 1 + m_Datos.tipoAcceso = telnet -104 Case 2 -105 m_Datos.tipoAcceso = auro - End Select + Case 2 + m_Datos.tipoAcceso = auro + End Select - ' - Exit Sub + ' + Exit Sub optTipo_Click_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.optTipo_Click.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.optTipo_Click" + Resume Next + ' End Sub Private Sub txtCodigos_Change() - ' - On Error GoTo txtCodigos_Change_Err - ' -100 m_Datos.codigo = Replace$(txtCodigos.Text, vbNewLine, Chr(254)) - ' - Exit Sub + ' + On Error GoTo txtCodigos_Change_Err + ' + m_Datos.codigo = Replace$(txtCodigos.Text, vbNewLine, Chr(254)) + ' + Exit Sub txtCodigos_Change_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.txtCodigos_Change.Ref 12/8/2008 : 08:11:22" - Resume Next - ' + Controlar_Error Erl, Err.Description, "Reseter.frmPrincipal.txtCodigos_Change" + Resume Next + ' End Sub diff --git a/frm/Telnet.frm b/frm/Telnet.frm dissimilarity index 79% index c640170..cab9c7f 100755 --- a/frm/Telnet.frm +++ b/frm/Telnet.frm @@ -1,763 +1,763 @@ -VERSION 5.00 -Begin VB.Form frmTelnet - BackColor = &H80000017& - BorderStyle = 0 'None - ClientHeight = 5970 - ClientLeft = -270 - ClientTop = 2385 - ClientWidth = 8220 - FillColor = &H00800000& - BeginProperty Font - Name = "Fixedsys" - Size = 9 - Charset = 0 - Weight = 400 - Underline = 0 'False - Italic = 0 'False - Strikethrough = 0 'False - EndProperty - ForeColor = &H0000FFFF& - KeyPreview = -1 'True - LinkTopic = "Form1" - MaxButton = 0 'False - MinButton = 0 'False - PaletteMode = 1 'UseZOrder - ScaleHeight = 5970 - ScaleWidth = 8220 - ShowInTaskbar = 0 'False - Begin VB.Timer cursor_timer - Enabled = 0 'False - Interval = 300 - Left = 6600 - Top = 600 - End -End -Attribute VB_Name = "frmTelnet" -Attribute VB_GlobalNameSpace = False -Attribute VB_Creatable = False -Attribute VB_PredeclaredId = True -Attribute VB_Exposed = False -Option Explicit -Const GO_NORM = 0 -Const GO_IAC1 = 6 -Const GO_IAC2 = 7 -Const GO_IAC3 = 8 -Const GO_IAC4 = 9 -Const GO_IAC5 = 10 -Const GO_IAC6 = 11 -Const SE = 240 'End of Subnegotiation -Const SB = 250 'What follows is subnegotiation -Const WILLTEL = 251 -Const WONTTEL = 252 -Const DOTEL = 253 -Const DONTTEL = 254 -Const IAC = 255 -Const BINARY = 0 -Const ECHO = 1 -Const SGA = 3 -Const STATUS = 5 -Const TIMING = 6 -Const TERMTYPE = 24 -Const NAWS = 31 -Const TERMSPEED = 32 -Const TFLOWCNTRL = 33 -Const LINEMODE = 34 -Const DISPLOC = 35 -Const ENVIRON = 36 -Const AUTHENTICATION = 37 -Const UNKNOWN39 = 39 -Public Receiving As Boolean -Private parsedata(10) As Integer -Private ppno As Integer -Private control_on As Boolean -Private sw_ugoahead As Boolean -Private sw_igoahead As Boolean -Private sw_echo As Boolean -Private sw_termsent As Boolean -'------------------------------------------------------------ -Public Telnet_Connectado As Boolean -Public WithEvents Socket As CSocketMaster -Attribute Socket.VB_VarHelpID = -1 - -Private Sub cursor_timer_Timer() - ' - On Error Resume Next - - ' - If Not Receiving Then term_DriveCursor -End Sub - -Private Sub Form_KeyDown(KeyCode As Integer, _ - Shift As Integer) - ' - On Error GoTo Form_KeyDown_Err - ' - Dim CH As String -100 CH = Chr$(0) - - 'Translate keycodes to VT100 escape sequences -101 Select Case KeyCode - - Case vbKeyControl -102 control_on = True - -103 Case vbKeyEnd -104 CH = Chr$(27) + "[K" - -105 Case vbKeyHome -106 CH = Chr$(27) + "[H" - -107 Case vbKeyLeft -108 CH = Chr$(27) + "[D" - -109 Case vbKeyUp -110 CH = Chr$(27) + "[A" - -111 Case vbKeyRight -112 CH = Chr$(27) + "[C" - -113 Case vbKeyDown -114 CH = Chr$(27) + "[B" - -115 Case vbKeyF1 -116 CH = Chr$(27) + "OP" - -117 Case vbKeyF2 -118 CH = Chr$(27) + "OQ" - -119 Case vbKeyF3 -120 CH = Chr$(27) + "OR" - -121 Case vbKeyF4 -122 CH = Chr$(27) + "OS" - -123 Case Else - -124 If control_on And KeyCode > 63 Then -125 CH = Chr$(KeyCode - 64) - End If - - End Select - -126 If CH > Chr$(0) And Telnet_Connectado Then Socket.SendData CH - ' - Exit Sub - -Form_KeyDown_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyDown.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Form_KeyPress(KeyAscii As Integer) - ' - On Error GoTo Form_KeyPress_Err - ' - Dim CH As String - -100 If Telnet_Connectado Then -101 CH = Chr$(KeyAscii) - -102 If control_on Then -103 If KeyAscii > 63 Then -104 CH = Chr$(KeyAscii - 64) - Else -105 CH = Chr$(0) - End If - End If - -106 If CH > Chr$(0) Then -107 If CH = Chr$(13) Then -108 CH = CH & Chr$(10) - End If - -109 Socket.SendData CH - End If - End If - - ' - Exit Sub - -Form_KeyPress_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyPress.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Form_KeyUp(KeyCode As Integer, _ - Shift As Integer) - ' - On Error GoTo Form_KeyUp_Err - - ' -100 Select Case KeyCode - - Case vbKeyControl -101 control_on = False - End Select - - ' - Exit Sub - -Form_KeyUp_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyUp.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Form_Load() - ' - On Error GoTo Form_Load_Err - ' -100 Set Socket = New CSocketMaster -101 term_init - ' - Exit Sub - -Form_Load_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_Load.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Form_Paint() - ' - On Error GoTo Form_Paint_Err - ' -100 term_redrawscreen - ' - Exit Sub - -Form_Paint_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_Paint.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Form_QueryUnload(Cancel As Integer, _ - UnloadMode As Integer) - ' - On Error GoTo Form_QueryUnload_Err - - ' -100 With Socket -101 .CloseSck ' Clear any errors... -102 .RemoteHost = "0.0.0.0" -103 .RemotePort = 0 - End With - -104 Telnet_Connectado = False - ' - Exit Sub - -Form_QueryUnload_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_QueryUnload.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Socket_CloseSck() - ' - On Error GoTo Socket_CloseSck_Err - ' -100 Telnet_Connectado = False - ' - Exit Sub -Socket_CloseSck_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_CloseSck.Ref 12/8/2008 : 08:11:23" - Resume Next - ' -End Sub - -Private Sub Socket_Connect() - ' - On Error GoTo Socket_Connect_Err - ' - Dim ConnectString As String - '------------------------------------------------------------ -100 sw_ugoahead = True -101 sw_igoahead = False -102 sw_echo = True -103 sw_termsent = False -104 ConnectString = Chr$(IAC) & Chr$(DOTEL) & Chr$(ECHO) & Chr$(IAC) & Chr$(DOTEL) & Chr$(SGA) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(NAWS) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMTYPE) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMSPEED) -105 Socket.SendData ConnectString -106 Telnet_Connectado = True - ' - Exit Sub -Socket_Connect_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_Connect.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Sub Socket_DataArrival(ByVal bytesTotal As Long) - ' - On Error GoTo Socket_DataArrival_Err - ' - Dim CH() As Byte - Dim i As Integer - Static cmd As Byte - - '------------------------------------------------------------ -100 If Receiving Then - Exit Sub - Else -101 Receiving = True -102 term_CaretControl True - End If - -103 If (bytesTotal > 0) Then ' If there is any data... -104 Socket.GetData CH, vbByte + vbArray, bytesTotal -105 bytesTotal = bytesTotal - 1 - - ' CH = Buf -106 For i = 0 To bytesTotal - -107 Select Case cmd - - Case GO_NORM -108 cmd = term_process_char(CH(i)) - -109 Case GO_IAC1 -110 cmd = iac1(CH(i)) - -111 Case GO_IAC2 -112 cmd = iac2(CH(i)) - -113 Case GO_IAC3 -114 cmd = iac3(CH(i)) - -115 Case GO_IAC4 -116 cmd = iac4(CH(i)) - -117 Case GO_IAC5 -118 cmd = iac5(CH(i)) - -119 Case GO_IAC6 -120 cmd = iac6(CH(i)) - End Select - - Next - - End If - - 'Enviamos el siguiente comando -121 If nComando < UBound(TelnetComandos) And Socket.State = sckConnected Then -122 Socket.SendData TelnetComandos(nComando) & vbCrLf -123 Registrar "Telnet -> Enviado: " & TelnetComandos(nComando) -124 nComando = nComando + 1 - End If - -125 term_CaretControl False -126 Receiving = False - ' - Exit Sub -Socket_DataArrival_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_DataArrival.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Private Function iac1(CH As Byte) As Integer - ' Debug.Print "IAC : "; - ' - On Error GoTo iac1_Err - ' -100 iac1 = GO_NORM - -101 Select Case CH - - Case DOTEL -102 iac1 = GO_IAC2 - -103 Case DONTTEL -104 iac1 = GO_IAC6 - -105 Case WILLTEL -106 iac1 = GO_IAC3 - -107 Case WONTTEL -108 iac1 = GO_IAC4 - -109 Case SB -110 iac1 = GO_IAC5 -111 ppno = 0 - -112 Case SE - - ' End of negotiation string, string is in parsedata() -113 Select Case parsedata(0) - - Case TERMTYPE - -114 If parsedata(1) = 1 Then -115 Socket.SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMTYPE) & "DEC-VT100" & Chr$(0) & Chr$(IAC) & Chr$(SE) - End If - -116 Case TERMSPEED - -117 If parsedata(1) = 1 Then - ' Debug.Print "TERMSPEED" -118 Socket.SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(CH) -119 Socket.SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMSPEED) & Chr$(0) & "57600,57600" & Chr$(IAC) & Chr$(SE) - End If - - End Select - End Select - - ' - Exit Function -iac1_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac1.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Function iac2(CH As Byte) As Integer - 'DO Processing Respond with WILL or WONT - ' - On Error GoTo iac2_Err - - ' -100 With Socket -101 iac2 = GO_NORM - -102 Select Case CH - - Case BINARY -103 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(BINARY) - -104 Case ECHO -105 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(ECHO) - -106 Case NAWS -107 .SendData Chr$(IAC) & Chr$(SB) & Chr$(NAWS) & Chr$(0) & Chr$(80) & Chr$(0) & Chr$(24) & Chr$(IAC) & Chr$(SE) - -108 Case SGA - -109 If Not sw_igoahead Then -110 .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(SGA) -111 sw_igoahead = True - End If - -112 Case TERMTYPE - -113 If Not sw_termsent Then -114 sw_termsent = True -115 .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMTYPE) -116 .SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMTYPE) & Chr$(0) & "VT100" & Chr$(IAC) & Chr$(SE) - End If - -117 Case TERMSPEED -118 .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMSPEED) -119 .SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMSPEED) & Chr$(0) -120 .SendData "57600,57600" -121 .SendData Chr$(IAC) & Chr$(SE) - -122 Case TFLOWCNTRL -123 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -124 Case LINEMODE -125 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -126 Case STATUS -127 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -128 Case TIMING -129 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -130 Case DISPLOC -131 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -132 Case ENVIRON -133 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -134 Case UNKNOWN39 -135 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -136 Case AUTHENTICATION -137 .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(CH) -138 .SendData Chr$(IAC) & Chr$(SB) & Chr$(AUTHENTICATION) & Chr$(0) & Chr$(0) & Chr$(0) & Chr$(0) & Chr$(IAC) & Chr$(SE) - -139 Case Else -140 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - End Select - - End With - - ' - Exit Function -iac2_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac2.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Function iac3(CH As Byte) As Integer - ' WILL Processing - Respond with DO or DONT - ' - On Error GoTo iac3_Err - - ' -100 With Socket -101 iac3 = GO_NORM - -102 Select Case CH - - Case ECHO - -103 If Not sw_echo Then -104 sw_echo = True -105 .SendData Chr$(IAC) & Chr$(DOTEL) & Chr$(ECHO) - End If - -106 Case SGA - -107 If Not sw_ugoahead Then -108 sw_ugoahead = True -109 .SendData Chr$(IAC) & Chr$(DOTEL) & Chr$(SGA) - End If - -110 Case TERMSPEED -111 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -112 Case TFLOWCNTRL -113 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -114 Case LINEMODE -115 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -116 Case STATUS -117 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -118 Case TIMING -119 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -120 Case DISPLOC -121 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -122 Case ENVIRON -123 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -124 Case UNKNOWN39 -125 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -126 Case Else -127 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - End Select - - End With - - ' - Exit Function -iac3_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac3.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Function iac4(CH As Byte) As Integer - ' WONT Processing - ' - On Error GoTo iac4_Err - - ' -100 With Socket -101 iac4 = GO_NORM - -102 Select Case CH - - Case ECHO - -103 If sw_echo = True Then -104 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(ECHO) -105 sw_echo = False - End If - -106 Case SGA -107 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(SGA) -108 sw_igoahead = False - -109 Case TERMSPEED -110 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -111 Case TFLOWCNTRL -112 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -113 Case LINEMODE -114 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -115 Case STATUS -116 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -117 Case TIMING -118 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -119 Case DISPLOC -120 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -121 Case ENVIRON -122 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -123 Case UNKNOWN39 -124 .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) - -125 Case Else -126 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - End Select - - End With - - ' - Exit Function -iac4_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac4.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Function iac5(CH As Byte) As Integer - ' - On Error GoTo iac5_Err - ' - Dim ich As Integer - ' Collect parms after SB and until another IAC -100 ich = CH - -101 If ich = IAC Then -102 iac5 = GO_IAC1 - Exit Function - End If - -103 parsedata(ppno) = ich -104 ppno = ppno + 1 -105 iac5 = GO_IAC5 - ' - Exit Function -iac5_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac5.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Function iac6(CH As Byte) As Integer - 'DONT Processing - ' - On Error GoTo iac6_Err - - ' -100 With Socket -101 iac6 = GO_NORM - -102 Select Case CH - - Case SE - - ' -103 Case ECHO - -104 If Not sw_echo Then -105 sw_echo = True -106 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(ECHO) - End If - -107 Case SGA - -108 If Not sw_ugoahead Then -109 sw_ugoahead = True -110 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(SGA) - End If - -111 Case TERMSPEED -112 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -113 Case TFLOWCNTRL -114 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -115 Case LINEMODE -116 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -117 Case STATUS -118 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -119 Case TIMING -120 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -121 Case DISPLOC -122 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -123 Case ENVIRON -124 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -125 Case UNKNOWN39 -126 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - -127 Case Else -128 .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) - End Select - - End With - - ' - Exit Function -iac6_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac6.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Function - -Private Sub SOCKET_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) - ' - On Error GoTo SOCKET_ERROR_Err - - ' -100 If Number <> 10053 Then -101 NetError = True -102 Registrar "Telnet -> (" & Number & ") " & Description - Else -103 Registrar "Telnet -> Bien, el router abandonó la conexión" - End If - - ' - Exit Sub -SOCKET_ERROR_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.SOCKET_ERROR.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub - -Public Sub ProcTelnet() - ' - On Error GoTo ProcTelnet_Err - ' -100 Registrar "~ProcTelnet - Nivel 1" - -101 With Socket -102 .CloseSck -103 .RemotePort = m_Datos.puerto -104 .RemoteHost = m_Datos.base -105 .Protocol = sckTCPProtocol -106 .Connect -107 term_init -108 Registrar "~ProcTelnet - Nivel 2" - -109 Do Until Telnet_Connectado Or NetError -110 Esperar 0.5 - Loop - -111 Registrar "~ProcTelnet - Nivel 3" - End With - - ' - Exit Sub -ProcTelnet_Err: - Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.ProcTelnet.Ref 12/8/2008 : 08:11:22" - Resume Next - ' -End Sub +VERSION 5.00 +Begin VB.Form frmTelnet + BackColor = &H80000017& + BorderStyle = 0 'None + ClientHeight = 5970 + ClientLeft = -270 + ClientTop = 2385 + ClientWidth = 8220 + FillColor = &H00800000& + BeginProperty Font + Name = "Fixedsys" + Size = 9 + Charset = 0 + Weight = 400 + Underline = 0 'False + Italic = 0 'False + Strikethrough = 0 'False + EndProperty + ForeColor = &H0000FFFF& + KeyPreview = -1 'True + LinkTopic = "Form1" + MaxButton = 0 'False + MinButton = 0 'False + PaletteMode = 1 'UseZOrder + ScaleHeight = 5970 + ScaleWidth = 8220 + ShowInTaskbar = 0 'False + Begin VB.Timer cursor_timer + Enabled = 0 'False + Interval = 300 + Left = 6600 + Top = 600 + End +End +Attribute VB_Name = "frmTelnet" +Attribute VB_GlobalNameSpace = False +Attribute VB_Creatable = False +Attribute VB_PredeclaredId = True +Attribute VB_Exposed = False +Option Explicit +Const GO_NORM = 0 +Const GO_IAC1 = 6 +Const GO_IAC2 = 7 +Const GO_IAC3 = 8 +Const GO_IAC4 = 9 +Const GO_IAC5 = 10 +Const GO_IAC6 = 11 +Const SE = 240 'End of Subnegotiation +Const SB = 250 'What follows is subnegotiation +Const WILLTEL = 251 +Const WONTTEL = 252 +Const DOTEL = 253 +Const DONTTEL = 254 +Const IAC = 255 +Const BINARY = 0 +Const ECHO = 1 +Const SGA = 3 +Const STATUS = 5 +Const TIMING = 6 +Const TERMTYPE = 24 +Const NAWS = 31 +Const TERMSPEED = 32 +Const TFLOWCNTRL = 33 +Const LINEMODE = 34 +Const DISPLOC = 35 +Const ENVIRON = 36 +Const AUTHENTICATION = 37 +Const UNKNOWN39 = 39 +Public Receiving As Boolean +Private parsedata(10) As Integer +Private ppno As Integer +Private control_on As Boolean +Private sw_ugoahead As Boolean +Private sw_igoahead As Boolean +Private sw_echo As Boolean +Private sw_termsent As Boolean +'------------------------------------------------------------ +Public Telnet_Connectado As Boolean +Public WithEvents Socket As CSocketMaster +Attribute Socket.VB_VarHelpID = -1 + +Private Sub cursor_timer_Timer() + ' + On Error Resume Next + + ' + If Not Receiving Then term_DriveCursor +End Sub + +Private Sub Form_KeyDown(KeyCode As Integer, _ + Shift As Integer) + ' + On Error GoTo Form_KeyDown_Err + ' + Dim CH As String + CH = Chr$(0) + + 'Translate keycodes to VT100 escape sequences + Select Case KeyCode + + Case vbKeyControl + control_on = True + + Case vbKeyEnd + CH = Chr$(27) + "[K" + + Case vbKeyHome + CH = Chr$(27) + "[H" + + Case vbKeyLeft + CH = Chr$(27) + "[D" + + Case vbKeyUp + CH = Chr$(27) + "[A" + + Case vbKeyRight + CH = Chr$(27) + "[C" + + Case vbKeyDown + CH = Chr$(27) + "[B" + + Case vbKeyF1 + CH = Chr$(27) + "OP" + + Case vbKeyF2 + CH = Chr$(27) + "OQ" + + Case vbKeyF3 + CH = Chr$(27) + "OR" + + Case vbKeyF4 + CH = Chr$(27) + "OS" + + Case Else + + If control_on And KeyCode > 63 Then + CH = Chr$(KeyCode - 64) + End If + + End Select + + If CH > Chr$(0) And Telnet_Connectado Then Socket.SendData CH + ' + Exit Sub + +Form_KeyDown_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyDown" + Resume Next + ' +End Sub + +Private Sub Form_KeyPress(KeyAscii As Integer) + ' + On Error GoTo Form_KeyPress_Err + ' + Dim CH As String + + If Telnet_Connectado Then + CH = Chr$(KeyAscii) + + If control_on Then + If KeyAscii > 63 Then + CH = Chr$(KeyAscii - 64) + Else + CH = Chr$(0) + End If + End If + + If CH > Chr$(0) Then + If CH = Chr$(13) Then + CH = CH & Chr$(10) + End If + + Socket.SendData CH + End If + End If + + ' + Exit Sub + +Form_KeyPress_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyPress" + Resume Next + ' +End Sub + +Private Sub Form_KeyUp(KeyCode As Integer, _ + Shift As Integer) + ' + On Error GoTo Form_KeyUp_Err + + ' + Select Case KeyCode + + Case vbKeyControl + control_on = False + End Select + + ' + Exit Sub + +Form_KeyUp_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_KeyUp" + Resume Next + ' +End Sub + +Private Sub Form_Load() + ' + On Error GoTo Form_Load_Err + ' + Set Socket = New CSocketMaster + term_init + ' + Exit Sub + +Form_Load_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_Load" + Resume Next + ' +End Sub + +Private Sub Form_Paint() + ' + On Error GoTo Form_Paint_Err + ' + term_redrawscreen + ' + Exit Sub + +Form_Paint_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_Paint" + Resume Next + ' +End Sub + +Private Sub Form_QueryUnload(Cancel As Integer, _ + UnloadMode As Integer) + ' + On Error GoTo Form_QueryUnload_Err + + ' + With Socket + .CloseSck ' Clear any errors... + .RemoteHost = "0.0.0.0" + .RemotePort = 0 + End With + + Telnet_Connectado = False + ' + Exit Sub + +Form_QueryUnload_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Form_QueryUnload" + Resume Next + ' +End Sub + +Private Sub Socket_CloseSck() + ' + On Error GoTo Socket_CloseSck_Err + ' + Telnet_Connectado = False + ' + Exit Sub +Socket_CloseSck_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_CloseSck" + Resume Next + ' +End Sub + +Private Sub Socket_Connect() + ' + On Error GoTo Socket_Connect_Err + ' + Dim ConnectString As String + '------------------------------------------------------------ + sw_ugoahead = True + sw_igoahead = False + sw_echo = True + sw_termsent = False + ConnectString = Chr$(IAC) & Chr$(DOTEL) & Chr$(ECHO) & Chr$(IAC) & Chr$(DOTEL) & Chr$(SGA) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(NAWS) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMTYPE) & Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMSPEED) + Socket.SendData ConnectString + Telnet_Connectado = True + ' + Exit Sub +Socket_Connect_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_Connect" + Resume Next + ' +End Sub + +Private Sub Socket_DataArrival(ByVal bytesTotal As Long) + ' + On Error GoTo Socket_DataArrival_Err + ' + Dim CH() As Byte + Dim i As Integer + Static cmd As Byte + + '------------------------------------------------------------ + If Receiving Then + Exit Sub + Else + Receiving = True + term_CaretControl True + End If + + If (bytesTotal > 0) Then ' If there is any data... + Socket.GetData CH, vbByte + vbArray, bytesTotal + bytesTotal = bytesTotal - 1 + + ' CH = Buf + For i = 0 To bytesTotal + + Select Case cmd + + Case GO_NORM + cmd = term_process_char(CH(i)) + + Case GO_IAC1 + cmd = iac1(CH(i)) + + Case GO_IAC2 + cmd = iac2(CH(i)) + + Case GO_IAC3 + cmd = iac3(CH(i)) + + Case GO_IAC4 + cmd = iac4(CH(i)) + + Case GO_IAC5 + cmd = iac5(CH(i)) + + Case GO_IAC6 + cmd = iac6(CH(i)) + End Select + + Next + + End If + + 'Enviamos el siguiente comando + If nComando < UBound(TelnetComandos) And Socket.State = sckConnected Then + Socket.SendData TelnetComandos(nComando) & vbCrLf + Registrar "Telnet -> Enviado: " & TelnetComandos(nComando) + nComando = nComando + 1 + End If + + term_CaretControl False + Receiving = False + ' + Exit Sub +Socket_DataArrival_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.Socket_DataArrival" + Resume Next + ' +End Sub + +Private Function iac1(CH As Byte) As Integer + ' Debug.Print "IAC : "; + ' + On Error GoTo iac1_Err + ' + iac1 = GO_NORM + + Select Case CH + + Case DOTEL + iac1 = GO_IAC2 + + Case DONTTEL + iac1 = GO_IAC6 + + Case WILLTEL + iac1 = GO_IAC3 + + Case WONTTEL + iac1 = GO_IAC4 + + Case SB + iac1 = GO_IAC5 + ppno = 0 + + Case SE + + ' End of negotiation string, string is in parsedata() + Select Case parsedata(0) + + Case TERMTYPE + + If parsedata(1) = 1 Then + Socket.SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMTYPE) & "DEC-VT100" & Chr$(0) & Chr$(IAC) & Chr$(SE) + End If + + Case TERMSPEED + + If parsedata(1) = 1 Then + ' Debug.Print "TERMSPEED" + Socket.SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(CH) + Socket.SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMSPEED) & Chr$(0) & "57600,57600" & Chr$(IAC) & Chr$(SE) + End If + + End Select + End Select + + ' + Exit Function +iac1_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac1" + Resume Next + ' +End Function + +Private Function iac2(CH As Byte) As Integer + 'DO Processing Respond with WILL or WONT + ' + On Error GoTo iac2_Err + + ' + With Socket + iac2 = GO_NORM + + Select Case CH + + Case BINARY + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(BINARY) + + Case ECHO + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(ECHO) + + Case NAWS + .SendData Chr$(IAC) & Chr$(SB) & Chr$(NAWS) & Chr$(0) & Chr$(80) & Chr$(0) & Chr$(24) & Chr$(IAC) & Chr$(SE) + + Case SGA + + If Not sw_igoahead Then + .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(SGA) + sw_igoahead = True + End If + + Case TERMTYPE + + If Not sw_termsent Then + sw_termsent = True + .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMTYPE) + .SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMTYPE) & Chr$(0) & "VT100" & Chr$(IAC) & Chr$(SE) + End If + + Case TERMSPEED + .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(TERMSPEED) + .SendData Chr$(IAC) & Chr$(SB) & Chr$(TERMSPEED) & Chr$(0) + .SendData "57600,57600" + .SendData Chr$(IAC) & Chr$(SE) + + Case TFLOWCNTRL + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case LINEMODE + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case STATUS + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case TIMING + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case DISPLOC + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case ENVIRON + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case UNKNOWN39 + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case AUTHENTICATION + .SendData Chr$(IAC) & Chr$(WILLTEL) & Chr$(CH) + .SendData Chr$(IAC) & Chr$(SB) & Chr$(AUTHENTICATION) & Chr$(0) & Chr$(0) & Chr$(0) & Chr$(0) & Chr$(IAC) & Chr$(SE) + + Case Else + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + End Select + + End With + + ' + Exit Function +iac2_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac2" + Resume Next + ' +End Function + +Private Function iac3(CH As Byte) As Integer + ' WILL Processing - Respond with DO or DONT + ' + On Error GoTo iac3_Err + + ' + With Socket + iac3 = GO_NORM + + Select Case CH + + Case ECHO + + If Not sw_echo Then + sw_echo = True + .SendData Chr$(IAC) & Chr$(DOTEL) & Chr$(ECHO) + End If + + Case SGA + + If Not sw_ugoahead Then + sw_ugoahead = True + .SendData Chr$(IAC) & Chr$(DOTEL) & Chr$(SGA) + End If + + Case TERMSPEED + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case TFLOWCNTRL + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case LINEMODE + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case STATUS + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case TIMING + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case DISPLOC + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case ENVIRON + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case UNKNOWN39 + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case Else + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + End Select + + End With + + ' + Exit Function +iac3_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac3" + Resume Next + ' +End Function + +Private Function iac4(CH As Byte) As Integer + ' WONT Processing + ' + On Error GoTo iac4_Err + + ' + With Socket + iac4 = GO_NORM + + Select Case CH + + Case ECHO + + If sw_echo = True Then + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(ECHO) + sw_echo = False + End If + + Case SGA + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(SGA) + sw_igoahead = False + + Case TERMSPEED + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case TFLOWCNTRL + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case LINEMODE + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case STATUS + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case TIMING + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case DISPLOC + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case ENVIRON + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case UNKNOWN39 + .SendData Chr$(IAC) & Chr$(DONTTEL) & Chr$(CH) + + Case Else + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + End Select + + End With + + ' + Exit Function +iac4_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac4" + Resume Next + ' +End Function + +Private Function iac5(CH As Byte) As Integer + ' + On Error GoTo iac5_Err + ' + Dim ich As Integer + ' Collect parms after SB and until another IAC + ich = CH + + If ich = IAC Then + iac5 = GO_IAC1 + Exit Function + End If + + parsedata(ppno) = ich + ppno = ppno + 1 + iac5 = GO_IAC5 + ' + Exit Function +iac5_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac5" + Resume Next + ' +End Function + +Private Function iac6(CH As Byte) As Integer + 'DONT Processing + ' + On Error GoTo iac6_Err + + ' + With Socket + iac6 = GO_NORM + + Select Case CH + + Case SE + + ' + Case ECHO + + If Not sw_echo Then + sw_echo = True + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(ECHO) + End If + + Case SGA + + If Not sw_ugoahead Then + sw_ugoahead = True + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(SGA) + End If + + Case TERMSPEED + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case TFLOWCNTRL + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case LINEMODE + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case STATUS + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case TIMING + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case DISPLOC + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case ENVIRON + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case UNKNOWN39 + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + + Case Else + .SendData Chr$(IAC) & Chr$(WONTTEL) & Chr$(CH) + End Select + + End With + + ' + Exit Function +iac6_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.iac6" + Resume Next + ' +End Function + +Private Sub SOCKET_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) + ' + On Error GoTo SOCKET_ERROR_Err + + ' + If Number <> 10053 Then + NetError = True + Registrar "Telnet -> (" & Number & ") " & Description + Else + Registrar "Telnet -> Bien, el router abandonó la conexión" + End If + + ' + Exit Sub +SOCKET_ERROR_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.SOCKET_ERROR" + Resume Next + ' +End Sub + +Public Sub ProcTelnet() + ' + On Error GoTo ProcTelnet_Err + ' + Registrar "~ProcTelnet - Nivel 1" + + With Socket + .CloseSck + .RemotePort = m_Datos.puerto + .RemoteHost = m_Datos.base + .Protocol = sckTCPProtocol + .Connect + term_init + Registrar "~ProcTelnet - Nivel 2" + + Do Until Telnet_Connectado Or NetError + Esperar 0.5 + Loop + + Registrar "~ProcTelnet - Nivel 3" + End With + + ' + Exit Sub +ProcTelnet_Err: + Controlar_Error Erl, Err.Description, "Reseter.frmTelnet.ProcTelnet" + Resume Next + ' +End Sub -- 2.11.4.GIT