Ms Access Gurus      
Home Articles Code Tools

List Fields in Word using Access

Document field information for the active document in Word to a new document. List page number, order, start position, length, field, parameters, switches including Format, and results.

A menu form pops up when the database opens to make it easy to run the code. Because this process can take awhile, a PleaseWait form appears while running to tell you what's happening.

{ List Fields in Word using Access }

Quick Jump

Download VBA Reference Backstory Share Donate

Goto the Very Top  

Download

Download

Access form that interacts with the Active Document in Word to document field information to a new Word document.

Access database file has 2 forms and 3 modules. Uses late binding with Word, which can be changed to early binding for intellisense.

aWord_ListFields_s4p_ACCDB.zip (70 kb, unzips to an Access ACCDB database file. )  

updated 13 April 2025

License

This may be used freely, but you may not sell it in whole or in part. You may include it in applications you develop for others provided you keep attribution, mark your modifications, and share this source link.

Remember to UNBLOCK files you download to remove the Mark of the Web. Here are steps to do that: https://msaccessgurus.com/MOTW_Unblock.htm

Goto Top  

VBA

code behind form: f_MENU_WordListFields

iaWordListFields_Menu_short

CALL aWord_WriteFieldList_2NewDoc_s4p 

'cbf: f_MENU_WordListFields
'*************** Code Start ***************************************************
' Purpose  : List Field information for ActiveDocument in Word
'              to a new Word document using Microsoft Access
' Author   : crystal (strive4peace)
' Code List: https://msaccessgurus.com/code.htm
' This tool: https://msaccessgurus.com/tool/aWord_ListFields.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'~~~~~~~~~~ Report
Private Sub cmd_ListFields_Click() 
'250404
   Call aWord_WriteFieldList_2NewDoc_s4p 
End Sub 
'*************** Code End ******************************************************

mod_aWord_WriteFieldList_2NewDoc_s4p

standard module

CALLS procedures in 

Option Compare Database 
Option Explicit 

'module: mod_aWord_WriteFieldList_2NewDoc_s4p
'*************** Code Start ***************************************************
' Purpose  : List Field information for ActiveDocument in Word
'              to a new Word document using Microsoft Access
' Author   : crystal (strive4peace)
' Code List: https://msaccessgurus.com/code.htm
' This tool: https://msaccessgurus.com/tool/aWord_ListFields.htm
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'                              module variables
'--------------------------------------------------------------------------------
Dim mStartTimer As Single _ 
   ,mDtmStart As Date 
   
'-------------------------------------------------------------------------------
'                        aWord_WriteFieldList_2NewDoc_s4p
'-------------------------------------------------------------------------------
Public Sub aWord_WriteFieldList_2NewDoc_s4p() 
's4p 250405, 250413

   '--------------------------- customize
   'True = watch where Word is as it is creating the document
   'False runs twice as fast (still slow if there are lots of fields)
   Const pbWatch As Boolean = True 
   '---------------------------
      
   'CLICK HERE
   '  PRESS F5 to RUN!

   'CALL
   
   '  StartTime
   '  EndTime
   '  GetStoryType
   '  WordTableBorders_s4p
   
   '     bas_PleaseWait
   '  PleaseWaitShow
   '  PleaseWaitClose
   '  PleaseWaitMsg
   '  GetElapsedTime
   
   On Error GoTo Proc_Err 
   
   '----- dimension object variables
   'early binding
