Actualiza Front-End de todas las estaciones de trabajo

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.