Buscar Dato Especifico en una Pagina WEB

Función para buscar y/o verificar un DATO en una pagina WEB
específicamente en "VENEZUELA" donde las empresas están registradas
bajo un numero de RIF y es necesario verificar la existencia de esta empresa

Es requisito obligatorio del SENIAT verificar el numero de RIF de las empresas. 
Esto debe hacerse al momento de facturar, bien consultando en la pagina del SENIAT o 
presentando el RIF de la empresa en original.

Para ello he creado un Código que ha continuación publico

Option Explicit
'***************************************************************
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&                                                            &*
'&               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






SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ

Descargar
Descargue el Ejemplo  31 kb v. 1 9 abr. 2011 19:53 Jefferson Jimenez
Comments