'   Dim oWord As Word.Application
'   Dim oDoc As Word.Document
'   Dim oSummaryDoc As Word.Document _
'      , oRange As Word.Range _
'      , oRangeStart As Word.Range _
'      , oRangeHeader As Word.Range _
'      , oTable As Word.Table
'   Dim oField As Word.Field
'   Dim oStory As Word.Range
   
   'late binding
   Dim oWord As Object 
   Dim oDoc As Object 
   Dim oSummaryDoc As Object _ 
      ,oRange As Object _ 
      ,oRangeStart As Object _ 
      ,oRangeHeader As Object _ 
      ,oTable As Object 
   Dim oField As Object 
   Dim oStory As Object 

   '----- dimension scalar variables
   Dim nStoryType As Long  'WdStoryType
   
   Dim sMsg As String _ 
      ,sMsg2 As String _ 
      ,sPathFile As String _ 
      ,sFieldCode As String _ 
      ,sFld As String _ 
      ,sFormat As String _ 
      ,sParam As String _ 
      ,sSwitch As String _ 
      ,nCountField As Long _ 
      ,nCountStory As Long _ 
      ,nOrdr As Long _ 
      ,nStart As Long _ 
      ,nEnd As Long _ 
      ,nPage As Long _ 
      ,nPages As Long _ 
      ,nPageLastField As Long _ 
      ,nSection As Long _ 
      ,iPos As Integer _ 
      ,vStoryTypes As Variant 

   Dim nRows As Long _ 
      ,nCols As Long _ 
      ,nRow As Long _ 
      ,i As Integer _ 
      ,n As Long _ 
      ,sTemp As String 
'      , iButton As Integer _

