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.
SelectionFile type iconFile nameDescriptionSizeRevisionTimeUser
ċ

Descargar
Descargue El Ejemplo  242 kb v. 1 24 oct. 2011 16:17 Jefferson Jimenez
Comments