Abrir y Cerrar Procesos desde Excel

El siguiente código es útil cuando se nos hace necesario recurrir a aplicaciones externas para realizar ciertas tareas que no se podrían hacer directamente en Excel o que son complicadas hacerlas, por ejemplo, podríamos necesitar tomar fotos y agregarlas en una carpeta especifica para mostrarlas en nuestras hojas de Excel, entonces necesitaríamos hacer uso de una aplicación externa que tomara las fotos.

Para ejecutar aplicaciones y cerrarlas desde Excel necesitamos hacer uso de las apis de windows, específicamente CreateProcessA y TerminateProcess, por lo que es necesario agregar el siguiente código en un módulo.

Option Explicit
 
Private Type STARTUPINFO
 cb As Long
 lpReserved As String
 lpDesktop As String
 lpTitle As String
 dwX As Long
 dwY As Long
 dwXSize As Long
 dwYSize As Long
 dwXCountChars As Long
 dwYCountChars As Long
 dwFillAttribute As Long
 dwFlags As Long
 wShowWindow As Integer
 cbReserved2 As Integer
 lpReserved2 As Long
 hStdInput As Long
 hStdOutput As Long
 hStdError As Long
End Type
 
Private Type PROCESS_INFORMATION
 hProcess As Long
 hThread As Long
 dwProcessID As Long
 dwThreadID As Long
End Type
 
Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As Long, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Long, ByVal lpThreadAttributes As Long, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByVal lpEnvironment As Long, ByVal lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long

Private Const NORMAL_PRIORITY_CLASS = &H20&

Private hAplicacion As Long

Lo que hace este código es declarar los tipos de variables STARTUPINFO y PROCESS_INFORMATION que se utilizan para almacenar la información de las aplicaciones que se ejecutan, declarar las apis para poderlas usar en nuestros códigos, declarar la constante NORMAL_PRIORITY_CLASS que se utiliza como parámetro de la api CreateProcessA, y por ultimo declarar la variable hAplicacion donde se almacena el apuntador de la aplicación que se utilizara para poder cerrarla.

Teniendo ya el código anterior, podemos crear nuestros códigos para ejecutar las aplicaciones.

Sub ejecutar()
    'Se declaran las variables (todas son necesarias)
    Dim proc As PROCESS_INFORMATION
    Dim start As STARTUPINFO
    Dim ReturnValue As Integer

    If (hAplicacion = 0) Then
        ReturnValue = CreateProcessA(0&, "notepad.exe", 0&, 0&, 1&, NORMAL_PRIORITY_CLASS, 0&, 0&, start, proc)
        hAplicacion = proc.hProcess
    End If
End Sub

Por ultimo creamos el código para cerrar la aplicación.

Sub cerrar()
    'Se cierra la aplicación utilizando su apuntador
    TerminateProcess hAplicacion, 0
    hAplicacion = 0
End Sub

Una vez agregado los códigos podemos agregar botones que ejecuten esos códigos para que al hacer clic en un botón se ejecute la aplicación y al hacer clic en otro botón se cierre.

El código es bastante simple para que sea fácil de utilizar, su principal limitación es que solo funciona para una sola aplicación, pero se puede mejorar y adaptar dependiendo del uso que se le vaya a dar.

El ejemplo funcionando lo encuentran en el siguiente enlace https://1drv.ms/x/s!ACvMpSG8IKpngU4, espero les sea útil.

Anuncios

Galeria de Imagenes

