Buscar Dato Especifico en una Pagina WEB

'***************************************************************

'& &*

'& &*

'& &*

'& &*

'& Jefferson Jimenez (JJJT) &*

'& Cabimas - Venezuela &*

'& Febrero - 2011 &*

'& &*

'& &*

'& &*

'& &*

'& &*

'***************************************************************

'Las API

Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" ( _

ByVal lpBuffer As String, _

ByVal nSize As Long) As Long

Private Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" _

(ByVal sAgent As String, ByVal lAccessType As Long, _

ByVal sProxyName As String, ByVal sProxyBypass As String, _

ByVal lFlags As Long) As Long

Private Declare Function InternetOpenUrl Lib "wininet.dll" Alias "InternetOpenUrlA" _

(ByVal hInternetSession As Long, ByVal sURL As String, _

ByVal sHeaders As String, ByVal lHeadersLength As Long, _

ByVal lFlags As Long, ByVal lContext As Long) As Long

Private Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As Long, _

ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _

lNumberOfBytesRead As Long) As Integer

Private Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As Long) _

As Integer

'Establezco las Constantes

Const PagWeb = "http://contribuyente.seniat.gob.ve/BuscaRif/BuscaRif.jsp?p_rif=", _

EscribeCaChe = &H4000000, _

LenBuff = 256, _

CadenVacia = vbNullString

'Const PagWeb = "http://www.seniat.gov.ve/BuscaRif/BuscaRif.jsp?p_rif=", _

EscribeCaChe = &H4000000, _

LenBuff = 256, _

CadenVacia = vbNullString

'Variable privadas del modulo

Private RifValue2 As Variant

Private NameCpo As Boolean

Public Actividad As Variant

Public Condicion As Variant

Public PorcentajeContr As Variant

Public Actualizado As Variant

Public StrCondicion As Variant

Public EmpresaAct As Boolean

'Funcion para buscar un dato especifico en una pagina WEB

'especificamente en "VENEZUELA" donde las empresas estan registradas

'bajo un numero de RIF y es necesario verificar la existencia de esta empresa

Function BuscaNameRIF _

(Optional CpoTxtRIF, Optional CpoTxtRes As Control) As String

On Error Resume Next

'Creo la referencia a Microsoft Scripting Runtime

References.AddFromFile (SystemFolder & "scrrun.dll") 'La Agrego

'Asigno Variables de Uso

Dim NRif As String

Dim NRif2 As String

Dim NoExiste As String

Dim CpoTxtWeb As Variant

Dim lngWEB As Long

Dim CodeFuente As Variant

'Verifico que exista la conexion a internet

If NameCpo = True Then

MsgBox "Disculpe no hay conexion a internet" _

& vbCrLf & "Vuelva a intentar", vbInformation, "JJJT"

CpoTxtRIF.Value = Null 'Vacio los campos

CpoTxtRes.Value = Null

NameCpo = False 'Devuelvo el valor original a la variable

Exit Function 'Detengo la ejecucion del codigo

End If

'De no haber nada escrito en el campo txtRIF

If IsNull(CpoTxtRIF) Then

MsgBox "Se necesita un numero de RIF ", vbCritical, "JJJT"

CpoTxtRIF.SetFocus

Exit Function

Else

'Obtengo el Codigo Fuente de la Pagina Web y se lo paso a una variable variante

CpoTxtWeb = CodigoFuente(PagWeb & CpoTxtRIF.Value)

'modifico la misma variable y me creo un archivo txt solo de la linea 73

'asignandole lo leido

CpoTxtWeb = LeeLineaTxt(73)

Actividad = LeeLineaTxt(85)

Condicion = LeeLineaTxt(87)

If InStr(1, Condicion, "Condición: Contribuyente Ordinario del IVA", 1) > 0 Then

PorcentajeContr = "Porcentaje de Retencion 75%"

StrCondicion = "La condición de este contribuyente requiere la retención del 75% del impuesto causado, salvo que incurra en los supuestos establecidos para la retención del 100%."

Condicion = Condicion & " y Agente de Retención del IVA " & StrCondicion

Else

Condicion = Condicion

StrCondicion = "La condición de este contribuyente requiere la retención del 100% del impuesto causado, salvo que esté exento, no sujeto o demuestre ante el Agente de Retención del IVA que es un contribuyente exonerado."

PorcentajeContr = "Porcentaje de Retencion 100%"

End If

Actualizado = LeeLineaTxt(95)

If InStr(1, Actualizado, "ACTUALIZADO", 1) > 1 Then

EmpresaAct = True

Else

EmpresaAct = False

End If

'Extraigo solo el RIF y se lo paso a una variable

NRif = Mid(CpoTxtWeb, 48, 10)

'Extraigo el nombre de la empresa asociada a este RIF

NRif2 = Right(CpoTxtWeb, Len(CpoTxtWeb) - InStrRev(CpoTxtWeb, ";"))

'Le asigno valor a una variable en caso de no existir el RIF escrito al campo

NoExiste = Left(User(NRif2, "("), 9)

'Verifico exista la pagina

CodeFuente = CodigoFuente(PagWeb & CpoTxtRIF.Value)

lngWEB = InStr(1, CodeFuente, "404 Not Found", 1)

If lngWEB <> 0 Then

