Palabras clave: Excel, rango, copia, outlook, correo
Autor: Ron De Bruin
Extraído de: Ron De Bruin

La necesidad surge de pegar el contenido de un rango de un fichero Excel abierto como parte del cuerpo de un correo electrónico.

Después de muchas vueltas y pruebas este código de Ron De Bruin soluciona el problema

Requiere una copia previa del rango o pasarle la dirección para que lo haga la función.



Function rngHTML(Rng As Object) ' Range
    Dim fso         As Object
    Dim ts          As Object
    Dim TempWB      As Object    ' Workbook
    Dim TempFile    As String
   
    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
   
    '' copy the range and create a new workbook to paste the data into
    'Rng.Copy
   
   
    Set TempWB = xlsApp.Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        .Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With

    '' publish the sheet to a htm file
    With TempWB.PublishObjects.Add( _
             SourceType:=xlSourceRange, _
             fileName:=TempFile, _
             Sheet:=TempWB.Sheets(1).Name, _
            Source:=TempWB.Sheets(1).UsedRange.Address, _
            HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With

    '' read all data from the htm file into rngHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    rngHTML = ts.readall
    ts.Close
    rngHTML = Replace(rngHTML, "align=center x:publishsource=", "align=left x:publishsource=")

    TempWB.Close savechanges:=False
    '' delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function


Palabras clave: color, paleta, API, CHOOSECOLOR
Autor: ni me acuerdo
Extraído de: No sabria decir

Objetivo:
Abrir la paleta de colores para realizar una selección

En un módulo independiente:

Option Compare Database
Option Explicit

' Declaraciones (para aDialogColor)
#If Win64 Then
    Private Declare PtrSafe Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#Else
    Private Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As COLORSTRUC) As Long
#End If

' Estructura (para aDialogColor)
Private Type COLORSTRUC
  lStructSize       As Long
  hWnd              As Long
  hInstance         As Long
  rgbResult         As Long
  lpCustColors      As String
  Flags             As Long
  lCustData         As Long
  lpfnHook          As Long
  lpTemplateName    As String
End Type

' Estructura de devolución de valor
Public Type udtSysDialogColor
    IsSelected      As Boolean
    PreSelected     As Variant
    SelectedColor   As Long
End Type
Public uSysDialogColor  As udtSysDialogColor

' Constantes (para aDialogColor)
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_RGBINIT = &H1

Public Function aDialogColor()
   
    Dim x As Long, CS As COLORSTRUC, CustColor(16) As Long
   
    CS.lStructSize = Len(CS)
   
    CS.hWnd = Application.hWndAccessApp
   
    CS.Flags = CC_SOLIDCOLOR Or CC_RGBINIT
    CS.lpCustColors = String$(16 * 4, 0)
   
    ' Were we passed a value in PreselectedColor
    If Not IsMissing(uSysDialogColor.PreSelected) Then
        CS.rgbResult = uSysDialogColor.PreSelected
    End If
   
    x = CHOOSECOLOR(CS)
    If x = 0 Then
        ' ERROR - return preselected Color
        uSysDialogColor.IsSelected = False
        Exit Function
    Else
        ' Normal processing
        uSysDialogColor.SelectedColor = CS.rgbResult
        uSysDialogColor.IsSelected = True
    End If
 
End Function


Palabras clave: configuración, resolución, TWIPS, API, GetSystemMetrics
Autor: Jacob Hilderbrand
Extraído de: VBA Express

Objetivo:
Determinar la resolución de la pantalla y proponer cambio.

En un módulo independiente:

Option Explicit

Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

Sub VerifyScreenResolution(Optional Dummy As Integer)
     
    Dim x  As Long
    Dim y  As Long
    Dim MyMessage As String
    Dim MyResponse As VbMsgBoxResult
     
    x = GetSystemMetrics(SM_CXSCREEN)
    y = GetSystemMetrics(SM_CYSCREEN)
    If x = 1024 And y = 768 Then
    Else
        MyMessage = "Your current screen resolution is " & x & " X " & y & vbCrLf & "This program " & _
        "was designed to run with a screen resolution of 1024 X 768 and may not function properly " & _
        "with your current settings." & vbCrLf & "Would you like to change your screen resolution?"
        MyResponse = MsgBox(MyMessage, vbExclamation + vbYesNo, "Screen Resolution")
    End If
    If MyResponse = vbYes Then
        Call Shell("rundll32.exe shell32.dll,Control_RunDLL desk.cpl,,3")
    End If
End Sub


Palabras clave: Excel, hoja, nombre, formula
Autor: Argenis
Extraído de: Grupo de Whatsapp PowerBI Barcelona


Jordi Bosch, en el grupo de WhatsApp de PowerBI Barcelona lanza esta pregunta:

¿Por casualidad, alguno sabe cómo aplicar una fórmula en Excel para obtener el nombre de la pestaña en la misma pestaña sin referencias circulares ni VBA? Gracias 

Respuesta de Argenis

=EXTRAE(CELDA("nombrearchivo");ENCONTRAR("]";CELDA("nombrearchivo"))+1;31)

No hace falta decir nada más.

Palabras clave: configuración, regional, API, SetLocaleInfo
Autor: Cecilia Colalongo
Extraído de: La Web del programador

Objetivo:
Cambiar la configuración regional de la máquina. En este ejemplo, el formato de fecha y los separadores decimales y de miles.

En un módulo independiente:

Option Compare Database
Option Explicit

#If Win64 Then
    Public Declare PtrSafe Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare PtrSafe Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
#Else
    Public Declare Function GetSystemDefaultLCID Lib "kernel32" () As Long
    Public Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long
#End If
Public Const LOCALE_SSHORTDATE = &H1F
Public Const LOCALE_SDECIMAL = &HE
Public Const LOCALE_STHOUSAND = &HF

Function testCambioConfReg()
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_SSHORTDATE, "dd/MM/yyyy"
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_SDECIMAL, "."
    SetLocaleInfo GetSystemDefaultLCID, LOCALE_STHOUSAND, ","
End Function


Palabras clave: array vacío
Autor: Rubén Vigón

Objetivo
Saber si un Array tiene elementos o no.
En ocasiones tenemos un array no inicializado (o borrado su contenido con Erase) y queremos evaluar ese estado. Rubén Vigón nos ofreció esta respuesta allá por el 2005



Dim matriz() As Variant
If Not Not matriz Then
  Debug.Print "Inicializada"
Else
  Debug.Print "No inicializada"
End If

Palabras clave: contar, lineas, fichero, texto
Autor: no lo recuerdo

Objetivo
Obtener la cantidad de líneas que contiene un fichero de texto


