Lista de fuentes instaladas mediante la automatización de Word desde Access con VBA

VBA

Código detrás del formulario de menú, f_MENU_FONT_List

Especifique una lista corta o larga. Haga clic en el botón para crear un documento de Word.

Marque «Ver progreso» para ver el documento de Word mientras se crea. Esto lleva más tiempo para que se ejecute el código, pero es interesante verlo.

Marque «Coincidir con patrón» para evaluar cada nombre de fuente con un patrón y ver si se debe incluir. Luego, especifique el patrón que desee. El valor predeterminado es omitir los nombres de fuente que comienzan con @

También puede hacer clic en los botones para ir al código VBA de cada paso principal.

Código de llamadas en el módulo:

• mod_Word_Make_LISTA_DE_FUENTES_s4p

Procedimientos:

• UpdateProgress (público)
• Carga de formulario
• cmd_Word_Hacer_Lista_de_Fuentes_Clic
• cmd_VBA_WordApp_Crear_Clic
• cmd_VBA_WordDoc_Obtener_nuevo_clic
• cmd_VBA_Márgenes_de_Word_Clic_estrecho
• cmd_VBA_WordTable_Hacer_clic
• Clic en los bordes de la tabla de Word de VBA
• cmd_VBA_Escribir_Datos_Clic
• Clic en encabezado de WordDoc de VBA cmd
• cmd_VBA_WordDoc_GuardarCerrar_Clic
• Clic para liberar cmd_VBA_WordApp

Option Compare Database 
Option Explicit 
' 230316 cmd_Word_FontList
' cbf: f_MENU_FONT_List
'*************** Code Start ***************************************************
' Purpose  : code behind form to List Windows Fonts installed using Word
' Author   : crystal (strive4peace)
' Code List: 
' This Code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'                              Public UpdateProgress
'--------------------------------------------------------------------------------
Public Sub UpdateProgress(psMessage As String) 
'230314 s4p
   Me.Label_Progress.Caption = psMessage 
End Sub 

'--------------------------------------------------------------------------------
'                              Form_Load
'--------------------------------------------------------------------------------
Private Sub Form_Load() 
'230314 s4p
   Call UpdateProgress( " ") 
End Sub 

'--------------------------------------------------------------------------------
'                              chk_MatchPattern_AfterUpdate
'--------------------------------------------------------------------------------
Private Sub chk_MatchPattern_AfterUpdate() 
'230316
   With Me 
      If .chk_MatchPattern  False Then 
         .txtPattern.SetFocus 
      End If 
   End With 
End Sub 

'--------------------------------------------------------------------------------
'                              cmd_Word_FontList_Click
'--------------------------------------------------------------------------------
Private Sub cmd_Word_FontList_Click() 
'230314 strive4peace, 230316
   'Calls
   '  Word_Make_Font_List_s4p
   
   Dim iShortLong As Integer 
   Dim sPattern As String 
   Dim bWatchProgress As Boolean 
   
   With Me 
      If .chk_MatchPattern  False Then 
         sPattern = .txtPattern 
      Else 
         sPattern =  ""
      End If 
      iShortLong = Nz(.fra_ShortLong,1) 
      bWatchProgress = Nz(.chk_WatchProgress,0) 
   End With 
   
   Call Word_Make_Font_List_s4p( _ 
      iShortLong,sPattern,bWatchProgress _ 
      ) 
End Sub 

'--------------------------------------------------------------------------------
'                              Open VBA Code
'--------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~ mod_Word_Application_Document_s4p
Private Sub cmd_VBA_WordApp_Create_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Application_Document_s4p", "WordApp_Create"
End Sub 

Private Sub cmd_VBA_WordDoc_GetNew_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Application_Document_s4p", "WordDoc_GetNew"
End Sub 

'~~~~~~~~~~~~~~~ mod_Word_Margins_s4p
Private Sub cmd_VBA_Word_Margins_Narrow_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Margins_s4p", "Word_Margins_Narrow"
End Sub 

'~~~~~~~~~~~~~~~ mod_Word_Table_s4p
Private Sub cmd_VBA_WordTable_Make_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Table_s4p", "WordTable_Make"
End Sub 

Private Sub cmd_VBA_WordTable_Borders_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Table_s4p", "WordTable_Borders"
End Sub 

