Mostrar/esconder en Word desde el acceso

adminmarzo 11, 2025
0 0 7 minutos de lectura
VBA

Código detrás del formulario

Option Compare Database 
Option Explicit 
'250309
' works in Word if there is an open document
'*************** Code Start *****************************************************
' cbf: f_aWord_ShowHide_s4p
'-------------------------------------------------------------------------------
' Purpose  : VBA to show or hide stuff in active Word document from Access
'              Field Codes, Bookmark Indicators, Nonprinting symbols
'              Navigation Pane, Rulers, Comments, more
' Author   : crystal (strive4peace)
' This tool: 
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Use at your own risk.
'-------------------------------------------------------------------------------
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Module variables
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
' NEED REFERENCE to:
'  Microsoft Word #.# Object Library
'  if you want to use EARLY binding

' late binding
Dim moWord As Object  'Word.Application
Dim moDoc As Object  'Word.Document

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Form_Load
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub Form_Load() 
'240821 strive4peace
   Set moWord = Nothing 
   Set moDoc = Nothing 
   
   Call ClearMyValues 
   'populate controls based on values from active Word document
   Call ReadMyValues 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ cmd_Word
Private Sub cmd_Word_Click() 
'250308
   'load and read everything again
   Call Form_Load 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           frames
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fraFieldShading
Private Sub fraFieldShading_AfterUpdate() 
'240824, 50305

   If Not isDocGood Then Exit Sub 
   
   Dim nFieldShading As Long 
   nFieldShading = Me.fraFieldShading 
   
   With moDoc.ActiveWindow.View 
      If .FieldShading <> nFieldShading Then 
         .FieldShading = nFieldShading 
      End If 
   End With 

End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ fraMarkup
Private Sub fraMarkup_AfterUpdate() 
'240825, 50305

   If Not isDocGood Then Exit Sub 
   
   Dim nValue As Long 
   nValue = Nz(Me.ActiveControl,-99) 
   
   With moDoc.ActiveWindow.View.RevisionsFilter 
   If nValue = -1 Then  'original
         .View = 1  'wdRevisionsViewOriginal
         .Markup = 0  'wdRevisionsMarkupNone
      Else 
         .View = 0  'wdRevisionsViewFinal
         .Markup = nValue 
      End If 
   End With 
     
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           SetCaption_Toggle
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function SetCaption_Toggle( _ 
   pControl As Control _ 
   ,Optional ByRef pbValue As Boolean _ 
   ,Optional ByRef pbReadValue As Boolean = True _ 
   ) As Boolean 
   
'240823, 24, 250228 pbValue, 305 ByVal, 250306, 7
'read toggle control value
' show HEAVY CHECK MARK or not in Caption

   ' PARAMETERs
   '  pControl = toggle control on this form
   '  OPTIONAL
   '     pbValue is defined boolean
   '     pbReadValue is TRUE unless value to use is passed by pbValue
   
   ' CALLs
   '  isDocGood

   On Error GoTo Proc_Err 
   
   Dim sName As String 
   
   'initialize return value
   SetCaption_Toggle = False  'error with Word
      
   'ensure ActiveDocument in Word
   If pbReadValue Then 
      If Not isDocGood Then Exit Function 
   End If 
   
   With pControl 
      'read value
      If pbReadValue Then 
         pbValue = .Value 
      'else use passed value
      End If 

      ' ----------- set Caption, Bold
      If pbValue <> False Then 
         'true
         .Caption = ChrW(10004)  'HEAVY CHECK MARK
      Else 
         .Caption =  " "
      End If 
      'bold or not the associated caption
      '     to make True value stand out
      .Controls(0).FontBold = pbValue 
   End With 

   'return value -- success
   SetCaption_Toggle = True 
   
Proc_Exit: 
   On Error GoTo 0  'reset error handler
   Exit Function 

Proc_Err: 

      MsgBox Err.Description _ 
          ,, "ERROR " & Err.Number _ 
           &  "   SetCaption_Toggle : " & Me.Name 
   
   Resume Proc_Exit 
   Resume 
   
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           Toggles
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ FieldCodes
Private Sub tog_FieldCodes_AfterUpdate() 
'240823, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
   
   With moDoc.ActiveWindow.View 
      If .ShowFieldCodes <> bValue Then .ShowFieldCodes = bValue 
   End With 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_ShowBookmarks
Private Sub tog_ShowBookmarks_AfterUpdate() 
'240823, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
      
   With moDoc.ActiveWindow.View 
      If .ShowBookmarks <> bValue Then .ShowBookmarks = bValue 
   End With 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_Nonprinting