MsgBox "la pagina solicitada no existe", vbInformation, "JJJT"

'Elimino el txt

Kill CurrentProject.Path & "\TxtRif.txt"

Exit Function

End If

'Leo la variable y la comparo

If NoExiste = "No existe" Then

MsgBox "No existe el contribuyente asociado", vbInformation, "JJJT"

PorcentajeContr = ""

CpoTxtRIF.Value = Null 'Vacio el campo

CpoTxtRIF.SetFocus

'Elimino el txt

Kill CurrentProject.Path & "\TxtRif.txt"

Exit Function

End If

'Limpio la variable y solo coloco el nombre de la empresa a la funcion

BuscaNameRIF = User(NRif2, "(")

'Elimino el txt

Kill CurrentProject.Path & "\TxtRif.txt"

End If

'Fin del codigo

If Err.Number = 424 Then Err.Clear

Err.Clear

End Function

Private Function CodigoFuente(DireccionURL As String) As String

'Abro reloj

DoCmd.Hourglass True

'Asigno Variables de Uso

Dim Bufer As String * LenBuff

Dim Reslt As Integer

Dim Datos As String

Dim AbrirURL As Long

Dim AbrirInternet As Long

Dim RetoRno As Long

'Abro Internet cargandome la DLL WiniNet

AbrirInternet = InternetOpen("vb wininet", 1, CadenVacia, CadenVacia, 0)

'Acto seguido abro la pagina WEB

AbrirURL = InternetOpenUrl _

(AbrirInternet, DireccionURL, CadenVacia, 0, EscribeCaChe, 0)

'Si la Funcion esta cargada

If AbrirInternet <> 0 Then

'Y logro abrir la pagina

If AbrirURL Then

'Le paso el binario de la pagina WEB

Reslt = InternetReadFile(AbrirURL, Bufer, LenBuff, RetoRno)

'Cargo los datos leidos por la API y se los paso a la varible

Datos = Bufer

Do While RetoRno <> 0 'Termino haciendolo creando un Bucle

Reslt = InternetReadFile(AbrirURL, Bufer, LenBuff, RetoRno)

Datos = Datos + Mid(Bufer, 1, RetoRno)

Loop

'Cierro

End If

'De no haber conexion a internet

If Reslt = 0 Then

NameCpo = True

Call BuscaNameRIF

DoCmd.Hourglass False

Exit Function

End If

'Cierro la Hwnd de la DLL WiniNet

Reslt = InternetCloseHandle(AbrirURL)

'Le paso todo lo leido a la funcion

CodigoFuente = Datos

'Luego creo el txt para poder leer la linea que yo quiero

EscribeTxt CodigoFuente

Else

'De no haber conexion a internet

MsgBox "Disculpe no hay conexion a internet" _

& vbCrLf & "Vuelva a intentar", vbInformation, "JJJT"

End If

'Cierro

'Y desactivo el Reloj

DoCmd.Hourglass False

End Function

Private Sub EscribeTxt(Datos As String)

'Por aqui escribo lo leido y creo un txt

Dim NumeroInt As Long

Dim LaRuta As String

Dim Escribe As String

LaRuta = CurrentProject.Path

LaRuta = LaRuta & "\" & "TxtRif.txt"

NumeroInt = FreeFile

Open LaRuta For Output As #NumeroInt

Escribe = Datos

Print #NumeroInt, Escribe

Close #NumeroInt

End Sub

Private Function User(StrCtl As String, Optional Caracter As String) As String

'Con esta funcion reviso una cadena, para eliminar algun caracter que le indique

Dim Usere As String

Dim Usar As String

If Caracter = "" Then

Usar = Right(StrCtl, Len(StrCtl) - InStrRev(StrCtl, "\"))

User = Usar

Exit Function

Else

Usar = Right(StrCtl, Len(StrCtl) - InStrRev(StrCtl, "\"))

Usere = Right(Usar, Len(Usar) - InStrRev(Usar, Caracter) + 1)

If Left(Usere, 1) = Caracter Then

User = Left(Usar, InStrRev(Usar, Caracter) - 1)

Else

User = Usar

End If

End If

End Function

Private Function LeeLineaTxt(LiNea As Long) As String

On Error Resume Next

'Declaro las variable

Dim fso As New FileSystemObject

Dim archivo As TextStream

Dim i As Integer

'Creo un nuevo Objeto

Set fso = CreateObject("Scripting.FileSystemObject")

'Creo un marcador de posicion variable

Set archivo = fso.OpenTextFile(CurrentProject.Path & "\TxtRif.txt", 1)

'Recorro el txt y me detengo en la linea especificada

For i = 1 To LiNea

'Leo la linea especificada a la cargo a la memoria del objeto

archivo.Skipline

Next 'Continuo el recorrido

'Al cerrar el bucle le escribo a la Funcion lo que leyo Skipline

LeeLineaTxt = archivo.readline()

'Cierro el Objeto

archivo.Close

'Desvinculo los Objetos

Set fso = Nothing

Set archivo = Nothing

Err.Clear

End Function

Private Function SystemFolder() As String

Dim Buffer As String * 256

Dim Tam As Long

' Muestra el path del directorio de sistema

Tam = GetSystemDirectory(Buffer, Len(Buffer))

SystemFolder = Left$(Buffer, Tam) & "\"

End Function