Aveces modificamos nuestra aplicación y quisiéramos que al terminarla, todas las Front-End que se encuentran en las diferentes estaciones de trabajo se actualizaran al detectar que se ha cambiado la versión..!!
Pues nada el código es un poco complejo, pero aplicable....
En este ejemplo uso un Formulario "frm_BuscoActualizacion" que no es mas que el lanzador de notificación en el SysTray de la barra Windows y el encargado de comparar las versiones
Un Código en un Modulo "Mdl_VersionSoft" que ejecuta la función de Actualizar
Option Compare Database
'Es necesario hacer Referencia a Microsoft Scripting Runtime
'Para que este codigo no valla a cascar las propiedades de ambas BD
'deben ser iguales
Option Explicit
'Aca colocamos el numero de la version
Public Const NumVersion = "1.0.0.1"
'Establezco donde guardar la version (en mi caso un fichero txt)
Public Const RutaVersionTxt = "\Version.txt"
'Establezco donde esta la version del servidor para que pueda comparar entre una y otra
'Si la tienes en RED seria : "\\Servidor\etc....."
Public Const VersionServidor = "C:\Actualizar Front-End\Carpeta del Servidor\Version.txt"
'Establezco donde esta el Archivo Front-End (claro en este ejemplo se llama Front-End)
'Si la tienes en RED seria : "\\Servidor\etc....."
Private Const RutaServidor = "C:\Actualizar Front-End\Carpeta del Servidor\Front-End(Servidor).accdb"
' En teoria solo abria que cambiar los datos de las constantes por los tuyos propios y listo
'************************************************************
'& &*
'& : || : &*
'& || &*
'& || &*
'& || &*
'& . - || - . &*
'& ( || ) &*
'& ) ( || ) ( &*
'& / || \ &*
'& ( || ) &*
'& ` ` &*
'& ` ____ ' &*
'& &*
'& Jefferson Jimenez (JJJT) &*
'& Cabimas - Venezuela &*
'& Octubre - 2011 &*
'& &*
'& &*
'& &*
'& &*
'& &*
'************************************************************
'//////////////////////////////////// EL CODIGO \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'Declaramos las APIs a utilizar
'Para Extraer el icono de la Carpeta
Private Declare Function ExtractAssociatedIcon Lib "shell32.dll" Alias "ExtractAssociatedIconA" _
(ByVal hInst As Long, _
ByVal lpIconPath As String, _
lpiIcon As Long) As Long
'Para cargar el Icono al SysTray
Private Declare Function LoadImage Lib "USER32" Alias "LoadImageA" _
(ByVal hInst As Long, _
ByVal lpsz As String, _
ByVal iImageType As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal fFlags As Long) As Long
'Para destruir el Icono del SysTray
Private Declare Function DestroyIcon Lib "USER32" (ByVal hIcon As Long) As Long
'Para Notificar al SysTray
Private Declare Function ShellNotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" _
(ByVal dwMessage As Long, _
lpData As NOTIFYICONDATA) As Long
'Para encontrar el TwipsPerPixelX
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
'Para extraer el nombre de la BD activa
Private Declare Function GetFileTitle Lib "comdlg32.dll" Alias "GetFileTitleA" _
(ByVal lpszFile As String, _
ByVal lpszTitle As String, _
ByVal cbBuf As Integer) As Integer
'La Estructura del SysTray al Notificar
Private Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 128
dwState As Long
dwStateMask As Long
szInfo As String * 256
uTimeout As Long
szInfoTitle As String * 64
dwInfoFlags As Long
End Type
'Las Constantes de la API ShellNotifyIcon
Public Const WM_LBUTTONDBLCLK = &H203
Const NIF_INFO = &H10
Const NIIF_INFO = &H1
Const NIM_ADD = &H0
Const NIM_MODIFY = &H1
Const NIM_DELETE = &H2
Const NIF_MESSAGE = &H1
Const NIF_ICON = &H2
Const NIF_TIP = &H4
Const WM_MOUSEMOVE = &H200
Const WM_LBUTTONDOWN = &H201
Const WM_LBUTTONUP = &H202
Const WM_RBUTTONDOWN = &H204
Const WM_RBUTTONUP = &H205
Const WM_RBUTTONDBLCLK = &H206
Const WM_MBUTTONDBLCLK = &H209
'Para copiar el archivo
Private Declare Function apiCopyFile Lib "kernel32" Alias "CopyFileA" _
(ByVal lpExistingFileName As String, _
ByVal lpNewFileName As String, _
ByVal bFailIfExists As Long) As Long
'Para Abrirlo despues de reiniciar
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" _
(ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'API para establecer un tiempo
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'Para buscar un fichero en un directorio
Private Declare Function JJJTExisteFile Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Boolean
Private SysTray As NOTIFYICONDATA
Private IcoNhWnd As Long
Private Ext As String
Private ArchTxt As String
Function EstaBD(Ruta As String)
Dim Buffer As String
Dim NombreBD As String
'Buffer de caracteres
Buffer = String(255, 0)
'Llamada a GetFileTitle, pasandole el path, el buffer y el tamaño
GetFileTitle Ruta, Buffer, Len(Buffer)
'Retornamos el nombre eliminando los espacios nulos
NombreBD = Left$(Buffer, InStr(1, Buffer, Chr$(0)) - 1)
'Busco por si tiene activo la extension
If InStr(1, NombreBD, ".", 1) > 0 Then
'si la tiene la elimino
EstaBD = Mid(NombreBD, 1, Len(NombreBD) - (Len(extension) + 1))
Else
'de no tenerla la dejo igual
EstaBD = NombreBD
End If
End Function
Function VersionAntigua()
VersionAntigua = LeeLineaTxtVersion(CurrentProject.Path & RutaVersionTxt, 0)
End Function
Function NuevaVersion()
NuevaVersion = LeeLineaTxtVersion(VersionServidor, 0)
End Function
Function ActualizaFE() As Long
On Error GoTo ProcError
'Verifico exista el archivo en la ruta
If JJJTExisteFile(RutaServidor) = False Then
MsgBox "El Archivo :" & vbCrLf & Chr(34) & RutaServidor & _
Chr(34) & vbCrLf & vbCrLf & _
"no es valido.", vbExclamation, "Error Version..." + EstaBD(CurrentDb.Name)
GoTo ExitProc
Else
'Copio el Archivo y suplanto el anterior
ActualizaFE = apiCopyFile(RutaServidor, CurrentProject.FullName, False)
End If
If ActualizaFE > 0 Then
'Abro el reloj de espera
DoCmd.Hourglass True: Sleep 4000: DoCmd.Hourglass False
'Notifico que se fue exitosa la actualizaion
MsgBox "La aplicacion se ha Actualizado Correctamente" & _
" vamos a reiniciar el Sistema...", vbInformation, "Actualizado.." + EstaBD(CurrentDb.Name)
'Y luego reinicio la apliacion
Reinicio
End If
ExitProc:
Exit Function
ProcError:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, _
"Error ..." + EstaBD(CurrentDb.Name)
Resume ExitProc
End Function
Sub EscribeTxtVersion(Datos As String, Archivo As String)
'Por aqui escribo lo leido y creo un txt
Dim NumeroInt As Long
Dim LaRuta As String
Dim Escribe As String
ArchTxt = Archivo
LaRuta = CurrentProject.Path
LaRuta = LaRuta & "\" & Archivo & ".txt"
'Si existe cambio el atributo a Normal
If JJJTExisteFile(LaRuta) Then Call SetAttr(LaRuta, vbNormal)
NumeroInt = FreeFile
Open LaRuta For Output As #NumeroInt
Escribe = Datos
Print #NumeroInt, Escribe
Close #NumeroInt
'Al salir vuelvo a ocultarlo
Call SetAttr(LaRuta, vbHidden + vbReadOnly)
End Sub
Function LeeLineaTxtVersion(RutaArchiVo As String, Linea As Long) As String
On Error Resume Next
'Declaro las variable
Dim fso As New FileSystemObject
Dim ArchiVoTxtStr As TextStream
Dim i As Integer
'Creo un nuevo Objeto
Set fso = CreateObject("Scripting.FileSystemObject")
'Creo un marcador de posicion variable
Set ArchiVoTxtStr = fso.OpenTextFile(RutaArchiVo, 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
ArchiVoTxtStr.SkipLine
Next 'Continuo el recorrido
'Al cerrar el bucle le escribo a la Funcion lo que leyo Skipline
LeeLineaTxtVersion = ArchiVoTxtStr.ReadLine()
'Cierro el Objeto
ArchiVoTxtStr.Close
'Desvinculo los Objetos
Set fso = Nothing
Set ArchiVoTxtStr = Nothing
Err.Clear
End Function
Function BuscaVersion() As Boolean
If VersionAntigua <> NuevaVersion Then
BuscaVersion = True
End If
End Function
Sub Reinicio()
Dim MiAplicacion As String
Dim ExeAccess As String
ExeAccess = SysCmd(acSysCmdAccessDir) & "MSAccess.exe "
MiAplicacion = CurrentProject.FullName
MiAplicacion = """" & MiAplicacion & """"
If extension = "accdr" Or extension = "accde" Or extension = "mde" Then
Call ShellExecute(Access.hWndAccessApp, "Open", MiAplicacion, "", "", 3)
Else
Shell ExeAccess & MiAplicacion & "", vbMaximizedFocus
End If
DoCmd.Quit
End Sub
Function extension()
Dim arch As String
arch = CurrentProject.FullName
extension = Mid(arch, InStr(arch, ".") + 1)
End Function
Sub NotificaSysTray( _
frm As Form, _
Optional TipText As String, _
Optional BalloonTipTex As String, _
Optional RutaIcon As String)
'Busco el Twips del form
TwipsPerPixelX frm
'Busco el long del Icono en la carpeta Access, dependiendo de la version
Select Case SysCmd(acSysCmdAccessVer)
Case 11
IcoNhWnd = ExtractAssociatedIcon(1, "C:\Archivos de programa\Microsoft Office\Office11\ACCESS.PIP", 0)
Case 12
IcoNhWnd = ExtractAssociatedIcon(1, "C:\Archivos de programa\Microsoft Office\Office12\ACCESS.PIP", 0)
Case 13
IcoNhWnd = ExtractAssociatedIcon(1, "C:\Archivos de programa\Microsoft Office\Office14\ACCESS.PIP", 0)
End Select
With SysTray
'Tamaño de la estructura al Systray
.cbSize = Len(SysTray)
'El hwnd del form activo
.hwnd = frm.hwnd
'El handle de la barra de tareas
.uID = vbNull
'Los flags para la estructura
.uFlags = NIF_ICON Or NIF_INFO Or NIF_MESSAGE Or NIF_TIP
'Estableze el mensaje a windows
.uCallbackMessage = WM_MOUSEMOVE
'Dibuja el Icono seleccionado a la barra de tareas
.hIcon = IcoNhWnd
'Le paso el Texto al tooltips
.szTip = TipText & Chr(0)
'El estado de la barra para los Balloon Tips
.dwState = vbNull
'La mascara de la barra para los Balloon Tips
.dwStateMask = vbNull
'El Texto del Balloon Tips
.szInfo = BalloonTipTex & Chr(0)
'El titulo del Balloon Tips
.szInfoTitle = EstaBD(CurrentDb.Name) & " Version " & VersionAntigua & Chr(0)
'Definitivamente la Forma Balloon Tips
.dwInfoFlags = NIIF_INFO
'Tiempo de duracion al pasar el mouse
.uTimeout = 100
End With
'Funcion al llamado API Notificando al Systray
Call ShellNotifyIcon(NIM_ADD, SysTray)
End Sub
Sub QuitaSysTray(frm As Form)
'Elimino la Notificacion al Systray
Call ShellNotifyIcon(NIM_DELETE, SysTray)
'Destruyo el icono
Call DestroyIcon(IcoNhWnd)
End Sub
Function TwipsPerPixelX(frm As Form) As Single
'--------------------------------------------------
'Returns the width of a pixel, in twips.
'--------------------------------------------------
Dim lngDC As Long
lngDC = GetDC(frm.hwnd)
TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, 88)
ReleaseDC frm.hwnd, lngDC
End Function
En el Ejemplo para descargar uso un AutoEjecutable que obligo a extraer en el Disco "C"
pues la dirección de los archivos(BD) en la practica se los deberías entregar tu.
y de esta manera me aseguro que el Ejemplo no se descargue en otra dirección.