VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "MigrationAnalyser" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False '************************************************************************* ' ' Licensed to the Apache Software Foundation (ASF) under one ' or more contributor license agreements. See the NOTICE file ' distributed with this work for additional information ' regarding copyright ownership. The ASF licenses this file ' to you under the Apache License, Version 2.0 (the ' "License"); you may not use this file except in compliance ' with the License. You may obtain a copy of the License at ' ' http://www.apache.org/licenses/LICENSE-2.0 ' ' Unless required by applicable law or agreed to in writing, ' software distributed under the License is distributed on an ' "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY ' KIND, either express or implied. See the License for the ' specific language governing permissions and limitations ' under the License. ' '************************************************************************* Option Explicit 'Class variables Private Enum HFIssueType hfInline hfShape hfFrame End Enum Private Enum HFIssueLocation hfHeader hffooter End Enum Private Type ShapeInfo top As Single Height As Single End Type Private Type FrameInfo Height As Single VerticalPosition As Single End Type Private mAnalysis As DocumentAnalysis Private mOdd As Boolean Private mbFormFieldErrorLogged As Boolean Private mbRefFormFieldErrorLogged As Boolean '***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue ' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to: ' word_res.bas and common_res.bas ' ' For complete list of all CID_... for Issue Categories(IssueID) and ' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to: ' ApplicationSpecific.bas and CommonMigrationAnalyser.bas ' ' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues Sub Analyze_SKELETON() On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_SKELETON" Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_VBA_MACROS 'Issue Category .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String .locationXML = .CXMLLocationDocument 'Non localised XML location .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND ' Add as many Attribute Value pairs as needed ' Note: following must always be true - Attributes.Count = Values.Count .Attributes.Add "AAA" .Values.Add "foobar" ' Use AddIssueDetailsNote to add notes to the Issue Details if required ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ ' Optional preStr As String = RID_STR_COMMON_NOTE_PRE) ' Where preStr is prepended to the output, with "Note" as the default AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST 'Only put this in if you have a preparation function added for this issue in CommonPreparation 'or Preparation - NUll can be replaced with any variant if you want to pass info to the Prepare fnc Call DoPreparation(mAnalysis, myIssue, "", Null, Null) mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _ mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _ startDir As String, storeToDir As String, fso As FileSystemObject) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "DoAnalyse" mAnalysis.name = fileName Dim aDoc As Document Dim bUnprotectError As Boolean mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES mbFormFieldErrorLogged = False mbRefFormFieldErrorLogged = False 'Turn off any AutoExce macros before loading the Word doc On Error Resume Next ' Ignore errors on setting WordBasic.DisableAutoMacros 1 On Error GoTo HandleErrors Dim myPassword As String myPassword = GetDefaultPassword 'Always skip password protected documents 'If IsSkipPasswordDocs() Then Dim aPass As String If myPassword <> "" Then aPass = myPassword Else aPass = "xoxoxoxoxo" End If On Error Resume Next Set aDoc = Documents.Open(fileName, False, False, False, _ aPass, aPass, False, aPass, aPass, wdOpenFormatAuto, _ msoEncodingAutoDetect, False) If Err.Number = 5408 Then ' if password protected, try open readonly next Set aDoc = Documents.Open(fileName, False, True, False, _ aPass, aPass, False, aPass, aPass, wdOpenFormatAuto, _ msoEncodingAutoDetect, False) End If If Err.Number = 5408 Then HandleProtectedDocInvalidPassword mAnalysis, _ "User entered Invalid Document Password, further analysis not possible", fso Analyze_Password_Protection True, False GoTo FinalExit ElseIf (Err.Number <> 0) Then GoTo HandleErrors End If On Error GoTo HandleErrors If aDoc Is Nothing Then GoTo FinalExit 'Do Analysis Analyze_Password_Protection aDoc.HasPassword, aDoc.WriteReserved Analyze_Document_Protection aDoc If aDoc.ProtectionType <> wdNoProtection Then If myPassword <> "" Then aDoc.Unprotect (myPassword) Else aDoc.Unprotect End If End If 'Set Doc Properties SetDocProperties mAnalysis, aDoc, fso ContinueFromUnprotectError: Analyze_Tables_TablesInTables aDoc Analyze_Tables_Borders aDoc Analyze_TOA aDoc If Not bUnprotectError Then Analyze_FieldAndFormFieldIssues aDoc End If Analyze_OLEEmbedded aDoc Analyze_MailMerge_DataSource aDoc Analyze_Macros mAnalysis, userFormTypesDict, aDoc 'Analyze_Numbering aDoc, mAnalysis 'Analyze_NumberingTabs aDoc, mAnalysis ' Doc Preparation only ' Save document with any prepared issues under \prepared\ If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then Dim preparedFullPath As String preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso) If preparedFullPath <> "" Then If fso.FileExists(preparedFullPath) Then fso.DeleteFile preparedFullPath, True End If If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then aDoc.SaveAs preparedFullPath End If End If End If 'DebugMacroInfo FinalExit: If Not aDoc Is Nothing Then 'If Not IsEmpty(aDoc) Then aDoc.Close (False) End If Set aDoc = Nothing Exit Sub HandleErrors: ' MsgBox currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source ' Handle Password error on Doc Open, Modify and Cancel If Err.Number = 5408 Or Err.Number = 4198 Then WriteDebug currentFunctionName & " : " & fileName & ": " & _ "User entered Invalid Document Password - " & Err.Number & " " & Err.Description & " " & Err.Source HandleProtectedDocInvalidPassword mAnalysis, _ "User entered Invalid Document Password, further analysis not possible", fso Resume FinalExit ElseIf Err.Number = 5485 Then ' Handle Password error on Unprotect Doc WriteDebug currentFunctionName & " : " & fileName & ": " & _ "User entered Invalid Document Part Password, Analysis of doc will continue but will skip analysis of:" & _ "Forms, Comments, Headers & Footers and Table cell spanning issues - " & Err.Number & " " & Err.Description & " " & Err.Source HandleProtectedDocInvalidPassword mAnalysis, _ "User entered Invalid Document Part Password, Analysis of doc will continue but will skip analysis of:" & vbLf & _ "Forms, Comments, Headers & Footers and Table cell spanning issues", fso bUnprotectError = True 'wdAllowOnlyComments, wdAllowOnlyFormFields, wdAllowOnlyRevisions Resume ContinueFromUnprotectError End If mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN WriteDebug currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub DebugMacroInfo() MsgBox "TotalNumLines: " & mAnalysis.MacroTotalNumLines & vbLf & _ "NumUserForms: " & mAnalysis.MacroNumUserForms & vbLf & _ "NumUserFormControls: " & mAnalysis.MacroNumUserFormControls & vbLf & _ "NumUserFormControlTypes: " & mAnalysis.MacroNumUserFormControlTypes & vbLf & _ "NumExternalRefs: " & mAnalysis.MacroNumExternalRefs & vbLf & _ "MacroNumFieldsUsingMacros: " & mAnalysis.MacroNumFieldsUsingMacros & vbLf & _ "NumOLEControls: " & mAnalysis.MacroNumOLEControls & vbLf & _ "MacroOverallClass: " & getDocOverallMacroClassAsString(mAnalysis.MacroOverallClass) End Sub Sub SetDocProperties(docAnalysis As DocumentAnalysis, doc As Document, fso As FileSystemObject) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "SetProperties" Dim f As File Set f = fso.GetFile(docAnalysis.name) docAnalysis.PageCount = doc.ComputeStatistics(wdStatisticPages) docAnalysis.Accessed = f.DateLastAccessed On Error Resume Next 'Some apps may not support all props docAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version 'docAnalysis.Application = doc.BuiltinDocumentProperties(wdPropertyAppName) 'If InStr(docAnalysis.Application, "Microsoft") = 1 Then ' docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2) 'End If 'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then ' docAnalysis.Application = docAnalysis.Application & " " & Application.Version 'End If docAnalysis.Created = _ doc.BuiltInDocumentProperties(wdPropertyTimeCreated) docAnalysis.Modified = _ doc.BuiltInDocumentProperties(wdPropertyTimeLastSaved) docAnalysis.Printed = _ doc.BuiltInDocumentProperties(wdPropertyTimeLastPrinted) docAnalysis.SavedBy = _ doc.BuiltInDocumentProperties(wdPropertyLastAuthor) docAnalysis.Revision = _ val(doc.BuiltInDocumentProperties(wdPropertyRevision)) docAnalysis.Template = _ fso.GetFileName(doc.BuiltInDocumentProperties(wdPropertyTemplate)) FinalExit: Set f = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub 'Limitation: Detect first level table in tables, does not detect further nesting 'Can do so if required Sub Analyze_Tables_TablesInTables(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Tables_TablesInTables" Dim myTopTable As Table Dim myInnerTable As Table Dim myIssue As IssueInfo For Each myTopTable In currDoc.Tables For Each myInnerTable In myTopTable.Tables Dim logString As String Dim myRng As Range Dim startpage As Long Dim startRow As Long Dim StartColumn As Long Dim details As String Set myIssue = New IssueInfo Set myRng = myInnerTable.Range myRng.start = myRng.End startpage = myRng.Information(wdActiveEndPageNumber) startRow = myRng.Information(wdStartOfRangeRowNumber) StartColumn = myRng.Information(wdStartOfRangeColumnNumber) With myIssue .IssueID = CID_TABLES .IssueType = RID_STR_WORD_ISSUE_TABLES .SubType = RID_STR_WORD_SUBISSUE_NESTED_TABLES .Location = .CLocationPage .SubLocation = startpage .IssueTypeXML = CSTR_ISSUE_TABLES .SubTypeXML = CSTR_SUBISSUE_NESTED_TABLES .locationXML = .CXMLLocationPage .Attributes.Add RID_STR_WORD_ATTRIBUTE_OUTER_TABLE .Values.Add myTopTable.Rows.count & "x" & myTopTable.Columns.count .Attributes.Add RID_STR_WORD_ATTRIBUTE_INNER_TABLE .Values.Add myInnerTable.Rows.count & "x" & myInnerTable.Columns.count .Attributes.Add RID_STR_WORD_ATTRIBUTE_START_ROW .Values.Add startRow .Attributes.Add RID_STR_WORD_ATTRIBUTE_START_COL .Values.Add StartColumn AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NESTED_TABLE_WILL_BE_LOST mAnalysis.IssuesCountArray(CID_TABLES) = _ mAnalysis.IssuesCountArray(CID_TABLES) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing Set myRng = Nothing Next Next Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_Document_Protection(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Document_Protection" If currDoc.ProtectionType = wdNoProtection Then Exit Sub End If Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_COMMON_SUBISSUE_DOCUMENT_PARTS_PROTECTION .Location = .CLocationDocument .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_DOCUMENT_PARTS_PROTECTION .locationXML = .CXMLLocationDocument .Attributes.Add RID_STR_WORD_ATTRIBUTE_PROTECTION Select Case currDoc.ProtectionType Case wdAllowOnlyComments .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_COMMENTS Case wdAllowOnlyFormFields .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_FORM_FIELDS Case wdAllowOnlyRevisions .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_REVISIONS Case Else .Values.Add RID_STR_COMMON_ATTRIBUTE_UNKNOWN End Select mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_Password_Protection(bHasPassword As Boolean, bWriteReserved As Boolean) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Password_Protection" Dim myIssue As IssueInfo If bHasPassword Or bWriteReserved Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_COMMON_SUBISSUE_PASSWORDS_PROTECTION .Location = .CLocationDocument .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_PASSWORDS_PROTECTION .locationXML = .CXMLLocationDocument If bHasPassword Then .Attributes.Add RID_STR_WORD_ATTRIBUTE_PASSWORD_TO_OPEN .Values.Add RID_STR_WORD_ATTRIBUTE_SET End If If bWriteReserved Then .Attributes.Add RID_STR_WORD_ATTRIBUTE_PASSWORD_TO_MODIFY .Values.Add RID_STR_WORD_ATTRIBUTE_SET End If mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_OLEEmbedded(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_OLEEmbedded" ' Handle Inline Shapes Dim aILShape As InlineShape For Each aILShape In currDoc.InlineShapes Analyze_OLEEmbeddedSingleInlineShape aILShape Next aILShape ' Handle Shapes Dim aShape As Shape For Each aShape In currDoc.Shapes Analyze_OLEEmbeddedSingleShape mAnalysis, aShape, _ Selection.Information(wdActiveEndPageNumber) Analyze_Lines mAnalysis, aShape, _ Selection.Information(wdActiveEndPageNumber) Analyze_Transparency mAnalysis, aShape, _ Selection.Information(wdActiveEndPageNumber) Analyze_Gradients mAnalysis, aShape, _ Selection.Information(wdActiveEndPageNumber) Next aShape Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub 'WdInlineShapeType constants: 'wdInlineShapeEmbeddedOLEObject, wdInlineShapeHorizontalLine, wdInlineShapeLinkedOLEObject, 'wdInlineShapeLinkedPicture, wdInlineShapeLinkedPictureHorizontalLine, wdInlineShapeOLEControlObject, 'wdInlineShapeOWSAnchor, wdInlineShapePicture, wdInlineShapePictureBullet, 'wdInlineShapePictureHorizontalLine, wdInlineShapeScriptAnchor Sub Analyze_OLEEmbeddedSingleInlineShape(aILShape As InlineShape) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_OLEEmbeddedSingleInlineShape" Dim myIssue As IssueInfo Dim bOleObject As Boolean Dim TypeAsString As String Dim XMLTypeAsString As String Dim objName As String bOleObject = (aILShape.Type = wdInlineShapeEmbeddedOLEObject) Or _ (aILShape.Type = wdInlineShapeLinkedOLEObject) Or _ (aILShape.Type = wdInlineShapeOLEControlObject) If Not bOleObject Then Exit Sub aILShape.Select Select Case aILShape.Type Case wdInlineShapeOLEControlObject TypeAsString = RID_STR_COMMON_OLE_CONTROL XMLTypeAsString = CSTR_SUBISSUE_OLE_CONTROL Case wdInlineShapeEmbeddedOLEObject TypeAsString = RID_STR_COMMON_OLE_EMBEDDED XMLTypeAsString = CSTR_SUBISSUE_OLE_EMBEDDED Case wdInlineShapeLinkedOLEObject TypeAsString = RID_STR_COMMON_OLE_LINKED XMLTypeAsString = CSTR_SUBISSUE_OLE_LINKED Case Else TypeAsString = RID_STR_COMMON_OLE_UNKNOWN XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN End Select Set myIssue = New IssueInfo With myIssue .IssueID = CID_PORTABILITY .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY .SubType = TypeAsString .Location = .CLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .IssueTypeXML = CSTR_ISSUE_PORTABILITY .SubTypeXML = XMLTypeAsString .locationXML = .CXMLLocationPage .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) DoEvents If aILShape.Type = wdInlineShapeEmbeddedOLEObject Or _ aILShape.Type = wdInlineShapeOLEControlObject Then 'If Object is invalid can get automation server hanging Dim tmpStr As String On Error Resume Next tmpStr = aILShape.OLEFormat.Object If Err.Number = 0 Then .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE .Values.Add aILShape.OLEFormat.ProgID Else Err.Clear tmpStr = aILShape.OLEFormat.ClassType If Err.Number = 0 Then .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE .Values.Add aILShape.OLEFormat.ClassType Else .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE .Values.Add RID_STR_COMMON_NA End If End If If aILShape.Type = wdInlineShapeOLEControlObject Then mAnalysis.MacroNumOLEControls = 1 + mAnalysis.MacroNumOLEControls End If objName = aILShape.OLEFormat.Object.name If Err.Number = 0 Then .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME .Values.Add objName End If On Error GoTo HandleErrors End If If aILShape.Type = wdInlineShapeLinkedOLEObject Then .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE .Values.Add aILShape.LinkFormat.SourceFullName End If mAnalysis.IssuesCountArray(CID_PORTABILITY) = _ mAnalysis.IssuesCountArray(CID_PORTABILITY) + 1 End With mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebugLevelTwo currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub 'Appears to be picked up by other OLE analysis code - the Shapes are actually field codes 'So I get double reporting if I use this as well. Sub Analyze_OLEFields(myField As Field) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_OLEFields" Dim myIssue As IssueInfo Dim bOleObject As Boolean Dim TypeAsString As String Dim XMLTypeAsString As String bOleObject = (myField.Type = wdFieldOCX) If Not bOleObject Then Exit Sub myField.Select Select Case myField.Type Case wdFieldLink TypeAsString = RID_STR_COMMON_OLE_FIELD_LINK XMLTypeAsString = CSTR_SUBISSUE_OLE_FIELD_LINK Case Else TypeAsString = RID_STR_COMMON_OLE_UNKNOWN XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN End Select Set myIssue = New IssueInfo With myIssue .IssueID = CID_PORTABILITY .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY .SubType = TypeAsString .Location = .CLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .IssueTypeXML = CSTR_ISSUE_PORTABILITY .SubTypeXML = XMLTypeAsString .locationXML = .CXMLLocationPage .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE .Values.Add myField.OLEFormat.ClassType If myField.Type = wdFieldLink Then .Attributes.Add RID_STR_WORD_ATTRIBUTE_LINK .Values.Add myField.LinkFormat.SourceFullName End If mAnalysis.IssuesCountArray(CID_PORTABILITY) = _ mAnalysis.IssuesCountArray(CID_PORTABILITY) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing Exit Sub HandleErrors: Set myIssue = Nothing WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Sub Analyze_MailMergeField(myField As Field) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_MailMergeField" Dim myIssue As IssueInfo Dim TypeAsString As String Dim bProblemMailMergeField As Boolean bProblemMailMergeField = _ (myField.Type = wdFieldFillIn) Or _ (myField.Type = wdFieldAsk) Or _ (myField.Type = wdFieldMergeRec) Or _ (myField.Type = wdFieldMergeField) Or _ (myField.Type = wdFieldNext) Or _ (myField.Type = wdFieldRevisionNum) Or _ (myField.Type = wdFieldSequence) Or _ (myField.Type = wdFieldAutoNum) Or _ (myField.Type = wdFieldAutoNumOutline) Or _ (myField.Type = wdFieldAutoNumLegal) If bProblemMailMergeField Then 'Some of the following are numbering fields and need to be broken out into a seperate function. See migration guide. Select Case myField.Type Case wdFieldFillIn TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_FILL_IN Case wdFieldAsk TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_ASK Case wdFieldMergeRec TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_MERGE_RECORDS Case wdFieldMergeField TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_MERGE_FIELDS Case wdFieldNext TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_NEXT Case wdFieldRevisionNum TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_REVISION_NUMBER Case wdFieldSequence TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_SEQUENCE Case wdFieldAutoNum TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER Case wdFieldAutoNumOutline TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER_OUTLINE Case wdFieldAutoNumLegal TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER_LEGAL Case Else TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_FIELD_NAME_NOT_KNOWN End Select Set myIssue = New IssueInfo myField.Select With myIssue .IssueID = CID_FIELDS .IssueType = RID_STR_WORD_ISSUE_FIELDS .SubType = RID_STR_WORD_SUBISSUE_MAILMERGE_FIELD .Location = .CLocationPage .IssueTypeXML = CSTR_ISSUE_FIELDS .SubTypeXML = CSTR_SUBISSUE_MAILMERGE_FIELD .locationXML = .CXMLLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME .Values.Add TypeAsString If myField.Code.Text <> "" Then .Attributes.Add RID_STR_WORD_ATTRIBUTE_TEXT .Values.Add myField.Code.Text End If mAnalysis.IssuesCountArray(CID_FIELDS) = _ mAnalysis.IssuesCountArray(CID_FIELDS) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing End If Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub 'Get field DS Info Sub Analyze_MailMerge_DataSource(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_MailMerge_DataSource" ' There may be no mail merge in the document If (currDoc.MailMerge.DataSource.Type = wdNoMergeInfo) Then Exit Sub End If 'Dim issue As SimpleAnalysisInfo If (currDoc.MailMerge.DataSource.Type <> wdNoMergeInfo) Then Dim myIssue As IssueInfo Set myIssue = New IssueInfo With myIssue .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES .SubType = RID_STR_WORD_SUBISSUE_MAILMERGE_DATASOURCE .Location = .CLocationDocument .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES .SubTypeXML = CSTR_SUBISSUE_MAILMERGE_DATASOURCE .locationXML = .CXMLLocationDocument .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME .Values.Add currDoc.MailMerge.DataSource.name .Attributes.Add RID_STR_WORD_ATTRIBUTE_DATASOURCE .Values.Add currDoc.MailMerge.DataSource.Type mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing End If Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source End Sub Function getFormFieldTypeAsString(fieldType As WdFieldType) Dim Str As String Select Case fieldType Case wdFieldFormCheckBox Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CHECK_BOX Case wdFieldFormDropDown Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DROP_DOWN Case wdFieldFormTextInput Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_TEXT Case Else Str = RID_STR_WORD_ENUMERATION_UNKNOWN End Select getFormFieldTypeAsString = Str End Function Function getTextFormFieldTypeAsString(fieldType As WdTextFormFieldType) Dim Str As String Select Case fieldType Case wdCalculationText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CALCULATION Case wdCurrentDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CURRENT_DATE Case wdCurrentTimeText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CURRENT_TIME Case wdDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DATE Case wdNumberText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_NUMBER Case wdRegularText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_REGULAR Case Else Str = RID_STR_WORD_ENUMERATION_UNKNOWN End Select getTextFormFieldTypeAsString = Str End Function Function getTextFormFieldDefaultAsString(fieldType As WdTextFormFieldType) Dim Str As String Select Case fieldType Case wdCalculationText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_EXPRESSION Case wdCurrentDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_DATE Case wdCurrentTimeText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_TIME Case wdDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_DATE Case wdNumberText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_NUMBER Case wdRegularText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_TEXT Case Else Str = RID_STR_WORD_ENUMERATION_UNKNOWN End Select getTextFormFieldDefaultAsString = Str End Function Function getTextFormFieldFormatAsString(fieldType As WdTextFormFieldType) Dim Str As String Select Case fieldType Case wdCalculationText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_NUMBER Case wdCurrentDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_DATE Case wdCurrentTimeText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_TIME Case wdDateText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_DATE Case wdNumberText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_NUMBER Case wdRegularText Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_TEXT Case Else Str = RID_STR_WORD_ENUMERATION_UNKNOWN End Select getTextFormFieldFormatAsString = Str End Function Sub Analyze_FieldAndFormFieldIssues(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_FormFields" Dim myIssue As IssueInfo 'Analysze all Fields in doc Dim myField As Field For Each myField In currDoc.Fields 'Analyze Mail Merge Fields Analyze_MailMergeField myField 'Analyze TOA Fields Analyze_TOAField myField Next myField 'Analyze FormField doc issues If currDoc.FormFields.count = 0 Then GoTo FinalExit If (currDoc.FormFields.Shaded) Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_FIELDS .IssueType = RID_STR_WORD_ISSUE_FIELDS .SubType = RID_STR_WORD_SUBISSUE_APPEARANCE .Location = .CLocationDocument .IssueTypeXML = CSTR_ISSUE_FIELDS .SubTypeXML = CSTR_SUBISSUE_APPEARANCE .locationXML = .CXMLLocationDocument .Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_GREYED .Values.Add RID_STR_WORD_TRUE mAnalysis.IssuesCountArray(CID_FIELDS) = _ mAnalysis.IssuesCountArray(CID_FIELDS) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing End If 'Analyse all FormFields in doc Dim myFormField As FormField For Each myFormField In currDoc.FormFields Analyze_FormFieldIssue myFormField Next myFormField FinalExit: Set myIssue = Nothing Set myFormField = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_FormFieldIssue(myFormField As FormField) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_FormFieldIssue" Dim myIssue As IssueInfo Dim bCheckBoxIssues As Boolean Dim bFormFieldIssues As Boolean bCheckBoxIssues = False If (myFormField.Type = wdFieldFormCheckBox) Then If myFormField.CheckBox.AutoSize Then bCheckBoxIssues = True End If End If bFormFieldIssues = bCheckBoxIssues If Not bFormFieldIssues Then GoTo FinalExit myFormField.Select Set myIssue = New IssueInfo With myIssue .IssueID = CID_FIELDS .IssueType = RID_STR_WORD_ISSUE_FIELDS .SubType = RID_STR_WORD_SUBISSUE_FORM_FIELD .Location = .CLocationPage .IssueTypeXML = CSTR_ISSUE_FIELDS .SubTypeXML = CSTR_SUBISSUE_FORM_FIELD .locationXML = .CXMLLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_TYPE myIssue.Values.Add getFormFieldTypeAsString(myFormField.Type) End With 'Checkbox Issues If (myFormField.Type = wdFieldFormCheckBox) Then 'AutoSize CheckBoxes If myFormField.CheckBox.AutoSize Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_AUTOSIZE myIssue.Values.Add RID_STR_WORD_TRUE End If End If 'TextInput Issues If myFormField.Type = wdFieldFormTextInput Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_TEXT_FORM_FIELD_TYPE myIssue.Values.Add getTextFormFieldTypeAsString(myFormField.TextInput.Type) Dim bLostType As Boolean bLostType = False If (myFormField.TextInput.Type = wdCalculationText) Or _ (myFormField.TextInput.Type = wdCurrentDateText) Or _ (myFormField.TextInput.Type = wdCurrentTimeText) Then AddIssueDetailsNote myIssue, 0, getTextFormFieldTypeAsString(myFormField.TextInput.Type) & _ " " & RID_STR_WORD_NOTE_FORM_FIELD_TYPE_LOST bLostType = True End If If (myFormField.TextInput.Format <> "") Then myIssue.Attributes.Add getTextFormFieldFormatAsString(myFormField.TextInput.Type) myIssue.Values.Add myFormField.TextInput.Format End If 'Default text If (myFormField.TextInput.Default <> "") Then myIssue.Attributes.Add getTextFormFieldDefaultAsString(myFormField.TextInput.Type) myIssue.Values.Add myFormField.TextInput.Default End If 'Maximum text If (myFormField.TextInput.Width <> 0) Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_MAX_LENGTH myIssue.Values.Add myFormField.TextInput.Width End If 'Fill-in disabled If (myFormField.Enabled = False) And (Not bLostType) Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_FILLIN_ENABLED myIssue.Values.Add RID_STR_WORD_FALSE End If End If 'Help Key(F1) If (myFormField.OwnHelp And myFormField.HelpText <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_HELP_KEY_F1_OWN_TEXT myIssue.Values.Add myFormField.HelpText ElseIf ((Not myFormField.OwnHelp) And myFormField.HelpText <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_HELP_KEY_F1_AUTO_TEXT myIssue.Values.Add myFormField.HelpText End If 'StatusHelp If (myFormField.OwnStatus And myFormField.StatusText <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_STATUS_BAR_HELP_OWN_TEXT myIssue.Values.Add myFormField.StatusText ElseIf ((Not myFormField.OwnStatus) And myFormField.StatusText <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_STATUS_BAR_HELP_AUTO_TEXT myIssue.Values.Add myFormField.StatusText End If 'Macros If (myFormField.EntryMacro <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_ENTRY_MACRO myIssue.Values.Add myFormField.EntryMacro End If If (myFormField.ExitMacro <> "") Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_EXIT_MACRO myIssue.Values.Add myFormField.ExitMacro End If If (myFormField.EntryMacro <> "") Or (myFormField.ExitMacro <> "") Then mAnalysis.MacroNumFieldsUsingMacros = 1 + mAnalysis.MacroNumFieldsUsingMacros End If 'LockedField If (myFormField.Enabled = False) And (myFormField.Type <> wdFieldFormTextInput) Then myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_LOCKED myIssue.Values.Add RID_STR_WORD_TRUE End If mAnalysis.IssuesCountArray(CID_FIELDS) = _ mAnalysis.IssuesCountArray(CID_FIELDS) + 1 mAnalysis.Issues.Add myIssue FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: 'Log first occurence for this doc If Not mbFormFieldErrorLogged Then WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source mbFormFieldErrorLogged = True End If Resume FinalExit End Sub Sub Analyze_TOA(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_TOA" Dim toa As TableOfAuthorities Dim myIssue As IssueInfo Dim myRng As Range For Each toa In currDoc.TablesOfAuthorities Set myRng = toa.Range myRng.start = myRng.End Set myIssue = New IssueInfo myRng.Select Dim TabLeaderAsString As String Select Case toa.TabLeader Case wdTabLeaderDashes TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_DASHES Case wdTabLeaderDots TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_DOTS Case wdTabLeaderHeavy TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_HEAVY Case wdTabLeaderLines TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_LINES Case wdTabLeaderMiddleDot TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_MIDDLEDOT Case wdTabLeaderSpaces TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_SPACES Case Else TabLeaderAsString = RID_STR_WORD_ENUMERATION_UNKNOWN End Select Dim FormatAsString As String Select Case currDoc.TablesOfAuthorities.Format Case wdTOAClassic FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_CLASSIC Case wdTOADistinctive FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_DISTINCTIVE Case wdTOAFormal FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_FORMAL Case wdTOASimple FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_SIMPLE Case wdTOATemplate FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_FROM_TEMPLATE Case Else FormatAsString = RID_STR_WORD_ENUMERATION_UNKNOWN End Select With myIssue .IssueID = CID_INDEX_AND_REFERENCES .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES .SubType = RID_STR_WORD_SUBISSUE_TABLE_OF_AUTHORITIES .Location = .CLocationPage .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES .SubTypeXML = CSTR_SUBISSUE_TABLE_OF_AUTHORITIES .locationXML = .CXMLLocationPage .SubLocation = myRng.Information(wdActiveEndPageNumber) .Attributes.Add RID_STR_WORD_ATTRIBUTE_LEADER .Values.Add TabLeaderAsString AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TOA_MIGRATE_AS_PLAIN_TEXT mAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ mAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing Set myRng = Nothing Next FinalExit: Set myIssue = Nothing Set myRng = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_TOAField(myField As Field) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_TOAField" Dim toa As TableOfAuthorities Dim myIssue As IssueInfo If myField.Type = wdFieldTOAEntry Then Set myIssue = New IssueInfo myField.Select With myIssue .IssueID = CID_FIELDS .IssueType = RID_STR_WORD_ISSUE_FIELDS .SubType = RID_STR_WORD_SUBISSUE_TABLE_OF_AUTHORITIES_FIELD .Location = .CLocationPage .IssueTypeXML = CSTR_ISSUE_FIELDS .SubTypeXML = CSTR_SUBISSUE_TABLE_OF_AUTHORITIES_FIELD .locationXML = .CXMLLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) .Attributes.Add RID_STR_WORD_ATTRIBUTE_FIELD_TEXT .Values.Add myField.Code.Text AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TOA_FIELD_LOST_ON_ROUNDTRIP mAnalysis.IssuesCountArray(CID_FIELDS) = _ mAnalysis.IssuesCountArray(CID_FIELDS) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing End If FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Sub Analyze_Tables_Borders(currDoc As Document) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Tables_Borders" Dim myIssue As IssueInfo Set myIssue = New IssueInfo Dim aTable As Table Dim invalidBorders As String For Each aTable In currDoc.Tables invalidBorders = GetInvalidBorder(aTable) If invalidBorders <> "" Then aTable.Range.Select Set myIssue = New IssueInfo With myIssue .IssueID = CID_TABLES .IssueType = RID_STR_WORD_ISSUE_TABLES .SubType = RID_STR_WORD_SUBISSUE_BORDER_STYLES .Location = .CLocationPage .IssueTypeXML = CSTR_ISSUE_TABLES .SubTypeXML = CSTR_SUBISSUE_BORDER_STYLES .locationXML = .CXMLLocationPage .SubLocation = Selection.Information(wdActiveEndPageNumber) .Line = Selection.Information(wdFirstCharacterLineNumber) .column = Selection.Information(wdFirstCharacterColumnNumber) .Attributes.Add RID_STR_WORD_ATTRIBUTE_BORDERS_NOT_DISPLAYING .Values.Add invalidBorders AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TABLE_BORDER mAnalysis.IssuesCountArray(CID_TABLES) = mAnalysis.IssuesCountArray(CID_TABLES) + 1 End With mAnalysis.Issues.Add myIssue Set myIssue = Nothing End If Next aTable FinalExit: Set myIssue = Nothing Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Resume FinalExit End Sub Function GetInvalidBorder(aTable As Table) As String Dim theResult As String theResult = "" If IsInvalidBorderStyle(aTable.Borders(wdBorderTop).LineStyle) Then theResult = theResult + "Top, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderBottom).LineStyle) Then theResult = theResult + "Bottom, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderDiagonalDown).LineStyle) Then theResult = theResult + "Down Diagonal, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderDiagonalUp).LineStyle) Then theResult = theResult + "Up Diagonal, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderHorizontal).LineStyle) Then theResult = theResult + "Horizontal, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderLeft).LineStyle) Then theResult = theResult + "Left, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderRight).LineStyle) Then theResult = theResult + "Right, " End If If IsInvalidBorderStyle(aTable.Borders(wdBorderVertical).LineStyle) Then theResult = theResult + "Vertical, " End If If theResult <> "" Then theResult = Left(theResult, (Len(theResult) - 2)) + "." End If GetInvalidBorder = theResult End Function Function IsInvalidBorderStyle(aStyle As WdLineStyle) As Boolean Dim IsInvalid As Boolean Select Case aStyle Case wdLineStyleDot, wdLineStyleDashSmallGap, wdLineStyleDashLargeGap, wdLineStyleDashDot, _ wdLineStyleDashDotDot, wdLineStyleTriple, wdLineStyleThinThickThinSmallGap, wdLineStyleThinThickMedGap, _ wdLineStyleThickThinMedGap, wdLineStyleThinThickThinMedGap, wdLineStyleThinThickLargeGap, _ wdLineStyleThickThinLargeGap, wdLineStyleThinThickThinLargeGap, wdLineStyleSingleWavy, _ wdLineStyleDoubleWavy, wdLineStyleDashDotStroked, wdLineStyleEmboss3D, wdLineStyleEngrave3D IsInvalid = True Case Else IsInvalid = False End Select IsInvalidBorderStyle = IsInvalid End Function Private Sub Class_Initialize() Set mAnalysis = New DocumentAnalysis End Sub Private Sub Class_Terminate() Set mAnalysis = Nothing End Sub Public Property Get Results() As DocumentAnalysis Set Results = mAnalysis End Property Sub Analyze_NumberingTabs(currDoc As Document, docAnalysis As DocumentAnalysis) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_NumberingTabs" Dim tb As TabStop Dim customTabPos As Single Dim tabs As Integer Dim listLvl As Long Dim tp As Single Dim bHasAlignmentProblem As Boolean Dim bHasTooManyTabs As Boolean Dim myIssue As IssueInfo Dim p As Object bHasAlignmentProblem = False bHasTooManyTabs = False For Each p In currDoc.ListParagraphs tabs = 0 For Each tb In p.TabStops If tb.customTab Then tabs = tabs + 1 customTabPos = tb.Position End If Next If tabs = 1 Then listLvl = p.Range.ListFormat.ListLevelNumber tp = p.Range.ListFormat.ListTemplate.ListLevels.item(listLvl).TabPosition If (p.Range.ListFormat.ListTemplate.ListLevels.item(listLvl).Alignment <> _ wdListLevelAlignLeft) Then ' ERROR: alignment problem bHasAlignmentProblem = True End If If tp <> customTabPos Then p.Range.InsertBefore ("XXXXX") End If 'OK - at least heuristically Else 'ERROR: too many tabs bHasTooManyTabs = True End If Next If (bHasAlignmentProblem) Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_INDEX_AND_REFERENCES .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_TAB_ALIGNMENT .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES .SubTypeXML = CSTR_SUBISSUE_NUMBERING_TAB_ALIGNMENT .locationXML = .CXMLLocationDocument AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_TAB_ALIGNMENT docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 End With docAnalysis.Issues.Add myIssue Set myIssue = Nothing End If If (bHasTooManyTabs) Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_INDEX_AND_REFERENCES .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_TAB_OVERFLOW .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES .SubTypeXML = CSTR_SUBISSUE_NUMBERING_TAB_OVERFLOW .locationXML = .CXMLLocationDocument AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_TAB_OVERFLOW docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 End With docAnalysis.Issues.Add myIssue Set myIssue = Nothing End If FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Set myIssue = Nothing Resume FinalExit End Sub Sub Analyze_Numbering(currDoc As Document, docAnalysis As DocumentAnalysis) On Error GoTo HandleErrors Dim currentFunctionName As String currentFunctionName = "Analyze_Numbering" Dim myIssue As IssueInfo Dim nFormatProblems As Integer Dim nAlignmentProblems As Integer nFormatProblems = 0 nAlignmentProblems = 0 Dim lt As ListTemplate Dim lvl As ListLevel Dim I, l_, p1, p2, v1, v2 As Integer Dim display_levels As Integer Dim fmt, prefix, postfix, res As String For Each lt In currDoc.ListTemplates l_ = 0 For Each lvl In lt.ListLevels l_ = l_ + 1 'Selection.TypeText Text:="List Number Format " + lvl.NumberFormat 'Apply Heuristic fmt = lvl.NumberFormat p1 = InStr(fmt, "%") p2 = InStrRev(fmt, "%") v1 = val(Mid(fmt, p1 + 1, 1)) v2 = val(Mid(fmt, p2 + 1, 1)) display_levels = v2 - v1 + 1 prefix = Mid(fmt, 1, p1 - 1) postfix = Mid(fmt, p2 + 2) 'Check Heuristic res = prefix For I = 2 To display_levels res = "%" + Trim(Str(l_ - I + 1)) + "." + res Next res = res + "%" + Trim(Str(l_)) + postfix If (StrComp(res, fmt) <> 0) Then nFormatProblems = nFormatProblems + 1 'Selection.TypeText Text:="Label Problem: NumberFormat=" + fmt + " Heuristic=" + res End If 'check alignment If (lvl.NumberPosition <> wdListLevelAlignLeft) Then nAlignmentProblems = nAlignmentProblems + 1 'Selection.TypeText Text:="Number alignment problem" End If Next Next If (nFormatProblems > 0) Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_INDEX_AND_REFERENCES .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_FORMAT .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES .SubTypeXML = CSTR_SUBISSUE_NUMBERING_FORMAT .locationXML = .CXMLLocationDocument .Attributes.Add RID_STR_WORD_ATTRIBUTE_COUNT .Values.Add nFormatProblems AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_FORMAT docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 End With docAnalysis.Issues.Add myIssue Set myIssue = Nothing End If If (nAlignmentProblems > 0) Then Set myIssue = New IssueInfo With myIssue .IssueID = CID_INDEX_AND_REFERENCES .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_ALIGNMENT .Location = .CLocationDocument 'Location string .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES .SubTypeXML = CSTR_SUBISSUE_NUMBERING_ALIGNMENT .locationXML = .CXMLLocationDocument .Attributes.Add RID_STR_WORD_ATTRIBUTE_COUNT .Values.Add nAlignmentProblems AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_ALIGNMENT docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 End With docAnalysis.Issues.Add myIssue Set myIssue = Nothing End If FinalExit: Exit Sub HandleErrors: WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source Set myIssue = Nothing Resume FinalExit End Sub