Pescaderías

Mapa: Comunas prioritarias y competencia estimada. Fuente: búsquedas públicas. Si el mapa aparece en blanco, asegúrate de permitir la carga de recursos externos (CDN).

XML - Download File - VBA Excel

Tengo un archivo que es usado por distintas personas, necesito realizar una modificación a gran escala en una de las hojas. Para esto usé un archivo estándar que se encontrará online en el servidor y los archivos de las personas puedan diferenciar si tienen una versión antigua comparando el archivo estandar. Para lograr esto, en el archivo usado por el personal cree un macro que valida la versión tanto del archivo personal como del online. También se valida que tengan Internet para realizar el update. y por ultimo se valida que si no realiza la actualización, no puede usar el archivo personal.


Inicio automático validación archivo personal:

Sub Auto_Open() 'Ejecuta el macro cuando abrimos el archivo excel personal.
    GetCurrentVersionNumber
End Sub


Obtención de versión:
Function GetCurrentVersionNumber() As String
    Dim doc As MSXML2.DOMDocument
    Dim version As String
    
    If (checkInternetConnection = True) Then 'valida conexion a internet
        Set doc = New MSXML2.DOMDocument 'usamos la referencia correspondiente.
        doc.async = False
        doc.Load ("http://IP o RUTA/prueba/currentversion.xml") 'ruta del archivo que está online en el server.
            
            GetCurrentVersionNumber = doc.SelectSingleNode("/AppData/Version").Text 'obtiene la version que aparece en el archivo currentversion.xml.
            GetCurrentVersionRut = doc.SelectSingleNode("/AppData/Ruta").Text 'lo mismo de arriba pero buscando la ruta.
            version = Sheets.Item("Horas x Modelo").Cells(1, 2).Value 'obtengo la version del archivo personal.
        
            If (Sheets.Item("Horas x Modelo").Cells(1, 2).Value <> GetCurrentVersionNumber) Then 'valido que tengan la misma version.
                MessageBoxOption GetCurrentVersionNumber 'si la version es distinta, me saldrá un mensaje para descargar la nueva version, en caso de no bajar la version, el archivo se cierra.
            End If
    Else
        MsgBox ("No tienes conexion a internet y lo requieres!!!") 'si no se encuentra conectado a internet.
    End If
End Function


Mensaje validador:

Sub MessageBoxOption(version)
    Dim iRet As Integer
    Dim strPrompt As String
    Dim strTitle As String
 
    ' Mensaje
    strPrompt = "Tienes una nueva versión de MP para descargar. Este proceso se hará de forma automatica."
 
    ' Titulo
    strTitle = "Versión " & version 'genero el titulo con la version nueva.
 
    'Botones cuadro mensaje
    iRet = MsgBox(strPrompt, vbYesNo, strTitle)
 
    ' Validador yes no
    If iRet = vbNo Then
        Application.DisplayAlerts = False
        Application.Quit 'si elige no, saldra del Excel.
    Else
        DownloadFile version ' si selecciona si, descargará el archivo.
    End If
End Sub

Descargar archivo:

Sub DownloadFile(version)

Dim myURL As String 'creo variables
Dim rutaExcel As String
Dim rutaServidor As String

rutaExcel = Application.ActiveWorkbook.Path 'saco la ruta estatica del archivo personal
myURL = "http://IP o Ruta/prueba/respaldos/" & version & ".xlsx" 'URl del servidor donde esta el archivo online

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile rutaExcel & "\" & version & ".xlsx", 2  ' 1 = no overwrite, 2 = overwrite" descargo el archivo
    oStream.Close
End If

copiarAotroLibro rutaExcel & "\" & version & ".xlsx", version & ".xlsx" 'llamo la funcion para realizar la copia de los datos.