'~~~~~~~~~~~~~~~ mod_Word_Make_FONT_LIST_s4p
Private Sub cmd_VBA_WriteData_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Make_FONT_LIST_s4p", "Word_Make_Font_List_s4p"
End Sub 

'~~~~~~~~~~~~~~~ mod_Word_Header_s4p
Private Sub cmd_VBA_WordDoc_Header_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Header_s4p", "WordDoc_Header"
End Sub 

'~~~~~~~~~~~~~~~ mod_Word_Application_Document_s4p
Private Sub cmd_VBA_WordDoc_SaveClose_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Application_Document_s4p", "WordDoc_SaveClose"
End Sub 

Private Sub cmd_VBA_WordApp_Release_Click() 
'230314 strive4peace
   DoCmd.OpenModule  "mod_Word_Application_Document_s4p", "WordApp_Release"
End Sub 
'*************** Code End *****************************************************

Ir al inicio

mod_Word_Make_LISTA_DE_FUENTES_s4p

Código de llamadas en módulos:

• mod_Word_Documento_de_aplicación_s4p
• mod_Márgenes_de_Word_s4p
• mod_Tabla_de_Words_s4p
• mod_Encabezado_de_Word_s4p

Procedimientos:

• escribirPROGRESO
• Lista de fuentes de WordMaker s4p

Opción Comparar base de datos
Opción explícita
‘2303126 psPattern, sDocHeader ‘*************** Inicio de código ******************************************************** ‘ nombre del módulo: mod_Word_Make_Fonts_List_s4p ‘——————————————————————————- ‘ Propósito: VBA para crear una lista de fuentes instaladas en Windows usando Word ‘ Autor: crystal (strive4peace) ‘ Lista de códigos: ‘ Este código: ‘ LICENCIA: ‘ Puede usar y compartir libremente este código, pero no venderlo. ‘ Mantenga la atribución. Úselo bajo su propio riesgo. ‘——————————————————————————-

‘La vinculación temprana necesita referencia a: ‘ Biblioteca de objetos Microsoft Word #.# ‘ Variables públicas definidas y establecidas en ‘ mod_Word_Application_Document_s4p ‘ ‘——————————————————————————- ‘ writePROGRESS ‘——————————————————————————-
Sub escribirPROGRESO(psMensaje Como cadena) ‘— personalizar ‘230315 strive4peace. Enviar » » para borrar el mensaje

Llamar Formulario_f_MENU_FONT_List.UpdateProgress(psMessage)

Si psMensaje = » » Entonces
‘borrar mensaje en la barra de estado
SysCmd acSysCmdClearStatus
Demás
Oscuro Estado del mensaje Como cadena
sMessageStatus = Reemplazar(psMessage,vbCrLf, » «) SysCmd acSysCmdSetStatus,sMessageStatus
Fin si
Fin del subtítulo
‘——————————————————————————- ‘ Lista_de_fuentes_Word_Make_s4p ‘——————————————————————————-
Sub Lista de fuentes de WordMake s4p( _
Opcional piCortoLargo Como entero = 1 _ ,Opcional psPatrón Como cadena = «» _ ,Opcional Progreso del reloj pb Como booleano = Verdadero _ )
‘220420 strive4peace, 220530, 230314, 5 230316 ‘crear un documento de Word que muestre ejemplos de todas las fuentes instaladas

‘LLAMA’ writePROGRESS – escribe un mensaje de progreso en el formulario de menú ‘ WordApp_Create – establece goWord ‘ WordDoc_GetNew – devuelve el documento ‘ WordTable_Make ‘ – luego escribe los datos ‘ Word_Margins_Narrow ‘ WordTable_Borders ‘ WordDoc_Header ‘ WordDoc_SaveClose ‘ WordApp_Release ‘ ‘UTILIZA ‘ WizHook.SortStringArray

En caso de error, ir a Error de proceso

‘enlace anticipado’ Dim oDoc As Word.Document ‘ Dim oRange As Word.Range ‘ Dim oTable As Word.Table

‘encuadernación tardía
Oscuro oDoc Como objeto
Oscuro naranja Como objeto
Oscuro oMesa Como objeto

Oscuro sText Como cadena _ ,sRuta Como cadena _ ,sNombre de archivo Como cadena _ ,sDocHeader Como cadena _ ,sNombreDeFuente Como cadena _ ,mensaje de texto Como cadena _ ,sgTemporizador Como soltero