'   Dim asFieldCode() As String
   
   '-------------------------------------- StartTime, PleaseWait
   sMsg =  "document field information for the active document in Word"
   Call StartTime(sMsg) 
   Call PleaseWaitShow(sMsg) 
      
   '-------------------------------------- Initialize Word
   On Error Resume Next 
   
   Set oWord = GetObject(, "Word.Application") 
   On Error GoTo Proc_Err 
   If oWord Is Nothing Then 
      MsgBox  "Word isn't open" _ 
            & vbCrLf & vbCrLf &  "Can't " & sMsg _ 
            ,, "Can't get Word Object"
      GoTo Proc_Exit
   End If 
   
   'still here -- see if any docs open
   With oWord 
      If Not .Documents.Count > 0 Then 
         MsgBox  "No ActiveDocument in Word" _ 
            & vbCrLf & vbCrLf &  "Can't " & sMsg _ 
            ,, "Can't get Word ActiveDocument"
         GoTo Proc_Exit 
      End If 
      Set oDoc = .ActiveDocument 
   End With 
   
   '-------------------------------------- variables
   nPage = 0 
   nPageLastField = -1 
   nOrdr = 0 
   nCountField = 0 
   nCountStory = 0 
   vStoryTypes = Null 
   For Each oStory In oDoc.StoryRanges 
      n = oStory.Fields.Count 
      If n > 0 Then 
         nCountField = nCountField + n 
         nCountStory = nCountStory + 1 
         vStoryTypes = (vStoryTypes +  ", ") _ 
            & GetStoryType(oStory.StoryType) 
      End If 
   Next oStory 
   
   With oDoc 

      If Not nCountField > 0 Then 
         MsgBox  "No fields in " & .Name _ 
         ,, "no fields to list"
         GoTo Proc_Exit 
      End If 
      
      'number of pages in document
      nPages = .Content.Information(3)  'wdActiveEndPageNumber
      

   End With 
   
   sMsg =  "get path\file for new Summary Word document"
   Call PleaseWaitMsg(sMsg) 

   '------------------------------ path\file oSummaryDoc
   
   sPathFile = oDoc.FullName 
   iPos = InStrRev(sPathFile, "\") 
   sPathFile = Left(sPathFile,iPos) _ 
      &  "ListFields_" _ 
      & Mid(sPathFile,iPos + 1) 
   
   'call GetUniqueFilename_s4p
   sPathFile = GetUniqueFilename_s4p( _ 
      sPathFile, "yymmdd_hhnn") 
   
   Set oSummaryDoc = oWord.Documents.Add 
   
   sMsg =  "creating Summary document: " _ 
      & vbCrLf & vbCrLf & sPathFile 
   Call PleaseWaitMsg 
   
   'oWord.Visible = True
   If pbWatch Then oDoc.Activate 

   'make it Landscape, set margins
   With oSummaryDoc.PageSetup 
      .Orientation = 1  'wdOrientLandscape
      .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 
   
   'save document with constructed name
   oSummaryDoc.SaveAs sPathFile 
   sPathFile = oSummaryDoc.FullName 
      
   'get ready to write
   Set oRangeStart = oSummaryDoc.Content 
   oRangeStart.Collapse 0  'wdCollapseEnd
   
   'Heading 1, Heading 2
   With oSummaryDoc.Content 

      'Title
      .InsertAfter  "Field List, " _ 
         & Format(Now(), "yymmdd hh:nn ") 
      'style as Heading 1
      .Paragraphs(oSummaryDoc.Paragraphs.Count).Style _ 
            = oSummaryDoc.Styles( "Heading 1") 
      .InsertParagraphAfter 
            
      .InsertAfter  "source file: " & oDoc.FullName 
      .InsertParagraphAfter 
      
      .InsertAfter  "this documentation file: " & oSummaryDoc.FullName 
      
      .InsertParagraphAfter 
                  
      'style as Heading 3
      .Paragraphs(.Paragraphs.Count - 1).Style _ 
            = oSummaryDoc.Styles( "Heading 3") 
      .InsertParagraphAfter 
      
      sTemp = Format(nCountField, "#,##0") &  " field" _ 
         & IIf(nCountField <> 1, "s", "") _ 
         & IIf(nCountStory > 1,_ 
            " in " & nCountStory &  " stories: " & vStoryTypes _ 
            , "") 

      .InsertAfter sTemp 
      
      If pbWatch Then 
         ' change selection
         'goto the end of the document
         'wdStory=6, wdMove=0
         oWord.Selection.EndKey unit:=6  ', Extend:=0
      End If 

   End With  'oSummaryDoc.Content
   
   With oSummaryDoc 
      'range for table, put at end
      Set oRange = .Content 
      oRange.Collapse Direction:=0  'wdCollapseEnd
   
      'insert table
      nCols = 8  'number of columns
      'NumRows: number of fields + 1 for header row
      Set oTable = .Tables.Add( _ 
         Range:=oRange _ 
         ,NumRows:=nCountField + 1 _ 
         ,NumColumns:=nCols _ 
         ) 
   End With  'oSummaryDoc
      
   'customize and write table
   With oTable 
   
      'dont allow rows to break
      .Rows.AllowBreakAcrossPages = False 
      
      'Vertical Alignment for each cell is Top
      ' 0=wdCellAlignVerticalTop
      .Range.Cells.VerticalAlignment = 0 
      
      'heading row
      .Rows(1).HeadingFormat = True 
      .Cell(1,1).Range.Text =  "Page"
      
      .Cell(1,2).Range.Text =  "idx"
      .Cell(1,3).Range.Text =  "Start"
      .Cell(1,4).Range.Text =  "Len"
      
      .Cell(1,5).Range.Text =  "Field"
      .Cell(1,6).Range.Text =  "Parameter(s)"
      .Cell(1,7).Range.Text =  "Switch(es)"
      .Cell(1,8).Range.Text =  "Result"
      
      For i = 1 To 4 
         .Cell(1,i).Range.ParagraphFormat.Alignment = 2  'wdAlignParagraphRight
      Next i  'format
      
      nRow = 1  'header row just written
      
      '------------------------------------ Loop, Write


'story type?

      For Each oStory In oDoc.StoryRanges 
         nStoryType = oStory.StoryType 
         
         If nStoryType <> 1 Then 
            'GoTo NextStory
            sMsg2 = sMsg & vbCrLf _ 
               & GetStoryType(nStoryType) &  " fields"
         End If 
         
'            Select Case nStoryType
'            Case 1 ' wdMainTextStory
'            Case Else
'            End Select
   
        'loop each field in document
         For Each oField In oStory.Fields   '   oDoc.Fields
         
            nRow = nRow + 1 
            nOrdr = nOrdr + 1 

            If pbWatch Then 
               .Cell(nRow,1).Select  'so user can see what's being written
            End If 
            
            sFld =  ""
            sSwitch =  ""
            sParam =  ""
            sFormat =  ""
   '          .Index
   '          .Kind
   '          .Result.End
   
            sFieldCode = oField.Code 
            nPage = oField.Result.Information(3)  'wdActiveEndPageNumber
            nSection = oField.Result.Information(2)  'wdActiveEndSectionNumber
                   
            If nStoryType <> 1 Then 
               
               sTemp = GetStoryType(nStoryType,True) &  "," _ 
                  & nSection &  "," & nPage 
               
               .Cell(nRow,1).Range.Text = sTemp 
'               If Len(sTemp) > 5 Then
'                  .Cell(nRow, 1).Range.Font.Size = 8
'               End If
            Else 
               .Cell(nRow,1).Range.Text = nPage  'page
            End If 
            
            .Cell(nRow,2).Range.Text = oField.Index  ' nOrdr 'order
            .Cell(nRow,3).Range.Text = oField.Result.Start  'Format(.Result.Start, "#,##0") 'Start
            .Cell(nRow,4).Range.Text = oField.Result.Characters.Count  'Format(.Result.Characters.Count, "#,##0") 'Length
   
            'split Field, Parameters, Switches
            iPos = InStr(sFieldCode, "\") 
            If iPos > 0 Then 
               sFld = Trim(Left(sFieldCode,iPos - 1)) 
               sSwitch = Mid(sFieldCode,iPos)  'Switch(es)
               'add line breaks if >1 switch
               sSwitch = Replace(sSwitch, " \", " " & Chr(10) &  "\") 
            Else 
               sFld = Trim(sFieldCode) 
            End If 
      
            iPos = InStr(sFld, " ") 
            If iPos > 0 Then 
               sParam = Trim(Mid(sFld,iPos + 1))  'parameter(s)
               sFld = Trim(Left(sFld,iPos - 1))  'field
            End If 
      
   '            ' look for Format
   '            If InStr(sFieldCode, "\@") > 0 Then
   '               'has a format switch
   '               'split field code into array at space \
   '               asFieldCode = Split(sFieldCode, " \")
   '
   '               'skip first item
   '               For i = LBound(asFieldCode) + 1 To UBound(asFieldCode)
   '
   '                  sTemp = Trim(asFieldCode(i))
   '
   '                  If sTemp <> "" Then
   '                     'look for format
   '                     If Left(sTemp, 1) = "@" Then
   '                        sFormat = Trim(Mid(sTemp, 2))
   '                        'strip quotes?
   '                        Exit For 'quit looking
   '                     End If
   '                  End If 'has a value
   '
   '               Next i ' asFieldCode
   '            End If 'has Format
   
            'keep track of when page changes
            '  , update PleaseWait form
            If nPage <> nPageLastField Then 
               Call PleaseWaitMsg( _ 
                  IIf(nStoryType = 1,sMsg,sMsg2) _ 
                  & vbCrLf & vbCrLf &  " page " & nPage _ 
                  &  " of " & nPages _ 
                  ) 
               nPageLastField = nPage 
            End If 
   
            .Cell(nRow,5).Range.Text = sFld  'Field
            .Cell(nRow,6).Range.Text = sParam  'Parameter(s)
            .Cell(nRow,7).Range.Text = sSwitch  ''Switch(es)
            .Cell(nRow,8).Range.Text = oField.Result  'Result
   
            For i = 1 To 4 
               .Cell(nRow,i).Range.ParagraphFormat.Alignment = 2  'wdAlignParagraphRight
            Next i  'format
            
         Next oField 
      
NextStory: 
      Next oStory 
   
      Call PleaseWaitMsg(sMsg & vbCrLf & vbCrLf _ 
         &  "best-fit and format columns") 

      'best-fit columns
      .Columns.AutoFit 
      
      'format
      With .Range.ParagraphFormat 
         .SpaceAfter = 0 
         .SpaceBefore = 0 
      End With  'ParagraphFormat
      
      'keep with at least one row
      With .Cell(1,1).Range.ParagraphFormat 
        .KeepTogether = True 
        .KeepWithNext = True 
      End With 
    
   End With  'oTable
   
    With oSummaryDoc.Content 
       'go to end of document -- another way, using Content
       .MoveEnd unit:=6  'wdStory
           
       'write how many fields were found
       .InsertAfter  "** " _ 
          & Format(nCountField, "#,##0") _ 
             &  " Field" _ 
               & IIf(nRows <> 1, "s ", "") &  " listed"
         'add final line break
         .InsertParagraphAfter 
         
         'goto top
         .MoveStart unit:=6 
         
    End With  'oSummaryDoc.Content
    
'   If pbWatch Then
'      ' change selection
'      'goto the top of the document
'      'wdStory=6, wdMove=0
'      oWord.Selection.MoveStart unit:=6
'   End If
'
   
   '------------------------- sort?
'   Call PleaseWaitMsg(sMsg & vbCrLf & vbCrLf _
      &  "sort table by whatever?") 
   
   
   'add table borders
   Call PleaseWaitMsg(sMsg & vbCrLf & vbCrLf _ 
      &  "add table borders") 
   Call WordTableBorders_s4p(oTable) 
       
Write_Header: 

   Call PleaseWaitMsg(sMsg & vbCrLf & vbCrLf _ 
      &  "writing Document Header") 
    
   'add header to oSummaryDoc
   Set oRangeHeader = oSummaryDoc.Sections(1).Headers(1).Range  '
   
   With oRangeHeader  ' oSummaryDoc.Sections(1).Headers(1).Range
      'wdFieldEmpty = -1
         .Fields.Add Range:=.Characters.Last _ 
            ,Type:=-1 _ 
            ,Text:= "STYLEREF  ""Heading 1"" " _ 
            ,PreserveFormatting:=False 
         
         'then a TAB and text on right
         '  oRangeHeader
         .InsertAfter Chr(9) &  "strive4peace, " _ 
            & Format(Date, "d-mmm-yy, ddd") _ 
            &  ", page "

         'then PAGE/NUMPAGES
         '33=wdFieldPage
         'wdFieldEmpty = -1
         .Fields.Add Range:=.Characters.Last _ 
            ,Type:=-1 _ 
            ,Text:= "PAGE" ' _
            ,PreserveFormatting:=True 
         .InsertAfter Text:= "/"
         '26=wdFieldNumPages
         .Fields.Add Range:=.Characters.Last _ 
            ,Type:=-1 _ 
            ,Text:= "NUMPAGES" ' _
            ,PreserveFormatting:=True 
      
         'add border line below
         With .Borders(-3)  'wdBorderBottom =-3
            .LineStyle = 1   'wdLineStyleSingle=1
            .LineWidth = 8  'wdLineWidth100pt=8
            .Color = RGB(75,75,75)  'dark gray
         End With 
         With .ParagraphFormat 
            'clear current tabstops
            .TabStops.ClearAll 
            'set right-aligned Tab Stop at 7.5 inches
            '72 points/inch
            '2=wdAlignTabRight
            '0=wdTabLeaderSpaces
            .TabStops.Add _ 
               Position:=10 * 72 _ 
               ,Alignment:=2 _ 
               ,Leader:=0 
            
            '0=Left, 1=Center, 2=Right
            .Alignment = 0  '0=wdAlignParagraphLeft
            'space after paragraph = 6 points
            .SpaceAfter = 6 
         End With 
         .Fields.Update 
   End With  'header
   
   'save and close
   With oSummaryDoc 
      .Save 
      .Close 
   End With 
       
   sMsg =  "Done listing Fields to a new Word document" _ 
      & Format(Now, ", yymmdd hh:nn") _ 
      & vbCrLf &  "   " & sPathFile 
   
   Debug.Print  "******** " & sMsg 
      
   Call PleaseWaitMsg(sMsg) 
   
   'release object variables for Summary doc
   
   Set oTable = Nothing 
   Set oRange = Nothing 
   Set oRangeStart = Nothing 
   Set oRangeHeader = Nothing 
   Set oSummaryDoc = Nothing 

   'vbOK=1,vbYesNo=4
   sMsg =  "Documented " _ 
      & Format(nCountField, "#,##0") _ 
      &  " fields" _ 
      & vbCrLf & GetElapsedTime() 
   Debug.Print sMsg 

   Call PleaseWaitClose 
      
   sMsg = sMsg & vbCrLf &  "open " & sPathFile &  "?"
   
   If MsgBox(sMsg,vbYesNo, "done") = vbYes Then 
      'open document in new instance
      Application.FollowHyperlink sPathFile 
   End If 
  
Proc_Exit: 
   On Error Resume Next 
   
   Call EndTime 
   Call PleaseWaitClose 
   
   Set oTable = Nothing 
   Set oRange = Nothing 
   Set oRangeStart = Nothing 
   Set oRangeHeader = Nothing 
   Set oSummaryDoc = Nothing 
   
   Set oField = Nothing 
   Set oDoc = Nothing 
   Set oWord = Nothing 

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

   Resume Proc_Exit 
   Resume 
   
End Sub 


'-------------------------------------------------------------------------------
'                        StartTime, EndTime
'-------------------------------------------------------------------------------
Private Sub StartTime(Optional pMsg) 
   On Error Resume Next 
   mStartTimer = Timer() 
   mDtmStart = Now() 
   DoCmd.Hourglass True 
   Debug.Print  "--- START-------------" _ 
      & pMsg &  " ----- " & CStr(mDtmStart) 
End Sub 

Private Sub EndTime() 
'...240110
   'call in Exit code. ReportElapsedTime may have beenused to show message
   On Error Resume Next 
   DoCmd.Hourglass False 
   SysCmd acSysCmdClearStatus 
   Debug.Print  "End " & Format(Now(), "h:nn") &  " ----"
End Sub 

'-------------------------------------------------------------------------------
'                        WordTableBorders_s4p
'-------------------------------------------------------------------------------
'Object is Word.Table
Private Sub WordTableBorders_s4p(oTable As Object _ 
   ,Optional pbHeaderRow As Boolean = True _ 
   ) 
's4p 170811, 240818 pbHeaderRow
   Dim i As Integer 
   With oTable 
      For i = 1 To 6 
         'wdBorderTop =-1
         'wdBorderLeft = -2
         'wdBorderBottom =-3
         'wdBorderRight= -4
         'wdBorderHorizontal = -5
         'wdBorderVertical = -6
         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 
   
   'mark heading row
   If pbHeaderRow <> False Then   'True
      With oTable.Rows(1) 
         'Heading Row
         .HeadingFormat = True 
         'Shading for header row
         .Shading.BackgroundPatternColor = RGB(232,232,232) 
         'change main borders to black for first row
         For i = 1 To 4 
            With .Borders(-i) 
               .Color = 0        'wdColorBlack = 0
            End With 
         Next i 
      End With   'first row
   End If 
   
   'Not used:
'      'wdLineStyleNone = 0
'      .Borders(-7).LineStyle = 0 'wdBorderDiagonalDown =-7
'      .Borders(-8).LineStyle = 0 'wdBorderDiagonalUp =-8
End Sub 
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'           GetStoryType
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Private Function GetStoryType( _ 
   pWdStoryType As Long _ 
   ,Optional bAbbreviate As Boolean = False _ 
   ) As String 
'230826 s4p, 250412
   Select Case pWdStoryType 
      Case 1: GetStoryType = IIf(bAbbreviate, "Main", "Main text") 
      Case 2: GetStoryType = IIf(bAbbreviate, "FN", "Footnote") 
      Case 3: GetStoryType = IIf(bAbbreviate, "EN", "Endnote") 
      Case 4: GetStoryType = IIf(bAbbreviate, "C", "Comment") 
      Case 5: GetStoryType = IIf(bAbbreviate, "TF", "Text frame") 
      Case 6: GetStoryType = IIf(bAbbreviate, "HE", "Header Even pages") 
      Case 7: GetStoryType = IIf(bAbbreviate, "H", "Header Primary") 
      Case 8: GetStoryType = IIf(bAbbreviate, "FE", "Footer Even pages") 
      Case 9: GetStoryType = IIf(bAbbreviate, "F", "Footer Primary") 
      Case 10: GetStoryType = IIf(bAbbreviate, "H1", "Header 1st page") 
      Case 11: GetStoryType = IIf(bAbbreviate, "F1", "Footer 1st page") 
      Case 12: GetStoryType = IIf(bAbbreviate, "FNS", "Footnote separator") 
      Case 13: GetStoryType = IIf(bAbbreviate, "FNC", "Footnote continuation separator") 
      Case 14: GetStoryType = IIf(bAbbreviate, "FNN", "Footnote continuation notice") 
      Case 15: GetStoryType = IIf(bAbbreviate, "ENS", "Endnote separator") 
      Case 16: GetStoryType = IIf(bAbbreviate, "ENC", "Endnote continuation separator") 
      Case 17: GetStoryType = IIf(bAbbreviate, "ENN", "Endnote continuation notice") 
      Case Else: GetStoryType = pWdStoryType 
   End Select   'pWdStoryType
End Function 
'-------------------------------------------------------------------------------
'                        GetElapsedTime
'-------------------------------------------------------------------------------
Private Function GetElapsedTime() As String 
 'strive4peace 250404
   On Error Resume Next 
   Dim sMsg As String _ 
      ,nEndTime As Date _ 
      ,dbSeconds As Double 
   nEndTime = Now() 
   dbSeconds = Timer - mStartTimer 
   If dbSeconds < 0 Then 
      dbSeconds = Timer + (24 * 60 * 60) - mStartTimer 
   End If 
   
   If dbSeconds > 60 * 60 Then 
      sMsg = Format(dbSeconds / 60 / 60, "#,###.##") &  " hours"
   ElseIf dbSeconds > 60 Then 
      sMsg = Format(dbSeconds / 60, "#,###.##") &  " minutes"
   Else 
      sMsg = Format(dbSeconds, "#,###.##") &  " seconds"
   End If 
   
   sMsg =  "Start Time: " _ 
      & Format(mDtmStart, "hh:nn:ss") _ 
      & vbCrLf _ 
      &  "  End Time: " & Format(nEndTime, "hh:nn:ss") _ 
      & vbCrLf _ 
      &  "     Elapsed Time: " & sMsg 
    
   GetElapsedTime = sMsg 
   
End Function 
'*************** Code End ******************************************************

bas_PleaseWait

Helper code for PleaseWait form 

'module name: bas_PleaseWait
' 5-17-08, 241104
'*************** Code Start ***************************************************
' Purpose  : Helper code for PleaseWait form
' Author   : crystal (strive4peace)
' website  : https:\\msaccessgurus.com
' LICENSE  :
'   You may freely use and share this code, but not sell it.
'   Keep attribution. Mark your changes. Use at your own risk.
'--------------------------------------------------------------------------------
'------------------  open the PleaseWait form
Public Sub PleaseWaitShow( _ 
      Optional pMsg As String =  "PleaseWait...") 
   DoCmd.OpenForm  "f_PleaseWait"
   Forms!f_PleaseWait.Label_Msg.Caption = pMsg 
   Forms!f_PleaseWait.Repaint 
End Sub 
'
'------------------  close the PleaseWait form
Public Sub PleaseWaitClose() 
   If CurrentProject.AllForms( "f_PleaseWait").IsLoaded Then 
      DoCmd.Close acForm, "f_PleaseWait",acSaveNo 
   End If 
End Sub 
'
'------------------  change the PleaseWait message
Public Sub PleaseWaitMsg( _ 
      Optional pMsg As String =  "PleaseWait...") 
On Error Resume Next 
   Forms!f_PleaseWait.Label_Msg.Caption = pMsg 
   Forms!f_PleaseWait.Repaint 
End Sub 
'*************** Code End *****************************************************

mod_GetUniqueFilename_s4p

code for Fx_GetUniqueFilename.htm

' Code was generated with colors using the free Color Code add-in for Access

Goto Top  

Reference

Microsoft Learn

Document object (Word)

Field object (Word)

Field.Code property (Word)

Range.Information property (Word)

StoryRanges Object(Word)

WdStoryType enumeration (Word)

Goto Top  

Back Story

When you're controlling field content in a Word document, it's helpful to see what's been set up.

Updated the code to loop through all the story ranges instead of only documenting fields in the main body. Also got rid of the array and removed formatting from Start position and Length so you can sort by those columns if you want to.

Goto Top  

Share with others

here's the link to copy:

https://msaccessgurus.com/tool/aWord_ListFields.htm

Goto Top