MsgBox (rutaExcel & "\" & version & ".xlsx")
'revisa rutaExcel & "\" & version & ".xlsx"
End Sub

Validar Internet:
Function checkInternetConnection() As Boolean

On Error Resume Next
 checkInternetConnection = False
 Dim objSvrHTTP As ServerXMLHTTP
 Dim varProjectID, varCatID, strT As String
 Set objSvrHTTP = New ServerXMLHTTP
 objSvrHTTP.Open "GET", "http://www.google.com"
 objSvrHTTP.setRequestHeader "Accept", "application/xml"
 objSvrHTTP.setRequestHeader "Content-Type", "application/xml"
 objSvrHTTP.send strT
 If err = 0 Then
 checkInternetConnection = True
 Else
  'MsgBox "Sin internet: " & Err.Description & "", 64, "Additt !"
  checkInternetConnection = False
 End If
End Function



Copia hoja archivo descargado:

Sub copiarAotroLibro(archivo, version)
Dim nombreLibro As String

nombreLibro = ActiveWorkbook.Name
Worksheets.Item("Horas x Modelo").Visible = True

Application.ScreenUpdating = False
Workbooks.Open (archivo)
'Windows("origen.xls").Activate
Sheets("Estandar").Select
Sheets("Estandar").Copy After:=Workbooks(nombreLibro).Sheets("Horas x Modelo")
Application.ScreenUpdating = True

For Each she In Worksheets
a = she.Name
If a = "Horas x Modelo" Then
    Application.DisplayAlerts = False
    she.Delete
End If
Next

For Each she In Worksheets
a = she.Name
If a = "Estandar" Then she.Name = "Horas x Modelo"
Next

Workbooks(version).Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Worksheets.Item("Horas x Modelo").Protect Password:="icvsa", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True

Worksheets.Item("Horas x Modelo").Visible = False

End Sub


Código completo:

 
Sub Auto_Open() 'Ejecuta el macro cuando abrimos el archivo excel personal.
    GetCurrentVersionNumber
End Sub

Function GetCurrentVersionNumber() As String
    Dim doc As MSXML2.DOMDocument
    Dim version As String
    
    If (checkInternetConnection = True) Then 'valida conexion a internet
        Set doc = New MSXML2.DOMDocument 'usamos la referencia correspondiente.
        doc.async = False
        doc.Load ("http://IP o RUTA/prueba/currentversion.xml") 'ruta del archivo que está online en el server.
            
            GetCurrentVersionNumber = doc.SelectSingleNode("/AppData/Version").Text 'obtiene la version que aparece en el archivo currentversion.xml.
            GetCurrentVersionRut = doc.SelectSingleNode("/AppData/Ruta").Text 'lo mismo de arriba pero buscando la ruta.
            version = Sheets.Item("Horas x Modelo").Cells(1, 2).Value 'obtengo la version del archivo personal.
        
            If (Sheets.Item("Horas x Modelo").Cells(1, 2).Value <> GetCurrentVersionNumber) Then 'valido que tengan la misma version.
                MessageBoxOption GetCurrentVersionNumber 'si la version es distinta, me saldrá un mensaje para descargar la nueva version, en caso de no bajar la version, el archivo se cierra.
            End If
    Else
        MsgBox ("No tienes conexion a internet y lo requieres!!!") 'si no se encuentra conectado a internet.
    End If
End Function

Sub MessageBoxOption(version)
    Dim iRet As Integer
    Dim strPrompt As String
    Dim strTitle As String
 
    ' Mensaje
    strPrompt = "Tienes una nueva versión de MP para descargar. Este proceso se hará de forma automatica."
 
    ' Titulo
    strTitle = "Versión " & version 'genero el titulo con la version nueva.
 
    'Botones cuadro mensaje
    iRet = MsgBox(strPrompt, vbYesNo, strTitle)
 
    ' Validador yes no
    If iRet = vbNo Then
        Application.DisplayAlerts = False
        Application.Quit 'si elige no, saldra del Excel.
    Else
        DownloadFile version ' si selecciona si, descargará el archivo.
    End If
End Sub

Sub DownloadFile(version)

Dim myURL As String 'creo variables
Dim rutaExcel As String
Dim rutaServidor As String

rutaExcel = Application.ActiveWorkbook.Path 'saco la ruta estatica del archivo personal
myURL = "http://IP o Ruta/prueba/respaldos/" & version & ".xlsx" 'URl del servidor donde esta el archivo online

Dim WinHttpReq As Object
Set WinHttpReq = CreateObject("Microsoft.XMLHTTP")
WinHttpReq.Open "GET", myURL, False, "username", "password"
WinHttpReq.send

myURL = WinHttpReq.responseBody
If WinHttpReq.Status = 200 Then
    Set oStream = CreateObject("ADODB.Stream")
    oStream.Open
    oStream.Type = 1
    oStream.Write WinHttpReq.responseBody
    oStream.SaveToFile rutaExcel & "\" & version & ".xlsx", 2  ' 1 = no overwrite, 2 = overwrite" descargo el archivo
    oStream.Close
End If

copiarAotroLibro rutaExcel & "\" & version & ".xlsx", version & ".xlsx" 'llamo la funcion para realizar la copia de los datos.

MsgBox (rutaExcel & "\" & version & ".xlsx")
'revisa rutaExcel & "\" & version & ".xlsx"
End Sub

Sub copiarAotroLibro(archivo, version)
Dim nombreLibro As String

nombreLibro = ActiveWorkbook.Name
Worksheets.Item("Horas x Modelo").Visible = True

Application.ScreenUpdating = False
Workbooks.Open (archivo)
'Windows("origen.xls").Activate
Sheets("Estandar").Select
Sheets("Estandar").Copy After:=Workbooks(nombreLibro).Sheets("Horas x Modelo")
Application.ScreenUpdating = True

For Each she In Worksheets
a = she.Name
If a = "Horas x Modelo" Then
    Application.DisplayAlerts = False
    she.Delete
End If
Next

For Each she In Worksheets
a = she.Name
If a = "Estandar" Then she.Name = "Horas x Modelo"
Next

Workbooks(version).Close True
Application.ScreenUpdating = True
Application.DisplayAlerts = True

Worksheets.Item("Horas x Modelo").Protect Password:="icvsa", DrawingObjects:=True, Contents:=True, Scenarios:=True _
, AllowSorting:=True, AllowFiltering:=True, AllowUsingPivotTables:=True

Worksheets.Item("Horas x Modelo").Visible = False

End Sub

Function checkInternetConnection() As Boolean

On Error Resume Next
 checkInternetConnection = False
 Dim objSvrHTTP As ServerXMLHTTP
 Dim varProjectID, varCatID, strT As String
 Set objSvrHTTP = New ServerXMLHTTP
 objSvrHTTP.Open "GET", "http://www.google.com"
 objSvrHTTP.setRequestHeader "Accept", "application/xml"
 objSvrHTTP.setRequestHeader "Content-Type", "application/xml"
 objSvrHTTP.send strT
 If err = 0 Then
 checkInternetConnection = True
 Else
  'MsgBox "Sin internet: " & Err.Description & "", 64, "Additt !"
  checkInternetConnection = False
 End If
End Function

Public Sub revisa(ruta)
Dim test As String
test = Dir(ruta)
    If test <> "" Then
        Kill (ruta)
    End If
End Sub

Public Sub limpiaLista()
    Sheets.Item("Listado").Range("B3:Y1000").ClearContents
End Sub

Public Sub limpiaControl()
    Sheets.Item("Control PMs").Range("A2:G100").ClearContents
    Sheets.Item("Control PMs").Range("I2:L100").ClearContents
    Sheets.Item("Control PMs").Range("A2:L100").Interior.ColorIndex = xlNone
End Sub


Archivo XML en server:

 


  1.2
  http://localhost/prueba/respaldos/1.2.xlsx


Referencia faltantes:


Comentarios

Publicar un comentario

Entradas populares de este blog

Descarga revistas yumpu.com

Imagen
Como el titulo lo dice, generé un pequeño programa que realiza descargas de las revisar publicadas en yumpu.com. Necesitaba/n un archivo que había sido subido a este portal, el brillo es que se encuentra en un ember por lo que no se puede bajar o incluso siquiera revise si se podía. De igual manera, este es el código del programa por si alguien lo quiere mejorar o bajar imágenes desde otros lados y weas. Lo que hace el programa es bajar las imágenes de cada revisar que se encuentran en una ruta especifica. Para esto se debe entregar al programa el numero de la revista que se muestra en la imagenes N° 1. También se puede ver un JSON el cual nos presenta los tamaños de las imágenes y la cantidad de archivos. Una vez descargadas las imágenes, procedemos a transformar todo en un PDF y borrar las imágenes. El programa se realizo en C# con SharpDevelop en modo consola, las librerias itextSharp y NewtonSoft Json. De no ser libres estas librerías, besitos para que me perdonen de no ser a...
Leer más

Sorting Algorithm VBA

Necesitaba ordenar un valor en base a una lista de fechas ordenadas descendentes. No tenia idea como hacerlos y tampoco encontraba información al respecto. Cada vez que tengo una duda que ya no puedo solucionar, le pido ayuda a mi amigo Cristian Lizana para que me de una pista y encontrar el camino correcto. Me comentó de Sorting_algorithm  el cual respondía a mis necesidades. Implementé un código para analizar un rango que selecciono en Excel. Set rango = Application.InputBox(Prompt:="Seleccionar rango oe!!!", Title:="Seleccion de rango", Type:=8) 'Obtengo un rango seleccionado. x = 1 For i = 1 To rango.Rows.Count 'ingreso a un array todas las fechas seleccionadas. If (rango.Cells(i, 2).Value = componente) Then ReDim Preserve arrfech(x) arrfech(x) = CDate(rango.Cells(i, 1).Value) x = x + 1 End If Next i Sort ordena el array de fechas con el orden solicitado: Do Changed = False For Pointer = 1 To (Applica...
Leer más

BAT Windows ejecuta script PHP

En la publicación anterior , se presentó un código que me permite realizar backup desde dos bases de datos de motores diferentes, queda mostrar quien es el encargado de ejecutarlo. Lo podríamos hacer desde nuestro localhost, como servidor uso uniserver , pero por flojera prefiero que se ejecute cada vez que prendo el computados. Esto ultimo lo realizo con el inicio de Windows. ahora al punto que nos convoca. @echo off color 30 echo =================================================== echo = = echo = Transferencia de datos desde SQL Server ICPSAP = echo = = echo =================================================== echo. timeout 60 > NUL C:\UniServerZ\core\php54\php.exe "C:\UniServerZ\www\Panel\script.php" pause exit El código esta en BAT. Voy a explicar solo lo básico (o sea todo el código ya que es ultra básico) @echo off: Desactiva volvamiento de texto. color ...
Leer más