Excel a pesar de que no es un software para presentaciones en ocasiones necesitamos mostrar imágenes; cuando tenemos espacio suficiente podemos agregar todas las imágenes que necesitemos sin problema pero si queremos ahorrar espacio podemos crear una galería tipo slider haciendo lo siguiente.

  1. En una hoja de Excel, insertar un rectángulo y quitarle el contorno, en este rectángulo se mostraran las imágenes.
    Redimensionar el rectángulo al tamaño que se desee.
    Renombrar el cuadro a “Imagen” (sin comillas), esto para que funcione el código, si se desea poner otro nombre se debe ajustar el código.
  2. Insertar un cheurón (véase imagen) a cada lado del rectángulo, estos servirán para desplazarse por las imágenes.
  3. Seleccionar una celda y ponerle el nombre de “Carpeta”, esto para que funcione el código, si se desea poner otro nombre se debe ajustar el código, en esta celda se colocara la ubicación de la imagen mostrada.
  4. Agregar un rectángulo pequeño al lado de la celda que seleccionamos, este servirá como botón para seleccionar la primera imagen.
  5. En un módulo agregamos los siguientes códigos.
    Apis para busqueda de archivos

    Private Declare Function FindFirstFile Lib "kernel32" Alias "FindFirstFileA" (ByVal lpFileName As String, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindNextFile Lib "kernel32" Alias "FindNextFileA" (ByVal hFindFile As Long, lpFindFileData As WIN32_FIND_DATA) As Long
    Private Declare Function FindClose Lib "kernel32" (ByVal hFindFile As Long) As Long
    Const MAX_PATH = 260
    Const MAXDWORD = &HFFFF
    Const INVALID_HANDLE_VALUE = -1
    Const FILE_ATTRIBUTE_ARCHIVE = &H20
    Const FILE_ATTRIBUTE_DIRECTORY = &H10
    Const FILE_ATTRIBUTE_HIDDEN = &H2
    Const FILE_ATTRIBUTE_NORMAL = &H80
    Const FILE_ATTRIBUTE_READONLY = &H1
    Const FILE_ATTRIBUTE_SYSTEM = &H4
    Const FILE_ATTRIBUTE_TEMPORARY = &H100
     
    Private Type FILETIME
        dwLowDateTime As Long
        dwHighDateTime As Long
    End Type
     
    Private Type WIN32_FIND_DATA
        dwFileAttributes As Long
        ftCreationTime As FILETIME
        ftLastAccessTime As FILETIME
        ftLastWriteTime As FILETIME
        nFileSizeHigh As Long
        nFileSizeLow As Long
        dwReserved0 As Long
        dwReserved1 As Long
        cFileName As String * MAX_PATH
        cAlternate As String * 14
    End Type
    
    Function StripNulls(OriginalStr As String) As String
        If (InStr(OriginalStr, Chr(0)) > 0) Then
            OriginalStr = Left(OriginalStr, InStr(OriginalStr, Chr(0)) - 1)
        End If
        StripNulls = OriginalStr
    End Function
    


    Código para los botónes

    Sub SeleccionarCarpeta()
        Application.EnableEvents = False
        Application.ScreenUpdating = False
        Dim strImagenNew As String
        Dim i As Integer
        Dim j As Integer
        strImagenNew = Application.GetOpenFilename("Archivos de imagen(*.bmp;*.gif;*.jpg;*.png), *.bmp;*.gif;*.jpg;*.png", , "Selecciona...")
        If strImagenNew <> "Falso" Then
            Sheets("Hoja1").Shapes("Imagen").Fill.UserPicture strImagenNew
            Sheets("Hoja1").Range("Carpeta") = strImagenNew
        Else
            Exit Sub
        End If
        Application.EnableEvents = True
    End Sub
    
    Sub toLeft()
        Dim imagen As String
        imagen = SiguienteImagen("previous")
        If imagen <> Empty Then
            Sheets("Hoja1").Shapes("Imagen").Fill.UserPicture imagen
            Sheets("Hoja1").Range("Carpeta") = imagen
        End If
    End Sub
    Sub toRight()
        Dim imagen As String
        imagen = SiguienteImagen("next")
        If imagen <> Empty Then
            Sheets("Hoja1").Shapes("Imagen").Fill.UserPicture imagen
            Sheets("Hoja1").Range("Carpeta") = imagen
        End If
    End Sub
    


    Código para obtener las imagenes (usando las Apis)

    Function SiguienteImagen(direccion As String)
        Dim carpeta As String
        Dim busqueda As String
        Dim archivo As String
        Dim archivoInicial As String
        Dim extension As String
        Dim i As Integer
        Dim resultado As Long
        Dim WFD As WIN32_FIND_DATA
        Dim actual As Boolean
        Dim previous As String
        Dim cont As Integer
        archivoInicial = Sheets("Hoja1").Range("Carpeta")
        carpeta = Mid(archivoInicial, 1, InStrRev(archivoInicial, "\"))
        busqueda = "*.*" 'Todos los archivos
        If Right(carpeta, 1) <> "\" Then carpeta = carpeta & "\"
        'Busqueda del archivo en carpeta actual
        resultado = FindFirstFile(carpeta & busqueda, WFD)
        cont = True
        actual = False
        If resultado <> INVALID_HANDLE_VALUE Then
            While cont And SiguienteImagen = Empty
                archivo = StripNulls(WFD.cFileName)
                If (archivo <> ".") And (archivo <> "..") Then
                    extension = Right(archivo, Len(archivo) - InStrRev(archivo, "."))
                    If extension = "bmp" Or extension = "gif" Or extension = "jpg" Or extension = "png" Then
                        If direccion = "next" Then
                            If actual Then SiguienteImagen = carpeta & archivo
                            If (carpeta & archivo) = archivoInicial Then actual = True
                        ElseIf direccion = "previous" Then
                            If (carpeta & archivo) = archivoInicial Then SiguienteImagen = previous
                            previous = carpeta & archivo
                        End If
                    End If
                End If
                cont = FindNextFile(resultado, WFD)
            Wend
            cont = FindClose(resultado)
        End If
    End Function
    


  6. Agregar el código “SeleccionarCarpeta” al botón que se agregó en el paso 6.
  7. Agregar el código “toLeft” al cheurón del lado izquierdo y “toRight” al cheurón del lado derecho.
  8. Hacer clic en el botón del paso 6 para seleccionar la primera imagen.
  9. Hacer clic en el cheurón derecho para ver la siguiente imagen.

Si te gusto el artículo no dudes en comentar y compartir.

Utilizar Paleta de Colores para Seleccionar Color

En algunos de los proyectos que realizamos en Excel nos resultara necesario que el usuario pueda elegir un color para realizar una determinada tarea, por ejemplo para que el usuario pueda elegir un color de fondo para un formato, en estos casos podemos hacer uso de la paleta de colores de Excel y mediante macros obtener el color que el usuario seleccione.
Para que el usuario pueda elegir un color primero debemos especificar que celdas servirán para capturar el color a esas celdas les podemos llamar “Celdas de Color”, y debemos tener una macro que nos indique si una celda es una “celda de color” o no para ello utilizamos la siguiente macro la cual debe colocarse en un módulo.

Function EsCeldaColor(Celda As Range) As Boolean
    Dim CeldasColor As Variant
    Dim i As Integer
    Dim Resultado As Boolean
    'Las celdas de color se pueden especificar todas juntas, pero cuando son de diferentes hojas se deben separar para que no ocurran errores
    CeldasColor = Array(Range("Hoja1!C2:C3,C4"), Range("Hoja2!C2"))
    For i = LBound(CeldasColor) To UBound(CeldasColor)
        If CeldasColor(i).Parent.Name = Celda.Parent.Name Then
            If Not Application.Intersect(CeldasColor(i), Celda) Is Nothing Then
                Resultado = True
            End If
        End If
    Next
    EsCeldaColor = Resultado
End Function

Cuando una celda es una “celda de color” y el usuario seleccione dicha celda se debe mostrar la paleta de colores y para que eso ocurra necesitamos la siguiente macro que muestra la paleta de colores y guarda el color en la “celda de color”, esta macro se debe colocar en modulo

Sub SeleccionarColor(Celda As Range)
    On Error Resume Next
    Dim lngResult As Long, lngO As Long, intR As Integer, intG As Integer, intB As Integer
    lngO = ThisWorkbook.Colors(1)
    Err.Clear
    lngInitialColor = CLng(Celda)
    If Err.Description = "" Then
        intR = lngInitialColor And 255
        intG = lngInitialColor \ 256 And 255
        intB = lngInitialColor \ 256 ^ 2 And 255
    End If
    If Application.Dialogs(xlDialogEditColor).Show(1, intR, intG, intB) = True Then
        lngResult = ThisWorkbook.Colors(1)
        Celda = lngResult
    End If
    ThisWorkbook.Colors(1) = lngO
End Sub

Y también necesitamos la siguiente macro que es la que detecta cuando el usuario selecciona una celda y decide si se muestra la paleta de colores o no, esta macro se debe colocar en el objeto “ThisWorkbook”

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
    If EsCeldaColor(Target) Then
        SeleccionarColor Target
    End If
End Sub

Y con esto cada vez que el usuario seleccione una celda esta última macro comprobara (con la primera macro) que la celda es una celda de color y mostrara la paleta de colores (con la segunda macro).

Y el resultado es el siguiente

Sumar Celdas del Mismo Color

Cuando trabajamos con Excel la mayoría las veces necesitamos Sumar celdas que están separadas y para poder sumarlas es necesario ir agregándolas a la formula SUMA una por una lo cual cuando son demasiadas celdas llega a ser fastidioso y más si nos equivocamos y las celdas que habíamos agregado se quitan de la formula.
Mediante una UDF (función definida por el usuario) es posible facilitar esa tarea para solamente sumar las celdas que tienen el mismo color, es decir, de una sola vez se agregarían todas las celdas a la función y la propia función se encargaría de sumar solamente las celdas que tengan el mismo color.
La función a utilizar es la siguiente

Public Function SumaPorColor(Color As Range, ParamArray Valores() As Variant) As Double
    On Error Resume Next
    Application.Calculation = xlCalculationManual
    Dim celda As Range
    Dim rango As Variant
    For Each rango In Valores
        For Each celda In rango
            If celda.Interior.ColorIndex = Color.Cells(1, 1).Interior.ColorIndex Then
                If IsNumeric(celda) Then
                    SumaPorColor = SumaPorColor + celda
                End If
            End If
        Next celda
    Next rango
    Set celda = Nothing
    Set rango = Nothing
    Application.Calculation = xlCalculationAutomatic
End Function


La función se debe agregar a un módulo y se utiliza de la siguiente manera.
El primer rango que se le pasa como parámetro debe ser la celda que tiene el color, los demás rangos que se le pasan son los que se van a sumar, los rangos pueden estar en diferentes hojas como en la imagen de abajo y solamente las celdas que tengan el mismo color que el primer rango se sumaran, en la imagen de abajo solamente se suman las celdas de color azul (2+4+6+7+2=21).

Obtener datos de página web (Convertidor de Divisas)

En VBA es muy fácil hacer una consulta a una página web, lo complicado es procesar la respuesta pues por lo general es un código HTML, aunque también puede estar en formato json y en ese caso podemos utilizar el código de Cómo Utilizar JSON en Macros VBA.
Para hacer una consulta a una página web se utiliza la siguiente función

Function DatosWeb(url As String) As String
    On Error Resume Next
    Dim xml As Object
    Dim result As String
    Set xml = CreateObject("MSXML2.ServerXMLHTTP")
    xml.Open "GET", _
        url
    xml.Send
    ConsultarPagina = xml.responsetext
End Function


Y utilizamos la función de la siguiente forma para hacer una consulta a la página de Gmail

Sub ejemplo()
    Dim codigoPagina As String
    codigoPagina = DatosWeb("https://www.gmail.com/intl/es/mail/help/about.html")
    MsgBox codigoPagina
End Sub


Y el resultado sería similar a la siguiente imagen


El texto que vemos es el mismo que vemos en el navegador como código fuente de la página

Un vez que tenemos la respuesta (que es el código fuente de la página) podemos obtener información de ella utilizando funciones de texto.

Cuando la respuesta está en formato json es mas facil de manejar.
Si queremos obtener el valor del USD en pesos mexicanos hacemos una consulta a una página web y obtenemos el código fuente que es un json.


Podemos utilizar el json como en el siguiente código (Para que el código funcione se debe crear la clase json y la función parseJson como se indica en Cómo Utilizar JSON en Macros VBA)

Sub ejemplo2()
    Dim strJson As String
    Dim objJson As Object
    strJson = DatosWeb("http://devel.farebookings.com/api/curconversor/USD/MXN/1/json") 'Nos devuelve el valor del dolar americano es pesos mexicanos
    Set objJson = parseJSON(strJson)
    If Not objJson Is Nothing Then
        MsgBox "1 USD = " & objJson.Item("MXN") & " MXN"
    End If
End Sub


Y el resultado es el siguiente

Como Utilizar JSON en Macros VBA

Cuando utilizamos macros normalmente es para hacer tareas más complejas como accesar a bases de datos, utilizar tablas dinámicas, crear contenido dinámico, utilizar webservices, obtener datos directamente de la web, etc. En esto último no es una tarea tan fácil de manejar en VBA ya que cuando hacemos una consulta en la web muy pocas veces la respuesta es directa si no que la mayoría de las veces son textos JSON y en VBA no existe una función que nos permita utilizar JSON.
Para poder utilizar textos JSON en VBA podemos hacer uso de librerías (clases), una forma de usar JSON es la siguiente.

  1. Crear una clase de preferencia llamada “json” y agregarle el siguiente código que encontré aquí, este código es el que se encarga de convertir el texto JSON en un objeto Dictionary

    Option Explicit
    
    Const INVALID_JSON      As Long = 1
    Const INVALID_OBJECT    As Long = 2
    Const INVALID_ARRAY     As Long = 3
    Const INVALID_BOOLEAN   As Long = 4
    Const INVALID_NULL      As Long = 5
    Const INVALID_KEY       As Long = 6
    
    Private Sub Class_Initialize()
    
    End Sub
    
    Private Sub Class_Terminate()
    
    End Sub
    
    '
    '   parse string and create JSON object (Dictionary or Collection in VB)
    '
    Public Function parse(ByRef str As String) As Object
    
        Dim index As Long
        index = 1
        
        On Error Resume Next
    
        Call skipChar(str, index)
        Select Case Mid(str, index, 1)
        Case "{"
            Set parse = parseObject(str, index)
        Case "["
            Set parse = parseArray(str, index)
        End Select
    
    End Function
    
    '
    '   parse collection of key/value (Dictionary in VB)
    '
    Private Function parseObject(ByRef str As String, ByRef index As Long) As Object
    
        Set parseObject = CreateObject("Scripting.Dictionary")
        
        ' "{"
        Call skipChar(str, index)
        If Mid(str, index, 1) <> "{" Then Err.Raise vbObjectError + INVALID_OBJECT, Description:="char " & index & " : " & Mid(str, index)
        index = index + 1
        
        Do
        
            Call skipChar(str, index)
            If "}" = Mid(str, index, 1) Then
                index = index + 1
                Exit Do
            ElseIf "," = Mid(str, index, 1) Then
                index = index + 1
                Call skipChar(str, index)
            End If
            
            Dim key As String
            
            ' add key/value pair
            parseObject.Add key:=parseKey(str, index), Item:=parseValue(str, index)
            
        Loop
    
    End Function
    
    '
    '   parse list (Collection in VB)
    '
    Private Function parseArray(ByRef str As String, ByRef index As Long) As Collection
    
        Set parseArray = New Collection
        
        ' "["
        Call skipChar(str, index)
        If Mid(str, index, 1) <> "[" Then Err.Raise vbObjectError + INVALID_ARRAY, Description:="char " & index & " : " + Mid(str, index)
        index = index + 1
        
        Do
            
            Call skipChar(str, index)
            If "]" = Mid(str, index, 1) Then
                index = index + 1
                Exit Do
            ElseIf "," = Mid(str, index, 1) Then
                index = index + 1
                Call skipChar(str, index)
            End If
            
            ' add value
            parseArray.Add parseValue(str, index)
            
        Loop
    
    End Function
    
    '
    '   parse string / number / object / array / true / false / null
    '
    Private Function parseValue(ByRef str As String, ByRef index As Long)
    
        Call skipChar(str, index)
        
        Select Case Mid(str, index, 1)
        Case "{"
            Set parseValue = parseObject(str, index)
        Case "["
            Set parseValue = parseArray(str, index)
        Case """", "'"
            parseValue = parseString(str, index)
        Case "t", "f"
            parseValue = parseBoolean(str, index)
        Case "n"
            parseValue = parseNull(str, index)
        Case Else
            parseValue = parseNumber(str, index)
        End Select
    
    End Function
    
    '
    '   parse string
    '
    Private Function parseString(ByRef str As String, ByRef index As Long) As String
    
        Dim quote   As String
        Dim char    As String
        Dim code    As String
        
        Call skipChar(str, index)
        quote = Mid(str, index, 1)
        index = index + 1
        Do While index > 0 And index <= Len(str)
            char = Mid(str, index, 1)
            Select Case (char)
            Case "\"
                index = index + 1
                char = Mid(str, index, 1)
                Select Case (char)
                Case """", "\\", "/"
                    parseString = parseString & char
                    index = index + 1
                Case "b"
                    parseString = parseString & vbBack
                    index = index + 1
                Case "f"
                    parseString = parseString & vbFormFeed
                    index = index + 1
                Case "n"
                    parseString = parseString & vbNewLine
                    index = index + 1
                Case "r"
                    parseString = parseString & vbCr
                    index = index + 1
                Case "t"
                    parseString = parseString & vbTab
                    index = index + 1
                Case "u"
                    index = index + 1
                    code = Mid(str, index, 4)
                    parseString = parseString & ChrW(val("&h" + code))
                    index = index + 4
                End Select
            Case quote
                index = index + 1
                Exit Function
            Case Else
                parseString = parseString & char
                index = index + 1
            End Select
        Loop
    
    End Function
    
    '
    '   parse number
    '
    Private Function parseNumber(ByRef str As String, ByRef index As Long)
    
        Dim value   As String
        Dim char    As String
        
        Call skipChar(str, index)
        Do While index > 0 And index <= Len(str)
            char = Mid(str, index, 1)
            If InStr("+-0123456789.eE", char) Then
                value = value & char
                index = index + 1
            Else
                If InStr(value, ".") Or InStr(value, "e") Or InStr(value, "E") Then
                    parseNumber = CDbl(value)
                Else
                    parseNumber = CInt(value)
                End If
                Exit Function
            End If
        Loop
    
    
    End Function
    
    '
    '   parse true / false
    '
    Private Function parseBoolean(ByRef str As String, ByRef index As Long) As Boolean
    
        Call skipChar(str, index)
        If Mid(str, index, 4) = "true" Then
            parseBoolean = True
            index = index + 4
        ElseIf Mid(str, index, 5) = "false" Then
            parseBoolean = False
            index = index + 5
        Else
            Err.Raise vbObjectError + INVALID_BOOLEAN, Description:="char " & index & " : " & Mid(str, index)
        End If
    
    End Function
    
    '
    '   parse null
    '
    Private Function parseNull(ByRef str As String, ByRef index As Long)
    
        Call skipChar(str, index)
        If Mid(str, index, 4) = "null" Then
            parseNull = Null
            index = index + 4
        Else
            Err.Raise vbObjectError + INVALID_NULL, Description:="char " & index & " : " & Mid(str, index)
        End If
    
    End Function
    
    Private Function parseKey(ByRef str As String, ByRef index As Long) As String
    
        Dim dquote  As Boolean
        Dim squote  As Boolean
        Dim char    As String
        
        Call skipChar(str, index)
        Do While index > 0 And index <= Len(str)
            char = Mid(str, index, 1)
            Select Case (char)
            Case """"
                dquote = Not dquote
                index = index + 1
                If Not dquote Then
                    Call skipChar(str, index)
                    If Mid(str, index, 1) <> ":" Then
                        Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                    End If
                End If
            Case "'"
                squote = Not squote
                index = index + 1
                If Not squote Then
                    Call skipChar(str, index)
                    If Mid(str, index, 1) <> ":" Then
                        Err.Raise vbObjectError + INVALID_KEY, Description:="char " & index & " : " & parseKey
                    End If
                End If
            Case ":"
                If Not dquote And Not squote Then
                    index = index + 1
                    Exit Do
                End If
            Case Else
                If InStr(vbCrLf & vbCr & vbLf & vbTab & " ", char) Then
                Else
                    parseKey = parseKey & char
                End If
                index = index + 1
            End Select
        Loop
    
    End Function
    
    '
    '   skip special character
    '
    Private Sub skipChar(ByRef str As String, ByRef index As Long)
    
        While index > 0 And index <= Len(str) And InStr(vbCrLf & vbCr & vbLf & vbTab & " ", Mid(str, index, 1))
            index = index + 1
        Wend
    
    End Sub
    
    Public Function toString(ByRef obj As Variant) As String
    
        Select Case VarType(obj)
            Case vbNull
                toString = "null"
            Case vbDate
                toString = """" & CStr(obj) & """"
            Case vbString
                toString = """" & encode(obj) & """"
            Case vbObject
                Dim bFI, i
                bFI = True
                If TypeName(obj) = "Dictionary" Then
                    toString = toString & "{"
                    Dim keys
                    keys = obj.keys
                    For i = 0 To obj.Count - 1
                        If bFI Then bFI = False Else toString = toString & ","
                        Dim key
                        key = keys(i)
                        toString = toString & """" & key & """:" & toString(obj(key))
                    Next i
                    toString = toString & "}"
                ElseIf TypeName(obj) = "Collection" Then
                    toString = toString & "["
                    Dim value
                    For Each value In obj
                        If bFI Then bFI = False Else toString = toString & ","
                        toString = toString & toString(value)
                    Next value
                    toString = toString & "]"
                End If
            Case vbBoolean
                If obj Then toString = "true" Else toString = "false"
            Case vbVariant, vbArray, vbArray + vbVariant
                Dim sEB
                toString = multiArray(obj, 1, "", sEB)
            Case Else
                toString = Replace(obj, ",", ".")
        End Select
    
    End Function
    
    Private Function encode(str) As String
        
        Dim i, j, aL1, aL2, c, p
    
        aL1 = Array(&H22, &H5C, &H2F, &H8, &HC, &HA, &HD, &H9)
        aL2 = Array(&H22, &H5C, &H2F, &H62, &H66, &H6E, &H72, &H74)
        For i = 1 To Len(str)
            p = True
            c = Mid(str, i, 1)
            For j = 0 To 7
                If c = Chr(aL1(j)) Then
                    encode = encode & "\" & Chr(aL2(j))
                    p = False
                    Exit For
                End If
            Next
    
            If p Then
                Dim a
                a = AscW(c)
                If a > 31 And a < 127 Then
                    encode = encode & c
                ElseIf a > -1 Or a < 65535 Then
                    encode = encode & "\u" & String(4 - Len(Hex(a)), "0") & Hex(a)
                End If
            End If
        Next
    End Function
    
    Private Function multiArray(aBD, iBC, sPS, ByRef sPT)   ' Array BoDy, Integer BaseCount, String PoSition
        Dim iDU, iDL, i ' Integer DimensionUBound, Integer DimensionLBound
        On Error Resume Next
        iDL = LBound(aBD, iBC)
        iDU = UBound(aBD, iBC)
        
        Dim sPB1, sPB2  ' String PointBuffer1, String PointBuffer2
        If Err.Number = 9 Then
            sPB1 = sPT & sPS
            For i = 1 To Len(sPB1)
                If i <> 1 Then sPB2 = sPB2 & ","
                sPB2 = sPB2 & Mid(sPB1, i, 1)
            Next
    '        multiArray = multiArray & toString(Eval("aBD(" & sPB2 & ")"))
            multiArray = multiArray & toString(aBD(sPB2))
        Else
            sPT = sPT & sPS
            multiArray = multiArray & "["
            For i = iDL To iDU
                multiArray = multiArray & multiArray(aBD, iBC + 1, i, sPT)
                If i < iDU Then multiArray = multiArray & ","
            Next
            multiArray = multiArray & "]"
            sPT = Left(sPT, iBC - 2)
        End If
        Err.Clear
    End Function
    

  2. Crear un módulo y agregar la siguiente función para no estar declarando la clase cada vez que le necesitemos y así solamente llamaremos directamente a la función

    Function parseJSON(strJson As String) As Object
        Dim clsJson As json
        Set clsJson = New json
        Set parseJSON = clsJson.parse(strJson)
    End Function
    

  3. Usar la función de la siguiente forma

    Sub PruebaJson()
        Dim strJson As String
        Dim objJson As Object
        strJson = "{""response"": {""id"": ""1"",""value"": ""Código Excel""}}"
        Set objJson = parseJSON(strJson)
        If Not objJson Is Nothing Then
            MsgBox "Mi Blog es " & objJson.Item("response").Item("value")
        End If
    End Sub
    


    Como se puede observar el texto JSON de ejemplo tiene dos comillas dobles esto es porque en VBA para poner comillas en un texto se colocan dos veces, pero si el texto JSON lo obtenemos de la web o de algún archivo solamente debe tener una comilla doble y no dos.
    El texto JSON del ejemplo es el siguiente

    {"response": {
    "id": "1",
    "value": "Código Excel",
    }}

    Si queremos obtener el elemento “value” necesitamos pasar por todos los elementos superiores hasta llegar a “value”, en esta caso solamente hay un elemento superior llamado “response” y por eso se utiliza
    objJson.Item(“response”).Item(“value”) que nos da como resultado Código Excel

Obtener la Edad con la Fecha de Nacimiento

Cuando trabajamos con fechas los cálculos se pueden hacer muy complejas, no porque se requiera mucho trabajo si no porque resulta confuso.
Uno de los cálculos más comunes con las fechas es obtener la cantidad de años que hay entre dos fechas que normalmente es para obtener la edad de una persona.
La tarea parece sencilla pero puede ser algo confuso desarrollarla y seguramente en nuestro intento obtendremos resultados incorrectos las primeras veces pero con varias pruebas obtendremos la función correcta.
La función que yo utilizo para calcular la edad de una persona es la siguiente

Function getEdad(fechaNacimiento As Date)
    Dim año, mes, dia As Integer
    Dim dAño, dMes, dDia As Integer
    año = Format(fechaNacimiento, "yyyy")
    mes = Format(fechaNacimiento, "m")
    dia = Format(fechaNacimiento, "d")
    dAño = Format(Date, "yyyy") - año
    dMes = Format(Date, "mm") - mes
    dDia = Format(Date, "d") - dia
    If dMes < 0 Or (dMes = 0 And dDia < 0) Then
        dAño = dAño - 1
    End If
    getEdad = dAño
End Function

Es una función pequeña pero la clave esta en la sentencia IF que es cuando se verifica si se cuenta el año actual o no.

Para usar la función se debe colocar en un módulo y se llama de la siguiente forma

Dim edad as Integer
edad=getEdad("1990-06-25")
MsgBox "La edad es " & edad & " años"