USAMOS LOS SERVICIOS DE INTERNET INFORMACION SERVER DE WINDOWS XP O POSTERIOS
SERVIDOR WEB PUERTO 8081 Y SERVIDOR FTP 2121 ya que los puerto por defecto de conexion estan bloquados por la operadora.
CREAMOS EN EL FORMULARIO PRINCIPAL O PRINCIPAL MIDI LO SIGUIENTE:
'FROMULARIO CONECTAR
'LOS ARCHIVOS PARA DESCARGAS EESTAN COMPRIMIDOS PARA MEJORAR LA DESCARGA
'EL PROGRAMA SE ACTUALIZA AUTOMATICAMENTE PERO SI HAY UN ERROR SE PUEDE ACTUALIZAR POR EL BOTON ACTUALIZAR
'USA PROGRAMA ZIP32.DLL Y UNZIP32.DLL
EN EL FOMULARIO HIJO CON NOMBRE CONECTAR TENDRIA EL BOTON ACTUALIZAR VER IMAGEN
DENTRO DEL FORMULARIO CONEXION
Private Sub CmdActualizar_Click()
If MsgBox("¿Desea actualizar?", vbQuestion + vbYesNo, "Actualizar Hipico") = vbYes Then
Call Salir
Unload principal
Set principal = Nothing
Shell App.Path + "\actualizarBC.exe", vbNormalFocus
End If
Private Sub Version()
Dim versionapl As Double, xversionapl As Double
versionapl = Val(App.Major & App.Minor & App.Revision)
Dim rsp As ADODB.Recordset
If con.State = 0 Then
Call IniciarConexion
End If
con.Execute "use version"
'MsgBox "Fecha de creación del archivo: " & versionapl
Set rsp = New ADODB.Recordset
rsp.Open "select bc from version", con, adOpenForwardOnly, adLockReadOnly
If rsp(0) = 0 Then
con.Execute "update version set bc='" & versionapl & "' where 1"
End If
xversionapl = rsp(0)
If versionapl > xversionapl Then
con.Execute "update version set bc='" & versionapl & "' where 1"
End If
rsp.Close
Set rsp = Nothing
con.Execute "use " + GetSetting(App.Title, Me.Name, datos.Name) + ""
If versionapl < xversionapl Then
Unload principal
Set principal = Nothing
Shell App.Path + "\actualizarbc.exe", vbNormalFocus
End If
End Sub
Private Sub Salir()
'BANDERA PARA ACTUALIZAR
If bandera = 1 Then
date = DateValue(FechaServer)
Time = TimeValue(HoraServer)
Call Version
End If
Unload conexion
Set conexion = Nothing
End Sub
Public Sub ServerHour()
Dim rs1 As ADODB.Recordset
'CONTROLA LA HORA SEGUN MI USO HORARIO EN CLIENTE
Set rs1 = con.Execute("set time_zone='-04:30'")
Set rs1 = Nothing
'PONE LA HORA Y LA FECHA DE MI SERVIDOR
Set rs1 = con.Execute("select date_format(now(),'%d/%m/%Y')")
FechaServer = rs1(0)
Set rs1 = Nothing
Set rs1 = con.Execute("select time_format(now(),'%h:%i:%s %p')")
HoraServer = TimeValue(rs1(0))
rs1.Close
Set rs1 = Nothing
End SubEN OTRO PROYECTO DE PROGRAMA LLAMADO ACTUALIZARBC
VER IMAGEN
CUYO CODIGO ES:
'FORMULARIO ACTUALIZARBC
'COMPONETE DEL PROYECTO: MICROSOFT INTERNET TRANSFER CONTROL 6.0
'COMPONETE DEL PROYECTO: MICROSOFT WINDOWS COMMON CONTROLS 6.0 (SP6)
'UN FRAME
'UN LISTBOX
'UN PROGRESSBAR1
'TRES INET INET1,INET2,INET3
' UN LABEL CON NOMBRE DE DESCARGANDO
Option Explicit
Private Sub Form_Load()
'On Error GoTo err_sub
Dim fso As Object
'Instanciar el objeto FSO para poder _
usar las funciones FileExists y FolderExists
Set fso = CreateObject("Scripting.FileSystemObject")
Dim XDominio As String, XLocal As String
If App.PrevInstance Then End
ProgressBar1.Value = 0
'Inet1.Protocol = icFTP
Inet1.AccessType = icUseDefault
'Inet1.UserName = "administrador"
'Inet1.Password = "0987654321"
'Inet1.RemotePort = 2121
'Inet1.RequestTimeout = 120
'XLocal = App.Path + "\MIPROGRAMABC.exe"
'XDominio = "ftp://" + GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR") + "/MIPROGRAMABC.exe"
Inet1.RequestTimeout = 300
XDominio = "http://" + GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR") + ":8081/MIPROGRAMABC.zip"
Inet1.URL = XDominio
'Inet1.Execute , "put" & XDominio & " " & XLocal
Inet1.Execute , "GET"
DoEvents
' Comprobar archivo
If Not fso.FileExists(App.Path + "\unzip32.dll") Then
Inet2.AccessType = icUseDefault
Inet2.RequestTimeout = 300
XDominio = "http://" + GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR") + ":8081/unzip32.dll"
Inet2.URL = XDominio
Inet2.Execute , "GET"
DoEvents
Inet3.AccessType = icUseDefault
Inet3.RequestTimeout = 300
XDominio = "http://" + GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR") + ":8081/actualizarbc.exe"
Inet3.URL = XDominio
Inet3.Execute , "GET"
DoEvents
End If
Set fso = Nothing
'err_sub:
'MsgBox Err.Description, vbCritical, "error al usar Fso"
End Sub
Private Sub Inet1_StateChanged(ByVal State As Integer)
Select Case State
'estado
Case 0: Mostrar_Estado_FTP "..Conectando "
Case 1: Mostrar_Estado_FTP " Resolviendo Host "
Case 2: Mostrar_Estado_FTP " Host Resuelto "
Case 3: Mostrar_Estado_FTP " ..Conectando a: " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
Case 4: Mostrar_Estado_FTP "..Conectado a " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
Case 5: Mostrar_Estado_FTP " Petición"
Case 6: Mostrar_Estado_FTP "..Enviando petición"
'Case 7: Mostrar_Estado_FTP "Recibiendo Respuesta"
'Case 8: Mostrar_Estado_FTP " Respuesta recibida "
Case 9: Mostrar_Estado_FTP " ..Desconectando "
Case 10: Mostrar_Estado_FTP " Estado : Desconectado"
Case 11: Mostrar_Estado_FTP " Error: " & Inet1.ResponseInfo
MsgBox "No hay Conexión con Servidor intente más tarde", vbExclamation
Unload Actualizar
Set Actualizar = Nothing
Case 12: Mostrar_Estado_FTP Inet1.ResponseInfo
Mostrar_Estado_FTP " "
Mostrar_Estado_FTP "Descargando Nueva versión..."
Dim intFile As Integer
intFile = FreeFile()
Dim fs As Object
Dim vtData As Variant 'acá almacenamos los datos
Dim bDone As Boolean: bDone = False
Dim tempArray() As Byte ' Un array para grabar los datos en un archivo
Dim filesize As Long, contenttype As String
'Para saber el tamaño del fichero en bytes
filesize = Inet1.GetHeader("Content-length")
'Establecemos el Max del = a al tamaño del archivo
ProgressBar1.Max = filesize
contenttype = Inet1.GetHeader("Content-type")
' quitamos el archivo binario para ftp
'Creamos y abrimos un nuevo archivo en modo binario
'Open App.Path + "\MIPROGRAMABC.exe" For Binary Access Write As #intFile
Open "c:\MIPROGRAMABC.zip" For Binary Access Write As #intFile
' Leemos de a 1 Kbytes. El segundo parámetro indica _
el tipo de fichero. Tipo texto o tipo Binario, en este caso _
binario
vtData = Inet1.GetChunk(1024, icByteArray)
DoEvents
'Si el tamaño del fichero es 0 ponemos bDone en True para que no _
entre en el bucle
If Len(vtData) = 0 Then
bDone = True
End If
Do While Not bDone
'Almacenamos en un array el contenido del archivo
tempArray = vtData
'Escribimos el archivo en disco
Put #intFile, , tempArray
'Aumentamos la barra
ProgressBar1.Value = ProgressBar1.Value + Len(vtData) * 2
Label2 = CLng((ProgressBar1.Value * 100) / ProgressBar1.Max) & " %"
' Leemos de pedazos de a 1 kb (1024 bytes)
vtData = Inet1.GetChunk(1024, icByteArray)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Loop
Close #intFile
ProgressBar1.Value = 0
UnZip "c:\MIPROGRAMABC.zip", "c:\"
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile "c:\MIPROGRAMABC.exe", App.Path & "\MIPROGRAMABC.exe"
fs.DeleteFile "c:\MIPROGRAMABC.zip"
fs.DeleteFile "c:\MIPROGRAMABC.exe"
Set fs = Nothing
MsgBox "Actualizacion completada con exito", vbInformation, "Actualizacion VbaHipicoOnline"
Unload Actualizar
Set Actualizar = Nothing
Shell App.Path + "\MIPROGRAMABC.exe", vbNormalFocus
'Case Else: Mostrar_Estado_FTP " Estado -> " & Format$(State)
End Select
DoEvents
End Sub
Private Sub Inet2_StateChanged(ByVal State As Integer)
Select Case State
'estado
'Case 0: Mostrar_Estado_FTP "..Conectando "
'Case 1: Mostrar_Estado_FTP " Resolviendo Host "
'Case 2: Mostrar_Estado_FTP " Host Resuelto "
'Case 3: Mostrar_Estado_FTP " ..Conectando a: " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
'Case 4: Mostrar_Estado_FTP "..Conectado a " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
'Case 5: Mostrar_Estado_FTP " Petición"
'Case 6: Mostrar_Estado_FTP "..Enviando petición"
'Case 7: Mostrar_Estado_FTP "Recibiendo Respuesta"
'Case 8: Mostrar_Estado_FTP " Respuesta recibida "
'Case 9: Mostrar_Estado_FTP " ..Desconectando "
'Case 10: Mostrar_Estado_FTP " Estado : Desconectado"
'Case 11: Mostrar_Estado_FTP " Error: " & Inet2.ResponseInfo
'MsgBox "No hay Conexión con Servidor intente más tarde", vbExclamation
'Unload actualizar
'set actualizar= nothing
Case 12: Mostrar_Estado_FTP Inet2.ResponseInfo
Dim intFile As Integer
intFile = FreeFile()
Dim fs As Object
Dim vtData As Variant 'acá almacenamos los datos
Dim bDone As Boolean: bDone = False
Dim tempArray() As Byte ' Un array para grabar los datos en un archivo
Dim filesize As Long, contenttype As String
'Para saber el tamaño del fichero en bytes
filesize = Inet2.GetHeader("Content-length")
contenttype = Inet2.GetHeader("Content-type")
Open "c:\unzip32.dll" For Binary Access Write As #intFile
vtData = Inet2.GetChunk(1024, icByteArray)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Do While Not bDone
tempArray = vtData
Put #intFile, , tempArray
vtData = Inet2.GetChunk(1024, icByteArray)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Loop
Close #intFile
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile "c:\unzip32.dll", App.Path & "\unzip32.dll"
fs.DeleteFile "c:\unzip32.dll"
Set fs = Nothing
End Select
DoEvents
End Sub
Private Sub Inet3_StateChanged(ByVal State As Integer)
Select Case State
'estado
'Case 0: Mostrar_Estado_FTP "..Conectando "
'Case 1: Mostrar_Estado_FTP " Resolviendo Host "
'Case 2: Mostrar_Estado_FTP " Host Resuelto "
'Case 3: Mostrar_Estado_FTP " ..Conectando a: " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
'Case 4: Mostrar_Estado_FTP "..Conectado a " & GetSetting("MIPROGRAMABC", "CONEXION", "SERVIDOR")
'Case 5: Mostrar_Estado_FTP " Petición"
'Case 6: Mostrar_Estado_FTP "..Enviando petición"
'Case 7: Mostrar_Estado_FTP "Recibiendo Respuesta"
'Case 8: Mostrar_Estado_FTP " Respuesta recibida "
'Case 9: Mostrar_Estado_FTP " ..Desconectando "
'Case 10: Mostrar_Estado_FTP " Estado : Desconectado"
'Case 11: Mostrar_Estado_FTP " Error: " & Inet3.ResponseInfo
'MsgBox "No hay Conexión con Servidor intente más tarde", vbExclamation
'Unload actualizar
'set actualizar=nothing
Case 12: Mostrar_Estado_FTP Inet3.ResponseInfo
Dim intFile As Integer
intFile = FreeFile()
Dim fs As Object
Dim vtData As Variant 'acá almacenamos los datos
Dim bDone As Boolean: bDone = False
Dim tempArray() As Byte ' Un array para grabar los datos en un archivo
Dim filesize As Long, contenttype As String
'Para saber el tamaño del fichero en bytes
filesize = Inet3.GetHeader("Content-length")
contenttype = Inet3.GetHeader("Content-type")
Open "c:\actualizarbc.exe" For Binary Access Write As #intFile
vtData = Inet3.GetChunk(1024, icByteArray)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Do While Not bDone
tempArray = vtData
Put #intFile, , tempArray
vtData = Inet3.GetChunk(1024, icByteArray)
DoEvents
If Len(vtData) = 0 Then
bDone = True
End If
Loop
Close #intFile
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile "c:\actualizarbc.exe", App.Path & "\actualizarbc.exe"
fs.DeleteFile "c:\actualizarbc.exe"
Set fs = Nothing
End Select
DoEvents
End Sub
Private Sub Mostrar_Estado_FTP(ByVal estado As String)
List1.AddItem estado
List1.ListIndex = List1.ListCount - 1
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
' Cierra la conexión ftp
Call Desconectar_FTP
End Sub
Sub Desconectar_FTP()
On Error Resume Next
Call Mostrar_Estado_FTP(" [ Desconectando del serviror ]")
Inet1.Execute , "QUIT"
Inet1.Execute , "CLOSE"
End Sub
'******************************************************************' MODULO UNZIP.BAS
Private Type CBChar
ch(4096) As Byte
End Type
Private Type UNZIPUSERFUNCTION
UNZIPPrntFunction As Long
UNZIPSndFunction As Long
UNZIPReplaceFunction As Long
UNZIPPassword As Long
UNZIPMessage As Long
UNZIPService As Long
TotalSizeComp As Long
TotalSize As Long
CompFactor As Long
NumFiles As Long
Comment As Integer
End Type
Private Type UNZIPOPTIONS
ExtractOnlyNewer As Long
SpaceToUnderScore As Long
PromptToOverwrite As Long
fQuiet As Long
ncflag As Long
ntflag As Long
nvflag As Long
nUflag As Long
nzflag As Long
ndflag As Long
noflag As Long
naflag As Long
nZIflag As Long
C_flag As Long
FPrivilege As Long
Zip As String
extractdir As String
End Type
Private Type ZIPnames
s(0 To 99) As String
End Type
Public Declare Function Wiz_SingleEntryUnzip Lib "unzip32.dll" (ByVal ifnc As Long, ByRef ifnv As ZIPnames, ByVal xfnc As Long, ByRef xfnv As ZIPnames, dcll As UNZIPOPTIONS, Userf As UNZIPUSERFUNCTION) As Long
Public Sub UnZip(Zip As String, extractdir As String)
On Error GoTo err_Unzip
Dim Resultado As Long
Dim intContadorFicheros As Integer
Dim FuncionesUnZip As UNZIPUSERFUNCTION
Dim OpcionesUnZip As UNZIPOPTIONS
Dim NombresFicherosZip As ZIPnames, NombresFicheros2Zip As ZIPnames
NombresFicherosZip.s(0) = vbNullChar
NombresFicheros2Zip.s(0) = vbNullChar
FuncionesUnZip.UNZIPMessage = 0&
FuncionesUnZip.UNZIPPassword = 0&
FuncionesUnZip.UNZIPPrntFunction = DevolverDireccionMemoria(AddressOf UNFuncionParaProcesarMensajes)
FuncionesUnZip.UNZIPReplaceFunction = DevolverDireccionMemoria(AddressOf UNFuncionReplaceOptions)
FuncionesUnZip.UNZIPService = 0&
FuncionesUnZip.UNZIPSndFunction = 0&
OpcionesUnZip.C_flag = 1
OpcionesUnZip.fQuiet = 2
OpcionesUnZip.noflag = 1
OpcionesUnZip.Zip = Zip
OpcionesUnZip.extractdir = extractdir
Resultado = Wiz_SingleEntryUnzip(0, NombresFicherosZip, 0, NombresFicheros2Zip, OpcionesUnZip, FuncionesUnZip)
Exit Sub
err_Unzip:
MsgBox "Unzip: " + Err.Description, vbExclamation
Err.Clear
End Sub
Private Function UNFuncionParaProcesarMensajes(ByRef fname As CBChar, ByVal X As Long) As Long
On Error GoTo err_UNFuncionParaProcesarMensajes
UNFuncionParaProcesarMensajes = 0
Exit Function
err_UNFuncionParaProcesarMensajes:
MsgBox "UNFuncionParaProcesarMensajes: " + Err.Description, vbExclamation
Err.Clear
End Function
Private Function UNFuncionReplaceOptions(ByRef p As CBChar, ByVal L As Long, ByRef m As CBChar, ByRef Name As CBChar) As Integer
On Error GoTo err_UNFuncionReplaceOptions
UNFuncionParaProcesarPassword = 0
Exit Function
err_UNFuncionReplaceOptions:
MsgBox "UNFuncionParaProcesarPassword: " + Err.Description, vbExclamation
Err.Clear
End Function
Public Function DevolverDireccionMemoria(Direccion As Long) As Long
On Error GoTo err_DevolverDireccionMemoria
DevolverDireccionMemoria = Direccion
Exit Function
err_DevolverDireccionMemoria:
MsgBox "DevolverDireccionMemoria: " + Err.Description, vbExclamation
Err.Clear
End Function
'*****************************************************************************************