Private Sub tog_Nonprinting_AfterUpdate() 
'240823, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
      
   With moDoc.ActiveWindow.View 
      If .ShowAll <> bValue Then .ShowAll = bValue 
   End With 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_Hyphens
Private Sub tog_Hyphens_AfterUpdate() 
'240909, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
   
   With moDoc.ActiveWindow.View 
      If .ShowHyphens <> bValue Then 
         .ShowHyphens = bValue 
      End If 
   End With 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_OptionalBreaks
Private Sub tog_OptionalBreaks_AfterUpdate() 
'240909, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
   
   With moDoc.ActiveWindow.View 
      If .ShowOptionalBreaks <> bValue Then 
         .ShowOptionalBreaks = bValue 
      End If 
   End With 

End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_NavigationPane
Private Sub tog_NavigationPane_AfterUpdate() 
'240823, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
      
   With moDoc.ActiveWindow 
      If .DocumentMap <> bValue Then .DocumentMap = bValue 
   End With 

End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_Ruler
Private Sub tog_Ruler_AfterUpdate() 
'240824, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
      
   With moDoc.ActiveWindow.ActivePane 
      If .DisplayRulers <> bValue Then .DisplayRulers = bValue 
   End With 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_StylesPane
Private Sub tog_StylesPane_AfterUpdate() 
'240825, 26, 305

   On Error GoTo Proc_Err 
   If Not isDocGood Then Exit Sub 
   
   Dim sMsg As String 
   Dim boo As Boolean 
   boo = Me.ActiveControl.Value 
   sMsg = vbCrLf & vbCrLf _ 
      &  "TIP: Show or not show manually with Word first" _ 
      &  " -- and then this toggle works."
         
   With moDoc.Parent.CommandBars( "Styles") 
      If .Visible <> boo Then .Visible = boo 
   End With 
   
   Call SetCaption_Toggle(Me.ActiveControl) 
   
Proc_Exit: 
   On Error GoTo 0 
   Exit Sub 
  
Proc_Err: 

   MsgBox Err.Description & sMsg _ 
       ,, "ERROR " & Err.Number _ 
        &  "   tog_StylesPane_AfterUpdate"

'   Me.tog_StylesPane.Value = 0 'don't know
   Resume Proc_Exit 
   Resume 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_Comments
Private Sub tog_Comments_AfterUpdate() 
'240824, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
   
   With moDoc.ActiveWindow.View 
      If .ShowComments <> bValue Then .ShowComments = bValue 
   End With 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_RevisionsComments
Private Sub tog_RevisionsComments_AfterUpdate() 
'240824, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
   
   With moDoc.ActiveWindow.View 
      If .ShowRevisionsAndComments <> bValue Then .ShowRevisionsAndComments = bValue 
   End With 
End Sub 


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~ tog_TrackChanges
Private Sub tog_TrackChanges_AfterUpdate() 
'240825, 250307
   ' CALLs
   '  SetCaption_Toggle
   
   Dim bValue As Boolean 

   'Call SetCaption_Toggle, bValue passed back
   If Not SetCaption_Toggle(Me.ActiveControl,bValue) Then 
      'problem with Word
      Exit Sub 
   End If 
      
   With moDoc 
      If .TrackRevisions <> bValue Then .TrackRevisions = bValue 
   End With 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           cmd_ToggleRibbon
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub cmd_ToggleRibbon_Click() 
'240823, 50305

   If Not isDocGood Then Exit Sub 
   'TOGGLE! either collapse or expand, ExecuteMso
   moWord.CommandBars.ExecuteMso  "MinimizeRibbon"
   

Proc_Exit: 

   On Error GoTo 0 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   cmd_ToggleRibbon_Click"

   Resume Proc_Exit 
   Resume 
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           isDocGood
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function isDocGood() As Boolean 
'240823, 250305,9
   'CALLs
   '  ClearMyValues
   '  SetWordActiveDocument
   
   On Error GoTo Proc_Err 
   
   Dim sName As String 
   
   isDocGood = False 
   
   If moWord Is Nothing Or moDoc Is Nothing Then 
      Call SetWordActiveDocument 
   End If 
   If moDoc Is Nothing Then 
      Call ClearMyValues 
      Exit Function 
   End If 
   
   On Error Resume Next 
   sName = moDoc.Name 
   If Err.Number <> 0 Then 
      Set moWord = Nothing 
      Set moDoc = Nothing 
      Call ClearMyValues 
      MsgBox  "Problem with Word"
      Exit Function 
   End If 
   
   isDocGood = True 
   
