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