Oscuro i Como entero _ ,iRow Como entero _ ,iFilas Como entero _ ,iCountPatrón Como entero
Oscuro como fuente() Como cadena
Oscuro una matriz de encabezado(1 A 2) Como cadena

sgTimer = Temporizador sDocHeader = IIf(piShortLong = 1, «Short «, «Long «) _ & «Lista de fuentes» _ & IIf(psPattern «» _ , » para patrón » & psPattern _ , «») sFilename = «FontList_» _ & IIf(psPattern «», «Pattern_», «») _ & IIf(piShortLong = 1, «Short», «Long») _ & «_s4p_» iCountPattern = 0

‘————————————— Palabra de configuración
Llamar writePROGRESS(«configurar Word»)

‘crear objeto de aplicación goWord
Llamar WordApp_Crear

‘crear y devolver un nuevo documento de Word
Colocar oDoc = WordDoc_GetNew

‘establecer márgenes de página estrechos
Llamar Márgenes de palabras estrechos (oDoc)

‘————————————— Escribir datos
Llamar writePROGRESS(«escribe texto e hipervínculo»)

‘Escribe cosas al principio para describir el documento
sText = «Descargar base de datos de Access con VBA» _ & » y un formulario de menú para crear este documento: »

Con oDoc.Rango.InsertarDespués de sText.Rango.Contraer 0

Colocar oRange = oDoc.Range oRange.Collapse 0 .Hipervínculos.Agregar ancla:=oRange _ ,Dirección:= «» _ ,Texto a mostrar:= «»
Terminar con

Con oDoc.Range.Collapse 0.InsertParagraphAfter
Terminar con

Llamar writePROGRESS(«asignar cadena de ejemplo»)

‘hacer cadena por ejemplo
Si piCortoLargo = 1 Entonces
sTexto = «ABCDEFGHIJKLMNOPQRSTUVWXYZ» y » » _ y «abcdefghijklmnopqrstuvwxyz»
Demás
sTexto = Cristo(32) ‘espacio en fuentes estándar
Para yo = 33 A 254 sTexto = sTexto & Cristo(i)
‘agrega espacio cada 10 caracteres
Si i Mod 10 = 0 Entonces
sTexto = sTexto & » »
Fin si
Próximo i
Fin si

‘establecer rango al final del documento
Colocar oRange = oDoc.Contenido oRange.Contraer (0) ‘0=wdCollapseFin

‘contar filas
iRows = goWord.nombresdefuentes.Count

Llamar writePROGRESS(«obtener y ordenar los nombres de las fuentes»)

‘crea una matriz con todos los nombres de fuentes
Redim como fuente (1 A iRows) iCountPattern = 0

Para yo = 1 A iRows sFontName = goWord.fontnames(i)
Si psPatrón «» Entonces
Si no Nombre de fuente Como psPatrón Entonces
Ir a proc_SiguienteFuente
Fin si
Fin si
iCountPattern = iCountPattern + 1 asFont(iCountPattern) = sFontName proc_NextFont:
Próximo i

‘redimensionar matriz si hubiera un patrón
Si iCountPattern Then MsgBox «Ningún nombre de fuente coincide con el patrón: » & psPattern _ ,, «Anulando creación de documento» oDoc.Close SaveChanges:=False
Ir a Proc_Salir
Fin si

Si iCountPattern iFilas Entonces
Conservación de ReDim como fuente (1 A iCountPatrón)
Fin si

‘ordenar matriz de nombres de fuentes
WizHook.SortStringArray como fuente

‘pausa

Llamar writePROGRESS( «tabla» _ & vbCrLf & vbCrLf & «con un número especificado de filas y columnas»)

‘crear una tabla de Word al final del documento con ‘ 1 fila para cada fuente + fila para el encabezado ‘ 2 columnas ‘ omitir título
aHeadArray(1) = «Nombre de la fuente» aHeadArray(2) = «Ejemplo»

Colocar oTable = WordTable_Make(oDoc,oRange,iCountPattern + 1,2 _ , «»,aHeadArray)

Llamar writePROGRESS( «tabla» _ & vbCrLf & vbCrLf & «establecer anchos de columna»)

Con oMesa
‘1. Nombre de fuente, 2. Ejemplo ‘———————– Anchos de columna
.Columnas(1).AnchoPreferido = CINTO(1.8 * 72).Columnas(2).AnchoPreferido = CINTO(5,7 * 72)
Terminar con

