| 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 <storeToDir>\prepared\<source doc name> |
| 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 separate 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 occurrence 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 |
| |