Proc_Exit: 
   On Error GoTo 0 
   Exit Function 

Proc_Err: 
   'MsgBox Err.Description _
       ,, "ERROR " & Err.Number _ 
        &  "   isDocGood : " & Me.Name 
   
   Resume Proc_Exit 
   Resume 
   
End Function 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           ClearMyValues
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub ClearMyValues() 
'240821, 250305, 7

   With Me 
      .fraFieldShading = Null 
      .fraMarkup = Null 
      
      .tog_FieldCodes = False 
      .tog_ShowBookmarks = False 
      .tog_Nonprinting = False 
      .tog_Hyphens = False 
      .tog_OptionalBreaks = False 
      
      .tog_NavigationPane = False 
      .tog_Ruler = False 
      .tog_StylesPane = False 
      
      .tog_Comments = False 
      .tog_RevisionsComments = False 
      .tog_TrackChanges = False 

      'change display
      Call SetCaption_Toggle(.tog_FieldCodes,0,False) 
      Call SetCaption_Toggle(.tog_ShowBookmarks,0,False) 
   
      Call SetCaption_Toggle(.tog_Nonprinting,0,False) 
      Call SetCaption_Toggle(.tog_Hyphens,0,False) 
      Call SetCaption_Toggle(.tog_OptionalBreaks,0,False) 
     
      Call SetCaption_Toggle(.tog_NavigationPane,0,False) 
      Call SetCaption_Toggle(.tog_Ruler,0,False) 
      Call SetCaption_Toggle(.tog_StylesPane,0,False) 
      
      Call SetCaption_Toggle(.tog_Comments,0,False) 
      Call SetCaption_Toggle(.tog_RevisionsComments,0,False) 
      Call SetCaption_Toggle(.tog_TrackChanges,0,False) 
      
   End With 
   
End Sub 

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           ReadMyValues
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function ReadMyValues() As Boolean 
'240821, 250228, 305,9
'fill control values based on open Word document
' more information:
'  
'  

   'CALLs
   '  SetWordActiveDocument
   
   On Error GoTo Proc_Err 
   
   Dim nFieldShading As Long _ 
      ,bShowFieldCodes As Boolean _ 
      ,bShowBookmarks As Boolean _ 
      ,bShowNonprinting As Boolean _ 
      ,bShowHyphens As Boolean _ 
      ,bShowOptionalBreaks As Boolean _ 
      ,bNavigationPane As Boolean _ 
      ,bRulers As Boolean _ 
      ,bComments As Boolean _ 
      ,bRevisionsAndComments As Boolean _ 
      ,bTrackRevisions As Boolean _ 
      ,bStylesPane As Boolean 
      
   Dim iMarkup As Integer 
   Dim iView As Integer 
   Dim sName As String 
   
   ReadMyValues = False 
   
   '--------------- default values as opposed to 0
   ' WdFieldShading
   ' 1 = Always
   ' 2 = When selected
   ' 0 = Never