Llamar writePROGRESS( «tabla» _ & vbCrLf & vbCrLf & «bordes»)

Llamar WordTable_Borders(oTable) iRow = 1 ‘permitir fila de encabezado

Con oMesa
Para yo = LBound(como fuente) Para UBound(comoFuente) sFontName = comoFuente(i)
Llamar writePROGRESS( «escribir datos» _ & vbCrLf & vbCrLf & sFontName) iRow = iRow + 1 .Cell(iRow,1).Range.Text = sFontName
Con .Celda(iFila,2).Rango
Si Progreso del reloj pb Falso entonces
.Seleccionar ‘ mira el progreso
Fin si
.Texto = sTexto .Fuente.Nombre = sFontName
Terminar con
Próximo i
Terminar con ‘oMesa

‘————————————— Encabezado de página

Llamar writePROGRESS( «encabezado de página»)
Llamar WordDoc_Header(oDoc,sDocHeader)

‘Enumere cuántas fuentes se enumeran al final del documento
Llamar writePROGRESS(«contar fuentes»)
Con oDoc.Content .InsertParagraphAfter .InsertParagraphAfter sMsg = Format(iRows, «#,###») & » fuentes instaladas»
Si iCountPattern iFilas Entonces
sMsg = sMsg & «,» _ & Format(iCountPattern, «#,###») & » enumerado»
Fin si
.Insertar después del mensaje de texto
Terminar con ‘oDoc.Contenido

‘Vaya a la primera página para obtener una buena licencia’ 1=wdGoToPage ‘-1=wdGoToLast ‘1=wdGoToFirst
oDoc.Ir a 1,1

‘————————————— Guardar y cerrar documento
Documento_Guardar:
Llamar writePROGRESS( «Guardar y cerrar documento»)

‘obtener sFilename actualizado de nuevo
Llamar WordDoc_SaveClose(oDoc _ ,sNombreArchivo _ , «strive4peace»,,sRuta) sgTimer = Temporizador – sgTimer

Si temporizador sg > 60 Entonces
sMsg = sMsg & vbCrLf _ & sgTimer \ 60 & » minutos, » _ & Format(sgTimer – (sgTimer \ 60) * 60, «#.#») & » segundos»
Demás
sMsg = sMsg & vbCrLf _ & Format(sgTimer, «#.#») & » segundos»
Fin si

Si Progreso del reloj pb Falso entonces
sMsg = sMsg & «, viendo el progreso»
Fin si

sMsg = sPath _ & vbCrLf & sNombreArchivo _ & vbCrLf & vbCrLf & sMsg

‘————————————— Abrir Word
Llamar writePROGRESS(sMsg) sMsg = sMsg _ & vbCrLf & vbCrLf & «¿Abrir la ruta?»
Si MsgBox(sMsg,vbYesNo, «Hecho») = vbYes Entonces
Llamar Shell(«Explorer.exe» y » » y sPath,vbNormalFocus)
Fin si

Llamar escribirPROGRESO( » «) ‘mensaje claro

Proc_Salir:
Colocar oRango = Nada
Colocar oTabla = Nada
Colocar oDoc= Nada
Llamar Versión de WordApp
Salir del subtítulo

Proc_Err: MsgBox Err.Description _ ,, «ERROR » & Err.Number _ & » Word_Make_Font_List_s4p»

Reanudar Proc_Salir
Reanudar
Fin del subtítulo
‘*************** Fin del código **********************************************************

Ir al inicio

mod_Word_Documento_de_aplicación_s4p

Establece la variable de objeto global:

Establece una constante global:

Procedimientos:

• WordApp_Crear
• Versión de WordApp
• WordDoc_ObtenerNuevo
• WordDoc_GuardarCerrar
• Obtener ruta del escritorio
• Hacer una ruta

Option Compare Database 
Option Explicit 
'230316 pbWatchProgress
'*************** Code Start *****************************************************
' module name: mod_Word_Application_Document_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to set, save, and release Word application and Word Document
'              and code to get desktop path and make a path
' Author   : crystal (strive4peace)
' Code List: 
' This Code: 
'
'     Sub WordApp_Create
'        set public goWord variable for Word.Application as object for late-binding
'     Sub WordApp_Release
'        release goWord Word.Application
'     Function WordDoc_GetNew
'        make a new Word.Document and return the object for late-binding
'     Function WordDoc_SaveClose
'        save Word document as file on desktop or in folder
'        Return Path\Filename.Ext
'        Return Path in psReturnPath
'     Function GetDesktopPath
'        Return Path
'     Function MakeAPath
'        send path, return True if there or created
'
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'               Public variables
'-------------------------------------------------------------------------------
Const gbEarly As Boolean = False 
#Const IsEarly = gbEarly 
Private mbWordQuit As Boolean 
'early binding needs reference to:
'  Microsoft Word #.# Object Library
#If IsEarly = True Then 
   'early binding
   Public goWord As Word.Application 
'   Public goDoc As Word.Document
'   Public goField As Word.Field
'   Public goRange As Word.Range
#Else 
   'late binding
   Public goWord As Object 
'   Public goDoc As Object
'   Public goField As Object
'   Public goRange As Object
#End If 

'-------------------------------------------------------------------------------
'                        WordApp_Create
'-------------------------------------------------------------------------------
Public Sub WordApp_Create() 
'220420 strive4peace, 230314
'set public goWord variable for Word.Application

   mbWordQuit = False  'default value
   
   'if Word is already open, use that instance
   On Error Resume Next 
   Set goWord = GetObject(, "Word.Application") 
   On Error GoTo Proc_Err 
   
   If goWord Is Nothing Then 
      'Word wasn't open - create global Word application object
      Set goWord = CreateObject( "Word.Application") 
      mbWordQuit = True 
   End If 
   
Proc_Exit: 
   On Error Resume Next 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   WordApp_Create"

   Resume Proc_Exit 
   Resume 
End Sub 
'-------------------------------------------------------------------------------
'                        WordApp_Release
'-------------------------------------------------------------------------------
Public Sub WordApp_Release() 
'220420 strive4peace, 221108, 230315
'release goWord Word.Application
   On Error GoTo Proc_Err 
'   Set goField = Nothing
      
   'if Word application was started, then Quit
   If mbWordQuit = True Then 
'      If Not goDoc Is Nothing Then
'         'close document and don't save changes
'         goDoc.Close False
'      End If
      goWord.Quit 
   End If 
'   Set goDoc = Nothing
   
   'release Word application object
   Set goWord = Nothing 
   
Proc_Exit: 
   On Error Resume Next 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   WordApp_Release"

   Resume Proc_Exit 
   Resume 
End Sub 
'-------------------------------------------------------------------------------
'                        WordDoc_GetNew
'-------------------------------------------------------------------------------
Public Function WordDoc_GetNew( _ 
   Optional pbWatchProgress As Boolean = True _ 
   ) As Object  'Word.Document
'220420 strive4peace, 221314
'make a new Word.Document and return the object
'set goWord -- create or use Word.Application
'set Visible to True and Activate the window
   'RETURN
   '  Word.Document (object for late binding)
   'CALLS
   '  WordApp_Create
   
   'Initialize Word
   If goWord Is Nothing Then 
      Call WordApp_Create 
   End If 
   
   With goWord 
      If pbWatchProgress  False Then 
         ' make Word visible
         .Visible = True 
      End If 
      'make a new Word document and return the object
      Set WordDoc_GetNew = .Documents.Add 
   End With 

Proc_Exit: 
   On Error Resume Next 
   Exit Function 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   WordDoc_GetNew"

   Resume Proc_Exit 
   Resume 
End Function 
'-------------------------------------------------------------------------------
'                        WordDoc_SaveClose
'-------------------------------------------------------------------------------
'  Word.Document
Public Function WordDoc_SaveClose( _ 
   oDoc As Object _ 
   ,ByRef psFilename As String _ 
   ,Optional psFolderOrPath As String =  "" _ 
   ,Optional psFormatDateTime As String =  "yymmdd_hhnn" _ 
   ,Optional psReturnPath As String _ 
   ) As String 
'220420 strive4peace, ... 230314, 15
'save Word document as file on desktop or in folder
'Return Path\Filename.Ext
'Return Path in psReturnPath
'if psFolderOrPath specified, path is that folder on the desktop
'     if path is absolute and use that instead
'if no file extension specified, default will be added
'oDoc is the document object

   ' CALLs
   '  GetDesktopPath
   '  MakeAPath
   
' EXAMPLE:
'  CALL WordDoc_SaveClose(oDoc, "Word_Styles_s4p_", "strive4peace",,sPath)

   'PARAMETERS
   '  oDoc is the Word document object
   '  psFilename is what to call the file, with or without an extension
   '  psFolderOrPath is a folder name on the desktop
   '  psFormatDateTime is the date/time format to add, "" to skip
   '  psReturnPath is the Path

   'RETURN
   '  Path\Filename.Ext
   
   'CALLS
   '  GetDesktopPath
   '  MakeAPath

   On Error GoTo Proc_Err 
   
   Dim sPath As String _ 
      ,sPathFile As String 
      
   'if full path specified, use it
   If InStr(psFolderOrPath, ":") > 0 Then 
      sPath = psFolderOrPath 
   Else 
      'get desktop path ending with \
      sPath = GetDesktopPath(True) 
      
      If psFolderOrPath   "" Then 
         'make or use a folder on the desktop
         If MakeAPath(sPath & psFolderOrPath &  "\")  False Then 
            sPath = sPath & psFolderOrPath &  "\"
         End If 
      End If 
   End If 
   
   If Right(sPath,1)   "\" Then 
      sPath = sPath &  "\"
   End If 
   
   sPathFile = sPath & psFilename _ 
      & IIf(psFormatDateTime   "", "_" & Format(Now,psFormatDateTime), "") 

   oDoc.SaveAs sPathFile 
   
   'return path in a parameter
   psReturnPath = sPath 
   
   'return full path and filename with extension
   WordDoc_SaveClose = oDoc.FullName 
   'update filename and pass back
   psFilename = oDoc.Name 
   
   'close document without saving
   oDoc.Close SaveChanges:=False 
   
Proc_Exit: 
   On Error Resume Next 
   Exit Function 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   WordDoc_SaveClose"

   Resume Proc_Exit 
   Resume 
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           GetDesktopPath
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Function GetDesktopPath( _ 
   Optional pbAddTrailBackslash As Boolean = False _ 
   ) As String 

   With CreateObject( "WScript.Shell") 
      GetDesktopPath = .specialfolders( "Desktop") _ 
         & IIf(pbAddTrailBackslash, "\", "") 
   End With 
End Function 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           MakeAPath
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function MakeAPath( _ 
   psPath As String) As Boolean 
'crystal (strive4peace) ...190204

   'set up error handler
   On Error GoTo Proc_Err 

   'initialize return value to be False for not successful
   MakeAPath = False 

   'if directory is already there, return True and exit
   If Len(Dir(psPath,vbDirectory)) > 0 Then 
      MakeAPath = True 
      GoTo Proc_Exit 
   End If 

   'dimension variables
   Dim i As Integer _ 
      ,iPos As Integer _ 
      ,sPath As String 

   'add backslash to end of path if necessary
   iPos = 1 
   If Right(psPath,1)   "\" Then psPath = psPath &  "\"

   'get position of first backslash
   iPos = InStr(iPos,psPath, "\") 

   'loop through directories of path and make folders
   Do While iPos > 0 
      sPath = Left(psPath,iPos) 
      If Len(Dir(sPath,vbDirectory)) = 0 Then 
         MkDir sPath 
         DoEvents 
      End If 

      'set start search position to be 1 + position of last backslash found
      iPos = InStr(iPos + 1,psPath, "\") 
   Loop 

   'if folder exists, then return True and exit
   If Len(Dir(psPath,vbDirectory)) > 0 Then 
      MakeAPath = True 
   End If 

'exit code
Proc_Exit: 
   On Error Resume Next 
   Exit Function 

'if there is an error, then resume with exit code
Proc_Err: 
   Resume Proc_Exit 
End Function 
'*************** Code End *******************************************************

Ir al inicio

mod_Márgenes_de_Word_s4p

Procedimientos:

• Márgenes de palabras estrechos
• Márgenes de palabra de 1 pulgada
• Márgenes de palabras

'*************** Code Start *****************************************************
' module name: mod_Word_Margins_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to set margins in a Word document
'              uses Document.PageSetup
' Author   : crystal (strive4peace)
' Code List: 
' This Code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           72 points in an inch
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Word_Margins_Narrow
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins_Narrow(oDoc As Object) 
'make margins 0.5 inches on all sides
   With oDoc.PageSetup 
      .TopMargin = CInt(0.5 * 72)       'InchesToPoints
      .BottomMargin = CInt(0.5 * 72)    'InchesToPoints
      .LeftMargin = CInt(0.6 * 72)      'InchesToPoints
      .RightMargin = CInt(0.5 * 72)     'InchesToPoints
   End With 
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Word_Margins_1inch
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins_1inch(oDoc As Object) 
'make margins 1 inch on all sides
   With oDoc.PageSetup 
      .TopMargin = 72               'InchesToPoints
      .BottomMargin = 72            'InchesToPoints
      .LeftMargin = 72              'InchesToPoints
      .RightMargin = 72             'InchesToPoints
   End With 
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Word_Margins
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub Word_Margins(oDoc As Object _ 
   ,pInchTop As Double _ 
   ,pInchBottom As Double _ 
   ,pInchLeft As Double _ 
   ,pInchRight As Double _ 
   ) 
'send what you want for each margin in inches
   With oDoc.PageSetup 
      .TopMargin = CInt(pInchTop * 72)           'InchesToPoints
      .BottomMargin = CInt(pInchBottom * 72)     'InchesToPoints
      .LeftMargin = CInt(pInchLeft * 72)         'InchesToPoints
      .RightMargin = CInt(pInchRight * 72)       'InchesToPoints
   End With 

End Sub 
'*************** Code End *******************************************************

Ir al inicio

mod_Tabla_de_Words_s4p

Procedimientos:

• Crear tabla de palabras
• Bordes de WordTable

'*************** Code Start *****************************************************
' module name: mod_Word_Table_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to create a table and add borders to a table in Word
' Author   : crystal (strive4peace)
' Code List: 
' This Code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           WordTable_Make
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Function WordTable_Make(oDoc As Object _ 
   ,oRange As Object _ 
   ,ByVal pnRows As Long _ 
   ,ByVal pnCols As Long _ 
   ,ByVal psCaption As String _ 
   ,pasHeadArray() As String _ 
   ) As Object  'As Word.Table
'strive4peace 170811, 20202, 220420,230309

   'early binding
'   Dim oTable As Word.Table

   'late binding
   Dim oTable As Object 
   
   Dim i As Integer 
   
   'insert table
   With oDoc 
      Set oTable = .Tables.Add( _ 
         Range:=oRange _ 
         ,NumRows:=pnRows _ 
         ,NumColumns:=pnCols _ 
         ) 

   End With 
 
   If (psCaption   "") Then 
      'insert caption
      oDoc.Application.Selection.InsertCaption _ 
            Label:= "Table" _ 
            ,title:=psCaption _ 
            ,Position:=0 _ 
            ,ExcludeLabel:=0 
   End If 
      
   With oTable 
      'Position - wdCaptionPositionAbove=0
'      .ApplyStyleHeadingRows = True
      .TopPadding = 0 
      .BottomPadding = 0 
      .LeftPadding = 2  'points
      .RightPadding = 2 
      .Spacing = 0  'Auto
      .AllowPageBreaks = True 
      .AllowAutoFit = False 
 
      'mark heading row
      .Rows(1).HeadingFormat = True 
      'dont allow rows to break
      .Rows.AllowBreakAcrossPages = False 
 
      'no space above text between paragraphs
      .Range.Paragraphs.SpaceBefore = 0 
 
      'Vertical Alignment is Center
      .Range.Cells.VerticalAlignment = 1  ' 1=wdCellAlignVerticalCenter
 
      'Heading Row
      For i = LBound(pasHeadArray) To UBound(pasHeadArray) 
         .Cell(1,i).Range.Text = pasHeadArray(i) 
      Next i 
 
   End With 
 
   Set WordTable_Make = oTable 
 
End Function 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           WordTable_Borders
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Public Sub WordTable_Borders(oTable As Object)   'Word.Table
's4p 170811, 230314
   On Error Resume Next 
   Dim i As Integer 
   With oTable 
      For i = -1 To -6 Step -1 
         'wdBorderTop =-1
         'wdBorderLeft = -2
         'wdBorderBottom =-3
         'wdBorderRight= -4
         'wdBorderHorizontal = -5
         'wdBorderVertical = -6 -- error?

         With .Borders(i) 
            .LineStyle = 1   'wdLineStyleSingle=1
            .LineWidth = 8  'wdLineWidth100pt=8. wdLineWidth150pt=12
            .Color = RGB(200,200,200)  'medium-light gray
         End With 
      Next i 
   End With 
   'change borders to black for first row
   With oTable.Rows(1) 
      For i = -1 To -4 Step -1 
         With .Borders(i) 
            .Color = 0       'wdColorBlack = 0
         End With 
      Next i 
      'Shading for header row
      .Shading.BackgroundPatternColor = RGB(232,232,232) 
   End With  'first row
   'Not used:
'      'wdLineStyleNone = 0
'      .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
'      .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub 

'*************** Code End *******************************************************

Ir al inicio

mod_Encabezado_de_Word_s4p

Procedimientos:

'*************** Code Start *****************************************************
' module name: mod_Word_Header_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to create a new Word document and set Header
' Author   : crystal (strive4peace)
' Code List: 
' This Code: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
   
Const InchToPoint = 72 

'early binding needs reference to:
'  Microsoft Word #.# Object Library

'-------------------------------------------------------------------------------
'                       WordDoc_Header
'-------------------------------------------------------------------------------
Sub WordDoc_Header(oDoc As Object _ 
   ,psTitle As String _ 
   ,Optional pbAddHeading12 As Boolean = False) 
'220530 strive4peace, 230314

   Dim sgTabMiddle As Single 
   With oDoc.PageSetup 
      sgTabMiddle = .PageWidth - .LeftMargin - .RightMargin 
   End With 
   
   Dim oRange As Object 
   '1= wdHeaderFooterPrimary
   Set oRange = oDoc.Sections(1).Headers(1).Range 
   With oDoc 
      If pbAddHeading12 = True Then 
         'reference to Heading 1
         ' -1=wdFieldEmpty, False= Don't PreserveFormatting
         'reference oDoc
         .Fields.Add oRange,-1 _ 
            , "STYLEREF " & Chr(34) &  "Heading 1" & Chr(34),False 
         Set oRange = .Sections(1).Headers(1).Range 
         'position cursor after field just added
         oRange.Collapse 0  'wdCollapseEnd
         
         ' add comma space
         oRange.InsertAfter  ", "
         'collapse to end
         oRange.Collapse Direction:=0  'wdCollapseEnd
         
         'reference to Heading 2
         ' -1=wdFieldEmpty
         .Fields.Add oRange,-1 _ 
               , "STYLEREF " & Chr(34) &  "Heading 2" & Chr(34),False 
         Set oRange = .Sections(1).Headers(1).Range 
         oRange.Collapse Direction:=0 
      End If 
      
      'add TABs and text to align on right
      oRange.InsertAfter vbTab & psTitle &  ", " _ 
         &  "strive4peace, page "
      oRange.Collapse Direction:=0 
      
      'reference to Page number
      .Fields.Add oRange,-1, "Page",False 
      Set oRange = .Sections(1).Headers(1).Range 
      'collapse to end and
      oRange.Collapse Direction:=0 
      
      'insert /
      oRange.InsertAfter  "/"
      oRange.Collapse 0 
      
      'reference to total pages
      oRange.Parent.Fields.Add oRange,-1, "NumPages",False 
      Set oRange = .Sections(1).Headers(1).Range 
      oRange.Collapse 0 
      
       'update fields
      .Sections(1).Headers(1).Range.Fields.Update 
     
      'border line below paragraph
      With oRange 
         With .ParagraphFormat 
            '6 point space after paragraph
            .SpaceAfter = 6 
            'clear default tab stops
            .TabStops.ClearAll 
            'right tab stop at 6.5 inches
            'wdAlignTabRight=2
            'wdTabLeaderSpaces=0
            .TabStops.Add Position:=sgTabMiddle _ 
               ,Alignment:=2 _ 
               ,Leader:=0 
         End With  'ParagraphFormat
         With .Borders(-3)  'wdBorderBottom =-3
            .LineStyle = 1   'wdLineStyleSingle=1
            .LineWidth = 8  'wdLineWidth100pt=8
            .Color = RGB(75,75,75)  'dark gray
         End With  'Borders
      End With 
      .Range.Collapse 1  'goto beginning of document
   End With 
   
   Set oRange = Nothing 
   
End Sub 

'*************** Code End *******************************************************

‘El código se generó con colores utilizando el complemento gratuito Color Code para Access.