Function DameLineasFichero(ByVal strRuta As String) As Long
    Dim f As Integer
    Dim strTexto As String
    Dim arrLineas() As String
   
    f = FreeFile
    Open strRuta For Input As #f
    strTexto = Input(LOF(f), #f)
    Close #f
    arrLineas = Split(strTexto, vbNewLine)
    DameLineasFichero = UBound(arrLineas) - LBound(arrLineas) + 1
    Erase arrLineas
End Function


Palabras clave: Cadena, repetir, contar
Autor: David M.M. y Eva Etxebeste

Objetivo
Rafa pregunta:

Citar¿Recordáis si hay alguna función de VBA que me cuente las coincidencias de un carácter en una cadena de texto?

"Hola grupito". Si busco la o que me retorne 2.

Responde Mihura
Mira... una del ternero


Function RT_NumRepeticionesCaracter(ByVal Cadena As Variant, ByVal Caracter As Variant) As Long   'V0
' El valor que devolverá la función será el número de partes en que la función Split ha separado
' la cadena original con el caracter introducido menos uno. Primera función de David M.M.
    Dim Matriz_Split() As String
    RT_NumRepeticionesCaracter = 0
    If Nz(Cadena, "") = "" Then Exit Function
    Matriz_Split() = Split(Cadena, Nz(Caracter, ""))
    RT_NumRepeticionesCaracter = UBound(Matriz_Split)
End Function


A lo que Eva Etxebeste replica...
En una línea


Len(cadena) - Len(Replace(cadena, charBusqueda, ""))


Palabras clave: convertir, fecha, formato
Autor: xavi

---

Necesidad
Convertir en fecha una cadena de texto que puede venir en distintos formatos (ddmmyy o yyyymmdd, por ejemplo)


Function fntConvierteFecha(strFecha As String, strFormato As String) As Date

    Dim iniAño                      As Integer
    Dim iniMes                      As Integer
    Dim iniDia                      As Integer
   
    Dim lenAño                      As Integer
    Const lenMes                    As Integer = 2
    Const lenDia                    As Integer = 2
   
    ' Función que toma cualquier formato que se pase como argumento para devolver una gfecha
    ' El separador no tiene porqué coincidir con elde la fecha; bastará con cualquier caracter, incluso un espacio.
   ' Ejemplo:  fntConvierteFecha("22-25-12", "yy dd mm") devuelve el dia de navidad del 2022
   
    ' Solo podemos admitir formatos que contengan "dd", "mm" y "yy" (por lo menos 2 'y')
    ' Empezamos por "dd"
    If InStr(1, strFormato, "dd") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
    ' Seguimos por "mm"
    If InStr(1, strFormato, "mm") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
    ' Acabamos por "yy"
    ' venga como yy o como yyyy, por lo menos yy debe existir
    If InStr(1, strFormato, "yy") = 0 Then
        MsgBox "El formato pasado como argumento no es admisible.", vbExclamation, "Error"
        fntConvierteFecha = Empty
        Exit Function
    End If
   
   ' En este punto ya podemos tratar cualquier cosa
    iniAño = InStr(1, strFormato, "y")
    iniMes = InStr(1, strFormato, "m")
    iniDia = InStr(1, strFormato, "d")
   
    lenAño = IIf(InStr(1, strFormato, "yyyy") > 0, 4, 2)
   
    fntConvierteFecha = DateSerial(Mid(strFecha, iniAño, lenAño), Mid(strFecha, iniMes, lenMes), Mid(strFecha, iniDia, lenDia))

End Function


Palabras clave: librerías, bibliotecas, referencias, Object
Autor: xavi
Extraído de: experiencia propia

Partiendo de este hilo, y a raíz de los hechos del 27/07/2022, actualizo este post con una nueva versión.

Si bien se han publicado diferentes ejemplos sobre la forma de gestionar las referencias de nuestras aplicaciones, yo nunca he con seguido que funcionen. Para mí es complicado entender que, si un código no se ejecuta por referencias, el propio código *que no puede ejecutarse* lo pueda corregir. Así que presento la solución que yo he aplicado.

En mis aplicaciones es muy usual que se interactúe con Excel por lo que, durante el desarrollo, es mucho más cómodo tener marcada la referencia de Excel para tener a mano los comandos con el IntelliSense  y las constantes.
El problema es la disparidad de versiones que Office que conviven y que los chicos de Microsoft han resuelto bastante bien la "subida" de referencias, pero en absoluto la "bajada".

Tabla de versiones
2007	12.0
2010	14.0
2013	15.0
2016	16.0

En los siguientes escenarios se marca la referencia en desarrollo y no se desmarca al enviar la aplicación al cliente.

Escenario 1
Desarrollamos en Office 2013
Cliente dispone de Office 2013 o 2016

Al enviar nuestra aplicación al cliente, aquellos PC's con Office 2013 mantendrán la versión 15.0 de la librería; los que tuvieran 2016, "subirían" a 16.0

Escenario 2
Desarrollamos en Office 2016
Cliente dispone de Office 2013 o inferiores

Al enviar la aplicación al cliente, todos los PC's mantendrán la versión 16.0 y, como ninguno de ellos la tiene instalada, obtendremos un error y no podremos ejecutar la aplicación.

Caso especial
Aplicaciones desarrolladas en versiones antiguas (97, 2000) que tienen referencias a otras aplicaciones Office de esas versiones (8.0, 9.0) no son capaces de "subir" la versión cuando se ejecutan en, por ejemplo, una versión 2010.

Así pues, podemos tener un problema entre la comodidad de programar con las referencias y la distribución de las aplicaciones.

Dado que tener todas las versiones de las librerías de Office se antoja complicado, la solución pasa por entregar la aplicación sin las referencias de Office. Para cambiar a trabajar sin referencias es necesario cambiar nuestra táctica de declaración. Lo que hasta ahora declarábamos como Excel.Application habrá que declararlo como Object. Ello nos privará del IntelliSense y del acceso a las constantes específicas de la aplicación Office que queramos utilizar.

¿Como solucionamos eso? Expongo mi técnica.

La técnica se basa en la utilización de directivas a nivel de compilador que, en función del valor, toman un camino u otro.

Imaginemos que queremos utilizar 2 constantes a nivel de directiva para definir si utilizamos las librerías de Excel y Outlook.


' Constante de utilización de librerías de Office
#Const UseOL_XLS = True
#Const UseOL_OLK = False


Como ha descubierto Tonny Sanjiao, el alcance de las constantes de compilación condicional es únicamente en el módulo dónde se declaran. Cuando se intenta acceder a cualquiera de ellas desde otro módulo, el valor obtenido es False. Nuestro gozo en un pozo. Una solución es replicar esa asignación de constantes en cada módulo dónde fuera necesario, pero estamos de acuerdo en que no es práctico.

Gracias a Javier Mendiburu hemos descubierto un artículo dónde se mencionaba justamente eso y se apuntaba una alternativa para definir constantes de compilación condicional utilizando la ventana de propiedades del proyecto que encontramos en el editor de VBA, Herramientas, propiedades. Ahí encontraremos un cuadro de texto dónde, separado por : podremos colocar los distintos valores de contantes de compilación condicional.

Así que nos olvidaríamos del código anterior y podríamos ir a esa ventana para definir las constantes:

UseOL_XLS = 1 : UseOL_OLK = 0

Primero observamos que no acepta valores True/False y que estos deben convertirse a enteros. Eso ya nos da una pista de que tampoco admitirá valores alfanuméricos (cosa que si admiten las declaraciones #Const dentro de VBA)

También nos obliga a que, cada vez que cambiamos un valor de esas condiciones, ir a esa pantalla y modificar ese valor.

Ahora que tenemos definidas las constantes en la ventana de propiedades las podemos utilizar para crear directivas #If

En este caso vamos a utilizar una variable Public para decidir qué tipo será la variable xlsApp en función de la constante condicional.
Nota: en mis aplicaciones acostumbro a utilizar un solo fichero de Excel cada vez por lo que no es necesario ir dimensionando en cada utilización.

#If UseOL_XLS Then
  Public xlsApp As Excel.Application
#Else
  Public xlsApp As Object
#End If


Este trocito de código dice que, si la constante condicional está establecida a true (<>0) significa que se utiliza la librería de Excel (ergo está referenciada) y cualquier instancia de xlsApp se declarará como Excel.Application. Si, por contra, la constante es False, se declara como Object. Se entiende, ¿no?

Si necesitara declarar otra instancia de Excel, utilizaría la misma técnica, pero dentro del procedimiento:



#If UseOL_XLS Then
  Dim xlsAppOtro As Excel.Application
#Else
  Dim xlsAppOtro As Object
#End If



Si durante la fase de desarrollo necesito acceder a las propiedades, métodos y constantes de Excel, simplemente marco la referencia y cambio la propiedad del proyecto de forma que puedo acceder a la librería.

¿Y las constantes específicas de la otra aplicación?
Pues para las constantes hay que ir manteniendo una lista en la zona #Else de manera que, cuando no tengamos marcada la librería, siga funcionando.

Ejemplos de constantes:

   
    Public Const xlVeryHidden = 2
    Public Const xlPrintNoComments = -4142
    Public Const xlLandscape = 2
    Public Const xlAutomatic = -4105
    Public Const xlDownThenOver = 1
    Public Const xlPrintErrorsDisplayed = 0
    Public Const xlDown = -4121
    Public Const xlUp = -4162
    Public Const xlLeft = -4159
    Public Const xlRight = -4161
    Public Const xlCenter = -4108
    Public Const xlBottom = -4107
    Public Const xlToLeft = -4159
    Public Const xlToRight = -4161
    Public Const xlEdgeLeft = 7
    Public Const xlEdgeTop = 8
    Public Const xlEdgeBottom = 9
    Public Const xlEdgeRight = 10
    Public Const xlInsideVertical = 11
    Public Const xlInsideHorizontal = 12
    Public Const xlContinuous = 1
    Public Const xlColorIndexAutomatic = -4105
    Public Const xlHairline = 1
    Public Const xlMedium = -4138
    Public Const xlThick = 4
    Public Const xlThin = 2
   

La precaución que debemos tener a la hora de programar es la de añadir cualquier nueva constante que utilicemos.


Pero ya sabéis que esto no puede quedar aquí y estaría bien que en alguna parte del código pudiéramos definir nuestras constantes y estas se salvaran en la hoja de propiedades.

Para ello tendremos las constantes declaradas de forma "normal". En este caso simplemente las llamaré como antes quitando la palabra Use

' Constante de utilización de librerías de Office
Const OL_XLS = True
Const OL_OLK = False


Cuando voy a desarrollar y necesito ambas librerías
- Marco las 2 referencias
- Lanzo una función como esta


Function SetCCC()
    Dim strCCC          As String
       
    strCCC = "UseOL_XLS = " & Abs(OL_XLS) & ":" _
            & "UseOL_OLK = " & Abs(OL_OLK)
    Application.SetOption "Conditional Compilation Arguments", strCCC
End Function


Con esa función se genera una cadena que toma los valores de las constantes "normales" (OL_XLS y OL_OLK) para crear una cadena que asignamos a la propiedad.


¿Y a la hora de distribuir?
Sencillo.
- Quitar la referencia de Excel
- Cambiar la constante OL_XLS a False
- Lanzar la función SetCCC para cambiar las directivas
- Compilar por si me hubiera dejado alguna constante no definida o alguna "cosa rara" en cuyo caso lo corregiría

Con esta forma de trabajar me he ahorrado tener un montón de "dobles declaraciones" y estar poniendo/quitando la adecuada:

Dim xlsApp As Excel.Application
'Dim xlsApp As Object

Truco: ¿Como mantengo mi lista de #constantes?
Yo lo tengo en un módulo independiente dónde, en el encabezado, consta la versión del módulo. Cada vez que añado una constante lo registro en el log de cambios y subo el número de versión. El módulo lo exporto a una determinada carpeta. Además, llevo un registro de versiones de todos los módulos en un Excel.

Cuando debo actualizar una aplicación, lo primero es revisar las versiones de los módulos por si tuviera versiones más actuales. Si el módulo de directivas de mi archivo es más moderno del de la aplicación, simplemente importo el nuevo módulo.

Espero que os sirva para "salvar" el problema de las referencias.