'   nFieldShading = 2 'When selected
'   bShowBookmarks = True 'show
'   bShowNonprinting = False 'don't show
   
   If moDoc Is Nothing Then 
      Call SetWordActiveDocument 
   End If 
   If moDoc Is Nothing Then Exit Function  'nothing to do
   
   'make sure Word still open
   On Error Resume Next 
   sName = moDoc.Name 
   If Err.Number <> 0 Then 
      Call SetWordActiveDocument 
   End If 
   On Error GoTo 0 
   
   With moDoc 
      bStylesPane = .Application.CommandBars( "Styles").Visible 
      
      bTrackRevisions = .TrackRevisions 
      With .ActiveWindow 
         bNavigationPane = .DocumentMap 
         With .View 
            nFieldShading = .FieldShading 
            bShowFieldCodes = .ShowFieldCodes 
            bShowBookmarks = .ShowBookmarks 
            bShowNonprinting = .ShowAll 
            
            bShowHyphens = .ShowHyphens 
            bShowOptionalBreaks = .ShowOptionalBreaks 
                        
            bComments = .ShowComments 
            bRevisionsAndComments = .ShowRevisionsAndComments 
                        
            With .RevisionsFilter 
               iView = .View  '1=original, 0=final
               iMarkup = .Markup 
            End With  'RevisionsFilter
            
         End With  'Word document ActiveWindow.View
         
         With .ActivePane 
            bRulers = .DisplayRulers 
         End With  'ActiveWindow.ActivePane
         
      End With  'ActiveWindow
   End With  'Document
   
   'fill form control values
   With Me 
      .fraFieldShading = nFieldShading 
      .tog_FieldCodes = bShowFieldCodes 
      
      .tog_ShowBookmarks = bShowBookmarks 
      .tog_Nonprinting = bShowNonprinting 
      
      .tog_Hyphens = bShowHyphens 
      .tog_OptionalBreaks = bShowOptionalBreaks 
      
      .tog_NavigationPane = bNavigationPane 
      .tog_Ruler = bRulers 
      .tog_Comments = bComments 
      .tog_RevisionsComments = bRevisionsAndComments 
      
      .tog_TrackChanges = bTrackRevisions 
      
      .tog_StylesPane = bStylesPane 
      
      Call SetCaption_Toggle(.tog_FieldCodes,bShowFieldCodes,0) 
      Call SetCaption_Toggle(.tog_ShowBookmarks,bShowBookmarks,0) 
      Call SetCaption_Toggle(.tog_Nonprinting,bShowNonprinting,0) 
      
      Call SetCaption_Toggle(.tog_Hyphens,bShowHyphens,0) 
      Call SetCaption_Toggle(.tog_OptionalBreaks,bShowOptionalBreaks,0) 
      
      Call SetCaption_Toggle(.tog_NavigationPane,bNavigationPane,0) 
      Call SetCaption_Toggle(.tog_Ruler,bRulers,0) 
      Call SetCaption_Toggle(.tog_Comments,tog_Comments,0) 
      
      Call SetCaption_Toggle(.tog_RevisionsComments,bRevisionsAndComments,0) 
      
      Call SetCaption_Toggle(.tog_StylesPane,bStylesPane,0) 
      Call SetCaption_Toggle(.tog_TrackChanges,bTrackRevisions,0) 
      
      With Me.fraMarkup 
         If iView = 1 Then  'simple
            .Value = -1  'original
         Else 
            '0=RevisionsMarkupNone
            '1=wdRevisionsMarkupSimple
            '2=wdRevisionsMarkupAll
            .Value = iMarkup 
         End If 
      End With 
           
   End With 
   
   ReadMyValues = True 
   
Proc_Exit: 
   On Error GoTo 0  'reset
   Exit Function 

Proc_Err: 
   'MsgBox Err.Description _
       ,, "ERROR " & Err.Number _ 
        &  "   ReadMyValues"
   
   Resume Proc_Exit 
   Resume 
End Function 


'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           SetWordActiveDocument
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Sub SetWordActiveDocument() 
'240811 strive4peace, 250305 sub set moWord, moDoc
'return ActiveDocument in Word
'this isn't necessary when you already have a Document object
   
   'Initialize Word
   On Error Resume Next 
   Set moWord = GetObject(, "Word.Application") 
   On Error GoTo Proc_Err 
   If moWord Is Nothing Then 
      Set moDoc = Nothing 
      MsgBox  "Word isn't open",, "Can't get Word Object"
      Exit Sub 
   End If 
   
   'still here -- see if any docs open
   With moWord 
      If Not .Documents.Count > 0 Then 
         Set moDoc = Nothing 
         MsgBox  "No ActiveDocument in Word" _ 
            ,, "Can't get Word ActiveDocument"
         Exit Sub 
      End If 

      Set moDoc = .ActiveDocument 
   End With 


Proc_Exit: 
   On Error GoTo 0 
   Exit Sub 
  
Proc_Err: 
   MsgBox Err.Description _ 
       ,, "ERROR " & Err.Number _ 
        &  "   Word_Set _ActiveDocument"

   Resume Proc_Exit 
   Resume 
End Sub 

'*************** Code End ******************************************************
‘El código se generó con colores utilizando el complemento de código de color gratuito para el acceso
Goto top
Etiquetas
adminmarzo 11, 2025
0 0 7 minutos de lectura
VBA

Código detrás del formulario

admin

Publicaciones relacionadas

Guardar caracteres Unicode en un archivo desde campos de su base de datos de Access

Cuadro de lista con documentos de Word abiertos

A dónde recurrir a medida que se implementa la nueva perspectiva y rompe nuestras aplicaciones

Función VBA para obtener el tipo de consulta y SQL para enumerar la información de la consulta de Access para una base de datos de Access

Deja una respuesta Cancelar la respuesta
