1VERSION 1.0 CLASS 2BEGIN 3 MultiUse = -1 'True 4END 5Attribute VB_Name = "MigrationAnalyser" 6Attribute VB_GlobalNameSpace = False 7Attribute VB_Creatable = False 8Attribute VB_PredeclaredId = False 9Attribute VB_Exposed = False 10'/************************************************************************* 11' * 12' DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. 13' 14' Copyright 2000, 2010 Oracle and/or its affiliates. 15' 16' OpenOffice.org - a multi-platform office productivity suite 17' 18' This file is part of OpenOffice.org. 19' 20' OpenOffice.org is free software: you can redistribute it and/or modify 21' it under the terms of the GNU Lesser General Public License version 3 22' only, as published by the Free Software Foundation. 23' 24' OpenOffice.org is distributed in the hope that it will be useful, 25' but WITHOUT ANY WARRANTY; without even the implied warranty of 26' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 27' GNU Lesser General Public License version 3 for more details 28' (a copy is included in the LICENSE file that accompanied this code). 29' 30' You should have received a copy of the GNU Lesser General Public License 31' version 3 along with OpenOffice.org. If not, see 32' <http://www.openoffice.org/license.html> 33' for a copy of the LGPLv3 License. 34' 35' ************************************************************************/ 36 37Option Explicit 38 39'Class variables 40Private Enum HFIssueType 41 hfInline 42 hfShape 43 hfFrame 44End Enum 45 46Private Enum HFIssueLocation 47 hfHeader 48 hffooter 49End Enum 50 51 52Private Type ShapeInfo 53 top As Single 54 Height As Single 55End Type 56 57Private Type FrameInfo 58 Height As Single 59 VerticalPosition As Single 60End Type 61 62Private mAnalysis As DocumentAnalysis 63Private mOdd As Boolean 64Private mbFormFieldErrorLogged As Boolean 65Private mbRefFormFieldErrorLogged As Boolean 66 67'***ADDING-ISSUE: Use Following Skeleton as Guideline for Adding Issue 68' For complete list of all RID_STR_... for Issues (IssueType), SubIssues (SubType) and Attributes refer to: 69' word_res.bas and common_res.bas 70' 71' For complete list of all CID_... for Issue Categories(IssueID) and 72' CSTR_... for XML Issues (IssueTypeXML) and XML SubIssues (SubTypeXML) refer to: 73' ApplicationSpecific.bas and CommonMigrationAnalyser.bas 74' 75' You should not have to add any new Issue Categories or matching IssueTypes, only new SubIssues 76Sub Analyze_SKELETON() 77 On Error GoTo HandleErrors 78 Dim currentFunctionName As String 79 currentFunctionName = "Analyze_SKELETON" 80 Dim myIssue As IssueInfo 81 Set myIssue = New IssueInfo 82 83 With myIssue 84 .IssueID = CID_VBA_MACROS 'Issue Category 85 .IssueType = RID_STR_COMMON_ISSUE_VBA_MACROS 'Issue String 86 .SubType = RID_STR_COMMON_SUBISSUE_PROPERTIES 'SubIssue String 87 .Location = .CLocationDocument 'Location string 88 89 .IssueTypeXML = CSTR_ISSUE_VBA_MACROS 'Non localised XML Issue String 90 .SubTypeXML = CSTR_SUBISSUE_PROPERTIES 'Non localised XML SubIssue String 91 .locationXML = .CXMLLocationDocument 'Non localised XML location 92 93 .SubLocation = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 94 .Line = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 95 .column = 0 'if not set will default to RID_STR_NOT_AVAILABLE_SHORTHAND 96 97 ' Add as many Attribute Value pairs as needed 98 ' Note: following must always be true - Attributes.Count = Values.Count 99 .Attributes.Add "AAA" 100 .Values.Add "foobar" 101 102 ' Use AddIssueDetailsNote to add notes to the Issue Details if required 103 ' Public Sub AddIssueDetailsNote(myIssue As IssueInfo, noteNum As Long, noteStr As String, _ 104 ' Optional preStr As String = RID_STR_COMMON_NOTE_PRE) 105 ' Where preStr is prepended to the output, with "Note" as the default 106 AddIssueDetailsNote myIssue, 0, RID_STR_COMMON_NOTE_DOCUMENT_PROPERTIES_LOST 107 108 'Only put this in if you have a preparation function added for this issue in CommonPreparation 109 'or Preparation - NUll can be replaced with any variant if you want to pass info to the Prepare fnc 110 Call DoPreparation(mAnalysis, myIssue, "", Null, Null) 111 112 mAnalysis.IssuesCountArray(CID_VBA_MACROS) = _ 113 mAnalysis.IssuesCountArray(CID_VBA_MACROS) + 1 114 End With 115 116 mAnalysis.Issues.Add myIssue 117 118FinalExit: 119 Set myIssue = Nothing 120 Exit Sub 121 122HandleErrors: 123 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 124 Resume FinalExit 125End Sub 126 127Sub DoAnalyse(fileName As String, userFormTypesDict As Scripting.Dictionary, _ 128 startDir As String, storeToDir As String, fso As FileSystemObject) 129 On Error GoTo HandleErrors 130 Dim currentFunctionName As String 131 currentFunctionName = "DoAnalyse" 132 mAnalysis.name = fileName 133 Dim aDoc As Document 134 Dim bUnprotectError As Boolean 135 mAnalysis.TotalIssueTypes = CTOTAL_CATEGORIES 136 mbFormFieldErrorLogged = False 137 mbRefFormFieldErrorLogged = False 138 139 'Turn off any AutoExce macros before loading the Word doc 140 On Error Resume Next ' Ignore errors on setting 141 WordBasic.DisableAutoMacros 1 142 On Error GoTo HandleErrors 143 144 Dim myPassword As String 145 myPassword = GetDefaultPassword 146 147 'Always skip password protected documents 148 'If IsSkipPasswordDocs() Then 149 Dim aPass As String 150 If myPassword <> "" Then 151 aPass = myPassword 152 Else 153 aPass = "xoxoxoxoxo" 154 End If 155 156 On Error Resume Next 157 Set aDoc = Documents.Open(fileName, False, False, False, _ 158 aPass, aPass, False, aPass, aPass, wdOpenFormatAuto, _ 159 msoEncodingAutoDetect, False) 160 If Err.Number = 5408 Then 161 ' if password protected, try open readonly next 162 Set aDoc = Documents.Open(fileName, False, True, False, _ 163 aPass, aPass, False, aPass, aPass, wdOpenFormatAuto, _ 164 msoEncodingAutoDetect, False) 165 End If 166 If Err.Number = 5408 Then 167 HandleProtectedDocInvalidPassword mAnalysis, _ 168 "User entered Invalid Document Password, further analysis not possible", fso 169 Analyze_Password_Protection True, False 170 GoTo FinalExit 171 ElseIf (Err.Number <> 0) Then 172 GoTo HandleErrors 173 End If 174 175 On Error GoTo HandleErrors 176 177 If aDoc Is Nothing Then GoTo FinalExit 178 179 'Do Analysis 180 Analyze_Password_Protection aDoc.HasPassword, aDoc.WriteReserved 181 Analyze_Document_Protection aDoc 182 183 If aDoc.ProtectionType <> wdNoProtection Then 184 If myPassword <> "" Then 185 aDoc.Unprotect (myPassword) 186 Else 187 aDoc.Unprotect 188 End If 189 End If 190 191 'Set Doc Properties 192 SetDocProperties mAnalysis, aDoc, fso 193 194ContinueFromUnprotectError: 195 196 Analyze_Tables_TablesInTables aDoc 197 Analyze_Tables_Borders aDoc 198 Analyze_TOA aDoc 199 If Not bUnprotectError Then 200 Analyze_FieldAndFormFieldIssues aDoc 201 End If 202 Analyze_OLEEmbedded aDoc 203 Analyze_MailMerge_DataSource aDoc 204 Analyze_Macros mAnalysis, userFormTypesDict, aDoc 205 'Analyze_Numbering aDoc, mAnalysis 206 'Analyze_NumberingTabs aDoc, mAnalysis 207 208 ' Doc Preparation only 209 ' Save document with any prepared issues under <storeToDir>\prepared\<source doc name> 210 If mAnalysis.PreparableIssuesCount > 0 And CheckDoPrepare Then 211 Dim preparedFullPath As String 212 preparedFullPath = GetPreparedFullPath(mAnalysis.name, startDir, storeToDir, fso) 213 If preparedFullPath <> "" Then 214 If fso.FileExists(preparedFullPath) Then 215 fso.DeleteFile preparedFullPath, True 216 End If 217 If fso.FolderExists(fso.GetParentFolderName(preparedFullPath)) Then 218 aDoc.SaveAs preparedFullPath 219 End If 220 End If 221 End If 222 223 'DebugMacroInfo 224 225FinalExit: 226 227 If Not aDoc Is Nothing Then 'If Not IsEmpty(aDoc) Then 228 aDoc.Close (False) 229 End If 230 Set aDoc = Nothing 231 232 Exit Sub 233 234HandleErrors: 235 ' MsgBox currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 236 ' Handle Password error on Doc Open, Modify and Cancel 237 If Err.Number = 5408 Or Err.Number = 4198 Then 238 WriteDebug currentFunctionName & " : " & fileName & ": " & _ 239 "User entered Invalid Document Password - " & Err.Number & " " & Err.Description & " " & Err.Source 240 HandleProtectedDocInvalidPassword mAnalysis, _ 241 "User entered Invalid Document Password, further analysis not possible", fso 242 Resume FinalExit 243 ElseIf Err.Number = 5485 Then 244 ' Handle Password error on Unprotect Doc 245 WriteDebug currentFunctionName & " : " & fileName & ": " & _ 246 "User entered Invalid Document Part Password, Analysis of doc will continue but will skip analysis of:" & _ 247 "Forms, Comments, Headers & Footers and Table cell spanning issues - " & Err.Number & " " & Err.Description & " " & Err.Source 248 HandleProtectedDocInvalidPassword mAnalysis, _ 249 "User entered Invalid Document Part Password, Analysis of doc will continue but will skip analysis of:" & vbLf & _ 250 "Forms, Comments, Headers & Footers and Table cell spanning issues", fso 251 bUnprotectError = True 252 'wdAllowOnlyComments, wdAllowOnlyFormFields, wdAllowOnlyRevisions 253 Resume ContinueFromUnprotectError 254 End If 255 mAnalysis.Application = RID_STR_COMMON_CANNOT_OPEN 256 WriteDebug currentFunctionName & " : " & fileName & ": " & Err.Number & " " & Err.Description & " " & Err.Source 257 Resume FinalExit 258End Sub 259 260Sub DebugMacroInfo() 261 MsgBox "TotalNumLines: " & mAnalysis.MacroTotalNumLines & vbLf & _ 262 "NumUserForms: " & mAnalysis.MacroNumUserForms & vbLf & _ 263 "NumUserFormControls: " & mAnalysis.MacroNumUserFormControls & vbLf & _ 264 "NumUserFormControlTypes: " & mAnalysis.MacroNumUserFormControlTypes & vbLf & _ 265 "NumExternalRefs: " & mAnalysis.MacroNumExternalRefs & vbLf & _ 266 "MacroNumFieldsUsingMacros: " & mAnalysis.MacroNumFieldsUsingMacros & vbLf & _ 267 "NumOLEControls: " & mAnalysis.MacroNumOLEControls & vbLf & _ 268 "MacroOverallClass: " & getDocOverallMacroClassAsString(mAnalysis.MacroOverallClass) 269End Sub 270 271Sub SetDocProperties(docAnalysis As DocumentAnalysis, doc As Document, fso As FileSystemObject) 272 On Error GoTo HandleErrors 273 Dim currentFunctionName As String 274 currentFunctionName = "SetProperties" 275 Dim f As File 276 Set f = fso.GetFile(docAnalysis.name) 277 278 docAnalysis.PageCount = doc.ComputeStatistics(wdStatisticPages) 279 docAnalysis.Accessed = f.DateLastAccessed 280 281 On Error Resume Next 'Some apps may not support all props 282 docAnalysis.Application = getAppSpecificApplicationName & " " & Application.Version 283 'docAnalysis.Application = doc.BuiltinDocumentProperties(wdPropertyAppName) 284 'If InStr(docAnalysis.Application, "Microsoft") = 1 Then 285 ' docAnalysis.Application = Mid(docAnalysis.Application, Len("Microsoft") + 2) 286 'End If 287 'If InStr(Len(docAnalysis.Application) - 2, docAnalysis.Application, ".") = 0 Then 288 ' docAnalysis.Application = docAnalysis.Application & " " & Application.Version 289 'End If 290 291 docAnalysis.Created = _ 292 doc.BuiltInDocumentProperties(wdPropertyTimeCreated) 293 docAnalysis.Modified = _ 294 doc.BuiltInDocumentProperties(wdPropertyTimeLastSaved) 295 docAnalysis.Printed = _ 296 doc.BuiltInDocumentProperties(wdPropertyTimeLastPrinted) 297 docAnalysis.SavedBy = _ 298 doc.BuiltInDocumentProperties(wdPropertyLastAuthor) 299 docAnalysis.Revision = _ 300 val(doc.BuiltInDocumentProperties(wdPropertyRevision)) 301 docAnalysis.Template = _ 302 fso.GetFileName(doc.BuiltInDocumentProperties(wdPropertyTemplate)) 303 304FinalExit: 305 Set f = Nothing 306 Exit Sub 307 308HandleErrors: 309 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 310 Resume FinalExit 311End Sub 312 313'Limitation: Detect first level table in tables, does not detect further nesting 314'Can do so if required 315Sub Analyze_Tables_TablesInTables(currDoc As Document) 316 On Error GoTo HandleErrors 317 Dim currentFunctionName As String 318 currentFunctionName = "Analyze_Tables_TablesInTables" 319 Dim myTopTable As Table 320 Dim myInnerTable As Table 321 Dim myIssue As IssueInfo 322 323 For Each myTopTable In currDoc.Tables 324 For Each myInnerTable In myTopTable.Tables 325 Dim logString As String 326 Dim myRng As Range 327 Dim startpage As Long 328 Dim startRow As Long 329 Dim StartColumn As Long 330 Dim details As String 331 332 Set myIssue = New IssueInfo 333 Set myRng = myInnerTable.Range 334 myRng.start = myRng.End 335 startpage = myRng.Information(wdActiveEndPageNumber) 336 startRow = myRng.Information(wdStartOfRangeRowNumber) 337 StartColumn = myRng.Information(wdStartOfRangeColumnNumber) 338 339 With myIssue 340 .IssueID = CID_TABLES 341 .IssueType = RID_STR_WORD_ISSUE_TABLES 342 .SubType = RID_STR_WORD_SUBISSUE_NESTED_TABLES 343 .Location = .CLocationPage 344 .SubLocation = startpage 345 346 .IssueTypeXML = CSTR_ISSUE_TABLES 347 .SubTypeXML = CSTR_SUBISSUE_NESTED_TABLES 348 .locationXML = .CXMLLocationPage 349 350 .Attributes.Add RID_STR_WORD_ATTRIBUTE_OUTER_TABLE 351 .Values.Add myTopTable.Rows.count & "x" & myTopTable.Columns.count 352 .Attributes.Add RID_STR_WORD_ATTRIBUTE_INNER_TABLE 353 .Values.Add myInnerTable.Rows.count & "x" & myInnerTable.Columns.count 354 .Attributes.Add RID_STR_WORD_ATTRIBUTE_START_ROW 355 .Values.Add startRow 356 .Attributes.Add RID_STR_WORD_ATTRIBUTE_START_COL 357 .Values.Add StartColumn 358 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NESTED_TABLE_WILL_BE_LOST 359 360 mAnalysis.IssuesCountArray(CID_TABLES) = _ 361 mAnalysis.IssuesCountArray(CID_TABLES) + 1 362 End With 363 364 mAnalysis.Issues.Add myIssue 365 Set myIssue = Nothing 366 Set myRng = Nothing 367 Next 368 Next 369 Exit Sub 370HandleErrors: 371 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 372End Sub 373 374Sub Analyze_Document_Protection(currDoc As Document) 375 On Error GoTo HandleErrors 376 Dim currentFunctionName As String 377 currentFunctionName = "Analyze_Document_Protection" 378 If currDoc.ProtectionType = wdNoProtection Then 379 Exit Sub 380 End If 381 382 Dim myIssue As IssueInfo 383 Set myIssue = New IssueInfo 384 385 With myIssue 386 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 387 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 388 .SubType = RID_STR_COMMON_SUBISSUE_DOCUMENT_PARTS_PROTECTION 389 .Location = .CLocationDocument 390 391 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 392 .SubTypeXML = CSTR_SUBISSUE_DOCUMENT_PARTS_PROTECTION 393 .locationXML = .CXMLLocationDocument 394 395 .Attributes.Add RID_STR_WORD_ATTRIBUTE_PROTECTION 396 Select Case currDoc.ProtectionType 397 Case wdAllowOnlyComments 398 .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_COMMENTS 399 Case wdAllowOnlyFormFields 400 .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_FORM_FIELDS 401 Case wdAllowOnlyRevisions 402 .Values.Add RID_STR_WORD_ATTRIBUTE_ALLOW_ONLY_REVISIONS 403 Case Else 404 .Values.Add RID_STR_COMMON_ATTRIBUTE_UNKNOWN 405 End Select 406 407 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 408 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 409 End With 410 411 mAnalysis.Issues.Add myIssue 412FinalExit: 413 Set myIssue = Nothing 414 Exit Sub 415 416HandleErrors: 417 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 418 Resume FinalExit 419End Sub 420 421Sub Analyze_Password_Protection(bHasPassword As Boolean, bWriteReserved As Boolean) 422 On Error GoTo HandleErrors 423 Dim currentFunctionName As String 424 currentFunctionName = "Analyze_Password_Protection" 425 Dim myIssue As IssueInfo 426 427 If bHasPassword Or bWriteReserved Then 428 Set myIssue = New IssueInfo 429 430 With myIssue 431 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 432 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 433 .SubType = RID_STR_COMMON_SUBISSUE_PASSWORDS_PROTECTION 434 .Location = .CLocationDocument 435 436 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 437 .SubTypeXML = CSTR_SUBISSUE_PASSWORDS_PROTECTION 438 .locationXML = .CXMLLocationDocument 439 440 If bHasPassword Then 441 .Attributes.Add RID_STR_WORD_ATTRIBUTE_PASSWORD_TO_OPEN 442 .Values.Add RID_STR_WORD_ATTRIBUTE_SET 443 End If 444 If bWriteReserved Then 445 .Attributes.Add RID_STR_WORD_ATTRIBUTE_PASSWORD_TO_MODIFY 446 .Values.Add RID_STR_WORD_ATTRIBUTE_SET 447 End If 448 449 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 450 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 451 End With 452 453 mAnalysis.Issues.Add myIssue 454 End If 455FinalExit: 456 Set myIssue = Nothing 457 Exit Sub 458 459HandleErrors: 460 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 461 Resume FinalExit 462End Sub 463 464Sub Analyze_OLEEmbedded(currDoc As Document) 465 On Error GoTo HandleErrors 466 Dim currentFunctionName As String 467 currentFunctionName = "Analyze_OLEEmbedded" 468 469 ' Handle Inline Shapes 470 Dim aILShape As InlineShape 471 For Each aILShape In currDoc.InlineShapes 472 Analyze_OLEEmbeddedSingleInlineShape aILShape 473 Next aILShape 474 475 ' Handle Shapes 476 Dim aShape As Shape 477 For Each aShape In currDoc.Shapes 478 Analyze_OLEEmbeddedSingleShape mAnalysis, aShape, _ 479 Selection.Information(wdActiveEndPageNumber) 480 Analyze_Lines mAnalysis, aShape, _ 481 Selection.Information(wdActiveEndPageNumber) 482 Analyze_Transparency mAnalysis, aShape, _ 483 Selection.Information(wdActiveEndPageNumber) 484 Analyze_Gradients mAnalysis, aShape, _ 485 Selection.Information(wdActiveEndPageNumber) 486 Next aShape 487 488 Exit Sub 489 490HandleErrors: 491 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 492End Sub 493 494 495'WdInlineShapeType constants: 496'wdInlineShapeEmbeddedOLEObject, wdInlineShapeHorizontalLine, wdInlineShapeLinkedOLEObject, 497'wdInlineShapeLinkedPicture, wdInlineShapeLinkedPictureHorizontalLine, wdInlineShapeOLEControlObject, 498'wdInlineShapeOWSAnchor, wdInlineShapePicture, wdInlineShapePictureBullet, 499'wdInlineShapePictureHorizontalLine, wdInlineShapeScriptAnchor 500 501Sub Analyze_OLEEmbeddedSingleInlineShape(aILShape As InlineShape) 502 On Error GoTo HandleErrors 503 Dim currentFunctionName As String 504 currentFunctionName = "Analyze_OLEEmbeddedSingleInlineShape" 505 Dim myIssue As IssueInfo 506 Dim bOleObject As Boolean 507 Dim TypeAsString As String 508 Dim XMLTypeAsString As String 509 Dim objName As String 510 511 bOleObject = (aILShape.Type = wdInlineShapeEmbeddedOLEObject) Or _ 512 (aILShape.Type = wdInlineShapeLinkedOLEObject) Or _ 513 (aILShape.Type = wdInlineShapeOLEControlObject) 514 515 If Not bOleObject Then Exit Sub 516 517 aILShape.Select 518 Select Case aILShape.Type 519 Case wdInlineShapeOLEControlObject 520 TypeAsString = RID_STR_COMMON_OLE_CONTROL 521 XMLTypeAsString = CSTR_SUBISSUE_OLE_CONTROL 522 Case wdInlineShapeEmbeddedOLEObject 523 TypeAsString = RID_STR_COMMON_OLE_EMBEDDED 524 XMLTypeAsString = CSTR_SUBISSUE_OLE_EMBEDDED 525 Case wdInlineShapeLinkedOLEObject 526 TypeAsString = RID_STR_COMMON_OLE_LINKED 527 XMLTypeAsString = CSTR_SUBISSUE_OLE_LINKED 528 Case Else 529 TypeAsString = RID_STR_COMMON_OLE_UNKNOWN 530 XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN 531 End Select 532 533 Set myIssue = New IssueInfo 534 With myIssue 535 .IssueID = CID_PORTABILITY 536 .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY 537 .SubType = TypeAsString 538 .Location = .CLocationPage 539 .SubLocation = Selection.Information(wdActiveEndPageNumber) 540 541 .IssueTypeXML = CSTR_ISSUE_PORTABILITY 542 .SubTypeXML = XMLTypeAsString 543 .locationXML = .CXMLLocationPage 544 545 .Line = Selection.Information(wdFirstCharacterLineNumber) 546 .column = Selection.Information(wdFirstCharacterColumnNumber) 547 548 DoEvents 549 If aILShape.Type = wdInlineShapeEmbeddedOLEObject Or _ 550 aILShape.Type = wdInlineShapeOLEControlObject Then 551 552 'If Object is invalid can get automation server hanging 553 Dim tmpStr As String 554 On Error Resume Next 555 tmpStr = aILShape.OLEFormat.Object 556 If Err.Number = 0 Then 557 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE 558 .Values.Add aILShape.OLEFormat.ProgID 559 Else 560 Err.Clear 561 tmpStr = aILShape.OLEFormat.ClassType 562 If Err.Number = 0 Then 563 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE 564 .Values.Add aILShape.OLEFormat.ClassType 565 Else 566 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE 567 .Values.Add RID_STR_COMMON_NA 568 End If 569 End If 570 571 If aILShape.Type = wdInlineShapeOLEControlObject Then 572 mAnalysis.MacroNumOLEControls = 1 + mAnalysis.MacroNumOLEControls 573 End If 574 575 objName = aILShape.OLEFormat.Object.name 576 If Err.Number = 0 Then 577 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_NAME 578 .Values.Add objName 579 End If 580 On Error GoTo HandleErrors 581 End If 582 If aILShape.Type = wdInlineShapeLinkedOLEObject Then 583 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_SOURCE 584 .Values.Add aILShape.LinkFormat.SourceFullName 585 End If 586 587 mAnalysis.IssuesCountArray(CID_PORTABILITY) = _ 588 mAnalysis.IssuesCountArray(CID_PORTABILITY) + 1 589 End With 590 591 mAnalysis.Issues.Add myIssue 592 593FinalExit: 594 Set myIssue = Nothing 595 Exit Sub 596 597HandleErrors: 598 WriteDebugLevelTwo currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 599 Resume FinalExit 600End Sub 601 602'Appears to be picked up by other OLE analysis code - the Shapes are actually field codes 603'So I get double reporting if I use this as well. 604Sub Analyze_OLEFields(myField As Field) 605 On Error GoTo HandleErrors 606 Dim currentFunctionName As String 607 currentFunctionName = "Analyze_OLEFields" 608 Dim myIssue As IssueInfo 609 Dim bOleObject As Boolean 610 Dim TypeAsString As String 611 Dim XMLTypeAsString As String 612 613 bOleObject = (myField.Type = wdFieldOCX) 614 615 If Not bOleObject Then Exit Sub 616 617 myField.Select 618 Select Case myField.Type 619 Case wdFieldLink 620 TypeAsString = RID_STR_COMMON_OLE_FIELD_LINK 621 XMLTypeAsString = CSTR_SUBISSUE_OLE_FIELD_LINK 622 Case Else 623 TypeAsString = RID_STR_COMMON_OLE_UNKNOWN 624 XMLTypeAsString = CSTR_SUBISSUE_OLE_UNKNOWN 625 End Select 626 Set myIssue = New IssueInfo 627 With myIssue 628 .IssueID = CID_PORTABILITY 629 .IssueType = RID_STR_COMMON_ISSUE_PORTABILITY 630 .SubType = TypeAsString 631 .Location = .CLocationPage 632 .SubLocation = Selection.Information(wdActiveEndPageNumber) 633 634 .IssueTypeXML = CSTR_ISSUE_PORTABILITY 635 .SubTypeXML = XMLTypeAsString 636 .locationXML = .CXMLLocationPage 637 638 .Line = Selection.Information(wdFirstCharacterLineNumber) 639 .column = Selection.Information(wdFirstCharacterColumnNumber) 640 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_OBJECT_TYPE 641 .Values.Add myField.OLEFormat.ClassType 642 643 If myField.Type = wdFieldLink Then 644 .Attributes.Add RID_STR_WORD_ATTRIBUTE_LINK 645 .Values.Add myField.LinkFormat.SourceFullName 646 End If 647 mAnalysis.IssuesCountArray(CID_PORTABILITY) = _ 648 mAnalysis.IssuesCountArray(CID_PORTABILITY) + 1 649 End With 650 mAnalysis.Issues.Add myIssue 651 652 Set myIssue = Nothing 653 654 Exit Sub 655 656HandleErrors: 657 Set myIssue = Nothing 658 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 659End Sub 660 661Sub Analyze_MailMergeField(myField As Field) 662 On Error GoTo HandleErrors 663 Dim currentFunctionName As String 664 currentFunctionName = "Analyze_MailMergeField" 665 Dim myIssue As IssueInfo 666 Dim TypeAsString As String 667 Dim bProblemMailMergeField As Boolean 668 669 bProblemMailMergeField = _ 670 (myField.Type = wdFieldFillIn) Or _ 671 (myField.Type = wdFieldAsk) Or _ 672 (myField.Type = wdFieldMergeRec) Or _ 673 (myField.Type = wdFieldMergeField) Or _ 674 (myField.Type = wdFieldNext) Or _ 675 (myField.Type = wdFieldRevisionNum) Or _ 676 (myField.Type = wdFieldSequence) Or _ 677 (myField.Type = wdFieldAutoNum) Or _ 678 (myField.Type = wdFieldAutoNumOutline) Or _ 679 (myField.Type = wdFieldAutoNumLegal) 680 681 If bProblemMailMergeField Then 682 'Some of the following are numbering fields and need to be broken out into a seperate function. See migration guide. 683 684 Select Case myField.Type 685 Case wdFieldFillIn 686 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_FILL_IN 687 Case wdFieldAsk 688 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_ASK 689 Case wdFieldMergeRec 690 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_MERGE_RECORDS 691 Case wdFieldMergeField 692 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_MERGE_FIELDS 693 Case wdFieldNext 694 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_NEXT 695 Case wdFieldRevisionNum 696 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_REVISION_NUMBER 697 Case wdFieldSequence 698 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_SEQUENCE 699 Case wdFieldAutoNum 700 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER 701 Case wdFieldAutoNumOutline 702 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER_OUTLINE 703 Case wdFieldAutoNumLegal 704 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_AUTO_NUMBER_LEGAL 705 Case Else 706 TypeAsString = RID_STR_WORD_ENUMERATION_MAILMERGE_FIELD_NAME_NOT_KNOWN 707 End Select 708 709 Set myIssue = New IssueInfo 710 myField.Select 711 With myIssue 712 .IssueID = CID_FIELDS 713 .IssueType = RID_STR_WORD_ISSUE_FIELDS 714 .SubType = RID_STR_WORD_SUBISSUE_MAILMERGE_FIELD 715 .Location = .CLocationPage 716 717 .IssueTypeXML = CSTR_ISSUE_FIELDS 718 .SubTypeXML = CSTR_SUBISSUE_MAILMERGE_FIELD 719 .locationXML = .CXMLLocationPage 720 721 .SubLocation = Selection.Information(wdActiveEndPageNumber) 722 .Line = Selection.Information(wdFirstCharacterLineNumber) 723 .column = Selection.Information(wdFirstCharacterColumnNumber) 724 725 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 726 .Values.Add TypeAsString 727 If myField.Code.Text <> "" Then 728 .Attributes.Add RID_STR_WORD_ATTRIBUTE_TEXT 729 .Values.Add myField.Code.Text 730 End If 731 732 mAnalysis.IssuesCountArray(CID_FIELDS) = _ 733 mAnalysis.IssuesCountArray(CID_FIELDS) + 1 734 End With 735 mAnalysis.Issues.Add myIssue 736 Set myIssue = Nothing 737 End If 738 Exit Sub 739 740HandleErrors: 741 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 742End Sub 743 744'Get field DS Info 745Sub Analyze_MailMerge_DataSource(currDoc As Document) 746 On Error GoTo HandleErrors 747 Dim currentFunctionName As String 748 currentFunctionName = "Analyze_MailMerge_DataSource" 749 ' There may be no mail merge in the document 750 If (currDoc.MailMerge.DataSource.Type = wdNoMergeInfo) Then 751 Exit Sub 752 End If 753 754 'Dim issue As SimpleAnalysisInfo 755 If (currDoc.MailMerge.DataSource.Type <> wdNoMergeInfo) Then 756 Dim myIssue As IssueInfo 757 Set myIssue = New IssueInfo 758 With myIssue 759 .IssueID = CID_CONTENT_AND_DOCUMENT_PROPERTIES 760 .IssueType = RID_STR_COMMON_ISSUE_CONTENT_AND_DOCUMENT_PROPERTIES 761 .SubType = RID_STR_WORD_SUBISSUE_MAILMERGE_DATASOURCE 762 .Location = .CLocationDocument 763 764 .IssueTypeXML = CSTR_ISSUE_CONTENT_DOCUMENT_PROPERTIES 765 .SubTypeXML = CSTR_SUBISSUE_MAILMERGE_DATASOURCE 766 .locationXML = .CXMLLocationDocument 767 768 .Attributes.Add RID_STR_COMMON_ATTRIBUTE_NAME 769 .Values.Add currDoc.MailMerge.DataSource.name 770 .Attributes.Add RID_STR_WORD_ATTRIBUTE_DATASOURCE 771 .Values.Add currDoc.MailMerge.DataSource.Type 772 773 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) = _ 774 mAnalysis.IssuesCountArray(CID_CONTENT_AND_DOCUMENT_PROPERTIES) + 1 775 End With 776 777 mAnalysis.Issues.Add myIssue 778 Set myIssue = Nothing 779 End If 780 Exit Sub 781 782HandleErrors: 783 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 784End Sub 785 786Function getFormFieldTypeAsString(fieldType As WdFieldType) 787 Dim Str As String 788 789 Select Case fieldType 790 Case wdFieldFormCheckBox 791 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CHECK_BOX 792 Case wdFieldFormDropDown 793 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DROP_DOWN 794 Case wdFieldFormTextInput 795 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_TEXT 796 Case Else 797 Str = RID_STR_WORD_ENUMERATION_UNKNOWN 798 End Select 799 800 getFormFieldTypeAsString = Str 801End Function 802Function getTextFormFieldTypeAsString(fieldType As WdTextFormFieldType) 803 Dim Str As String 804 805 Select Case fieldType 806 Case wdCalculationText 807 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CALCULATION 808 Case wdCurrentDateText 809 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CURRENT_DATE 810 Case wdCurrentTimeText 811 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_CURRENT_TIME 812 Case wdDateText 813 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DATE 814 Case wdNumberText 815 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_NUMBER 816 Case wdRegularText 817 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_REGULAR 818 Case Else 819 Str = RID_STR_WORD_ENUMERATION_UNKNOWN 820 End Select 821 822 getTextFormFieldTypeAsString = Str 823End Function 824Function getTextFormFieldDefaultAsString(fieldType As WdTextFormFieldType) 825 Dim Str As String 826 827 Select Case fieldType 828 Case wdCalculationText 829 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_EXPRESSION 830 Case wdCurrentDateText 831 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_DATE 832 Case wdCurrentTimeText 833 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_TIME 834 Case wdDateText 835 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_DATE 836 Case wdNumberText 837 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_NUMBER 838 Case wdRegularText 839 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_DEFAULT_TEXT 840 Case Else 841 Str = RID_STR_WORD_ENUMERATION_UNKNOWN 842 End Select 843 844 getTextFormFieldDefaultAsString = Str 845End Function 846Function getTextFormFieldFormatAsString(fieldType As WdTextFormFieldType) 847 Dim Str As String 848 849 Select Case fieldType 850 Case wdCalculationText 851 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_NUMBER 852 Case wdCurrentDateText 853 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_DATE 854 Case wdCurrentTimeText 855 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_TIME 856 Case wdDateText 857 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_DATE 858 Case wdNumberText 859 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_NUMBER 860 Case wdRegularText 861 Str = RID_STR_WORD_ENUMERATION_FORM_FIELD_FORMAT_TEXT 862 Case Else 863 Str = RID_STR_WORD_ENUMERATION_UNKNOWN 864 End Select 865 866 getTextFormFieldFormatAsString = Str 867End Function 868 869Sub Analyze_FieldAndFormFieldIssues(currDoc As Document) 870 On Error GoTo HandleErrors 871 Dim currentFunctionName As String 872 currentFunctionName = "Analyze_FormFields" 873 Dim myIssue As IssueInfo 874 875 'Analysze all Fields in doc 876 Dim myField As Field 877 878 For Each myField In currDoc.Fields 879 'Analyze Mail Merge Fields 880 Analyze_MailMergeField myField 881 882 'Analyze TOA Fields 883 Analyze_TOAField myField 884 Next myField 885 886 'Analyze FormField doc issues 887 If currDoc.FormFields.count = 0 Then GoTo FinalExit 888 889 If (currDoc.FormFields.Shaded) Then 890 Set myIssue = New IssueInfo 891 With myIssue 892 .IssueID = CID_FIELDS 893 .IssueType = RID_STR_WORD_ISSUE_FIELDS 894 .SubType = RID_STR_WORD_SUBISSUE_APPEARANCE 895 .Location = .CLocationDocument 896 897 .IssueTypeXML = CSTR_ISSUE_FIELDS 898 .SubTypeXML = CSTR_SUBISSUE_APPEARANCE 899 .locationXML = .CXMLLocationDocument 900 901 .Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_GREYED 902 .Values.Add RID_STR_WORD_TRUE 903 mAnalysis.IssuesCountArray(CID_FIELDS) = _ 904 mAnalysis.IssuesCountArray(CID_FIELDS) + 1 905 End With 906 mAnalysis.Issues.Add myIssue 907 Set myIssue = Nothing 908 End If 909 910 'Analyse all FormFields in doc 911 Dim myFormField As FormField 912 913 For Each myFormField In currDoc.FormFields 914 Analyze_FormFieldIssue myFormField 915 Next myFormField 916 917FinalExit: 918 Set myIssue = Nothing 919 Set myFormField = Nothing 920 Exit Sub 921 922HandleErrors: 923 924 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 925 Resume FinalExit 926End Sub 927 928Sub Analyze_FormFieldIssue(myFormField As FormField) 929 On Error GoTo HandleErrors 930 Dim currentFunctionName As String 931 currentFunctionName = "Analyze_FormFieldIssue" 932 Dim myIssue As IssueInfo 933 Dim bCheckBoxIssues As Boolean 934 Dim bFormFieldIssues As Boolean 935 936 bCheckBoxIssues = False 937 If (myFormField.Type = wdFieldFormCheckBox) Then 938 If myFormField.CheckBox.AutoSize Then 939 bCheckBoxIssues = True 940 End If 941 End If 942 943 bFormFieldIssues = bCheckBoxIssues 944 945 If Not bFormFieldIssues Then GoTo FinalExit 946 947 myFormField.Select 948 Set myIssue = New IssueInfo 949 With myIssue 950 .IssueID = CID_FIELDS 951 .IssueType = RID_STR_WORD_ISSUE_FIELDS 952 .SubType = RID_STR_WORD_SUBISSUE_FORM_FIELD 953 .Location = .CLocationPage 954 955 .IssueTypeXML = CSTR_ISSUE_FIELDS 956 .SubTypeXML = CSTR_SUBISSUE_FORM_FIELD 957 .locationXML = .CXMLLocationPage 958 959 .SubLocation = Selection.Information(wdActiveEndPageNumber) 960 .Line = Selection.Information(wdFirstCharacterLineNumber) 961 .column = Selection.Information(wdFirstCharacterColumnNumber) 962 myIssue.Attributes.Add RID_STR_COMMON_ATTRIBUTE_TYPE 963 myIssue.Values.Add getFormFieldTypeAsString(myFormField.Type) 964 End With 965 966 'Checkbox Issues 967 If (myFormField.Type = wdFieldFormCheckBox) Then 968 'AutoSize CheckBoxes 969 If myFormField.CheckBox.AutoSize Then 970 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_AUTOSIZE 971 myIssue.Values.Add RID_STR_WORD_TRUE 972 End If 973 End If 974 975 'TextInput Issues 976 If myFormField.Type = wdFieldFormTextInput Then 977 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_TEXT_FORM_FIELD_TYPE 978 myIssue.Values.Add getTextFormFieldTypeAsString(myFormField.TextInput.Type) 979 Dim bLostType As Boolean 980 bLostType = False 981 If (myFormField.TextInput.Type = wdCalculationText) Or _ 982 (myFormField.TextInput.Type = wdCurrentDateText) Or _ 983 (myFormField.TextInput.Type = wdCurrentTimeText) Then 984 AddIssueDetailsNote myIssue, 0, getTextFormFieldTypeAsString(myFormField.TextInput.Type) & _ 985 " " & RID_STR_WORD_NOTE_FORM_FIELD_TYPE_LOST 986 bLostType = True 987 End If 988 989 If (myFormField.TextInput.Format <> "") Then 990 myIssue.Attributes.Add getTextFormFieldFormatAsString(myFormField.TextInput.Type) 991 myIssue.Values.Add myFormField.TextInput.Format 992 End If 993 994 'Default text 995 If (myFormField.TextInput.Default <> "") Then 996 myIssue.Attributes.Add getTextFormFieldDefaultAsString(myFormField.TextInput.Type) 997 myIssue.Values.Add myFormField.TextInput.Default 998 End If 999 1000 'Maximum text 1001 If (myFormField.TextInput.Width <> 0) Then 1002 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_MAX_LENGTH 1003 myIssue.Values.Add myFormField.TextInput.Width 1004 End If 1005 1006 'Fill-in disabled 1007 If (myFormField.Enabled = False) And (Not bLostType) Then 1008 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_FILLIN_ENABLED 1009 myIssue.Values.Add RID_STR_WORD_FALSE 1010 End If 1011 End If 1012 1013 'Help Key(F1) 1014 If (myFormField.OwnHelp And myFormField.HelpText <> "") Then 1015 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_HELP_KEY_F1_OWN_TEXT 1016 myIssue.Values.Add myFormField.HelpText 1017 ElseIf ((Not myFormField.OwnHelp) And myFormField.HelpText <> "") Then 1018 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_HELP_KEY_F1_AUTO_TEXT 1019 myIssue.Values.Add myFormField.HelpText 1020 End If 1021 1022 'StatusHelp 1023 If (myFormField.OwnStatus And myFormField.StatusText <> "") Then 1024 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_STATUS_BAR_HELP_OWN_TEXT 1025 myIssue.Values.Add myFormField.StatusText 1026 ElseIf ((Not myFormField.OwnStatus) And myFormField.StatusText <> "") Then 1027 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_STATUS_BAR_HELP_AUTO_TEXT 1028 myIssue.Values.Add myFormField.StatusText 1029 End If 1030 1031 'Macros 1032 If (myFormField.EntryMacro <> "") Then 1033 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_ENTRY_MACRO 1034 myIssue.Values.Add myFormField.EntryMacro 1035 End If 1036 If (myFormField.ExitMacro <> "") Then 1037 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_EXIT_MACRO 1038 myIssue.Values.Add myFormField.ExitMacro 1039 End If 1040 If (myFormField.EntryMacro <> "") Or (myFormField.ExitMacro <> "") Then 1041 mAnalysis.MacroNumFieldsUsingMacros = 1 + mAnalysis.MacroNumFieldsUsingMacros 1042 End If 1043 1044 'LockedField 1045 If (myFormField.Enabled = False) And (myFormField.Type <> wdFieldFormTextInput) Then 1046 myIssue.Attributes.Add RID_STR_WORD_ATTRIBUTE_FORM_FIELD_LOCKED 1047 myIssue.Values.Add RID_STR_WORD_TRUE 1048 End If 1049 1050 mAnalysis.IssuesCountArray(CID_FIELDS) = _ 1051 mAnalysis.IssuesCountArray(CID_FIELDS) + 1 1052 1053 mAnalysis.Issues.Add myIssue 1054 1055FinalExit: 1056 Set myIssue = Nothing 1057 Exit Sub 1058 1059HandleErrors: 1060 'Log first occurence for this doc 1061 If Not mbFormFieldErrorLogged Then 1062 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1063 mbFormFieldErrorLogged = True 1064 End If 1065 Resume FinalExit 1066End Sub 1067 1068 1069Sub Analyze_TOA(currDoc As Document) 1070 On Error GoTo HandleErrors 1071 Dim currentFunctionName As String 1072 currentFunctionName = "Analyze_TOA" 1073 1074 Dim toa As TableOfAuthorities 1075 Dim myIssue As IssueInfo 1076 Dim myRng As Range 1077 1078 For Each toa In currDoc.TablesOfAuthorities 1079 Set myRng = toa.Range 1080 myRng.start = myRng.End 1081 Set myIssue = New IssueInfo 1082 myRng.Select 1083 1084 Dim TabLeaderAsString As String 1085 Select Case toa.TabLeader 1086 Case wdTabLeaderDashes 1087 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_DASHES 1088 Case wdTabLeaderDots 1089 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_DOTS 1090 Case wdTabLeaderHeavy 1091 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_HEAVY 1092 Case wdTabLeaderLines 1093 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_LINES 1094 Case wdTabLeaderMiddleDot 1095 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_MIDDLEDOT 1096 Case wdTabLeaderSpaces 1097 TabLeaderAsString = RID_STR_WORD_ENUMERATION_INDEX_LEADER_SPACES 1098 Case Else 1099 TabLeaderAsString = RID_STR_WORD_ENUMERATION_UNKNOWN 1100 End Select 1101 1102 Dim FormatAsString As String 1103 Select Case currDoc.TablesOfAuthorities.Format 1104 Case wdTOAClassic 1105 FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_CLASSIC 1106 Case wdTOADistinctive 1107 FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_DISTINCTIVE 1108 Case wdTOAFormal 1109 FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_FORMAL 1110 Case wdTOASimple 1111 FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_SIMPLE 1112 Case wdTOATemplate 1113 FormatAsString = RID_STR_WORD_ENUMERATION_INDEX_TABLES_FROM_TEMPLATE 1114 Case Else 1115 FormatAsString = RID_STR_WORD_ENUMERATION_UNKNOWN 1116 End Select 1117 1118 With myIssue 1119 .IssueID = CID_INDEX_AND_REFERENCES 1120 .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES 1121 .SubType = RID_STR_WORD_SUBISSUE_TABLE_OF_AUTHORITIES 1122 .Location = .CLocationPage 1123 1124 .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES 1125 .SubTypeXML = CSTR_SUBISSUE_TABLE_OF_AUTHORITIES 1126 .locationXML = .CXMLLocationPage 1127 1128 .SubLocation = myRng.Information(wdActiveEndPageNumber) 1129 .Attributes.Add RID_STR_WORD_ATTRIBUTE_LEADER 1130 .Values.Add TabLeaderAsString 1131 1132 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TOA_MIGRATE_AS_PLAIN_TEXT 1133 1134 mAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ 1135 mAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 1136 End With 1137 1138 mAnalysis.Issues.Add myIssue 1139 Set myIssue = Nothing 1140 Set myRng = Nothing 1141 Next 1142FinalExit: 1143 Set myIssue = Nothing 1144 Set myRng = Nothing 1145 Exit Sub 1146 1147HandleErrors: 1148 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1149 Resume FinalExit 1150End Sub 1151 1152Sub Analyze_TOAField(myField As Field) 1153 On Error GoTo HandleErrors 1154 Dim currentFunctionName As String 1155 currentFunctionName = "Analyze_TOAField" 1156 1157 Dim toa As TableOfAuthorities 1158 Dim myIssue As IssueInfo 1159 1160 If myField.Type = wdFieldTOAEntry Then 1161 Set myIssue = New IssueInfo 1162 myField.Select 1163 1164 With myIssue 1165 .IssueID = CID_FIELDS 1166 .IssueType = RID_STR_WORD_ISSUE_FIELDS 1167 .SubType = RID_STR_WORD_SUBISSUE_TABLE_OF_AUTHORITIES_FIELD 1168 .Location = .CLocationPage 1169 1170 .IssueTypeXML = CSTR_ISSUE_FIELDS 1171 .SubTypeXML = CSTR_SUBISSUE_TABLE_OF_AUTHORITIES_FIELD 1172 .locationXML = .CXMLLocationPage 1173 1174 .SubLocation = Selection.Information(wdActiveEndPageNumber) 1175 .Line = Selection.Information(wdFirstCharacterLineNumber) 1176 .column = Selection.Information(wdFirstCharacterColumnNumber) 1177 1178 .Attributes.Add RID_STR_WORD_ATTRIBUTE_FIELD_TEXT 1179 .Values.Add myField.Code.Text 1180 1181 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TOA_FIELD_LOST_ON_ROUNDTRIP 1182 1183 mAnalysis.IssuesCountArray(CID_FIELDS) = _ 1184 mAnalysis.IssuesCountArray(CID_FIELDS) + 1 1185 End With 1186 1187 mAnalysis.Issues.Add myIssue 1188 Set myIssue = Nothing 1189 End If 1190 1191FinalExit: 1192 Set myIssue = Nothing 1193 Exit Sub 1194 1195HandleErrors: 1196 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1197 Resume FinalExit 1198End Sub 1199 1200Sub Analyze_Tables_Borders(currDoc As Document) 1201 On Error GoTo HandleErrors 1202 Dim currentFunctionName As String 1203 currentFunctionName = "Analyze_Tables_Borders" 1204 Dim myIssue As IssueInfo 1205 Set myIssue = New IssueInfo 1206 Dim aTable As Table 1207 Dim invalidBorders As String 1208 1209 For Each aTable In currDoc.Tables 1210 invalidBorders = GetInvalidBorder(aTable) 1211 If invalidBorders <> "" Then 1212 aTable.Range.Select 1213 Set myIssue = New IssueInfo 1214 With myIssue 1215 .IssueID = CID_TABLES 1216 .IssueType = RID_STR_WORD_ISSUE_TABLES 1217 .SubType = RID_STR_WORD_SUBISSUE_BORDER_STYLES 1218 .Location = .CLocationPage 1219 1220 .IssueTypeXML = CSTR_ISSUE_TABLES 1221 .SubTypeXML = CSTR_SUBISSUE_BORDER_STYLES 1222 .locationXML = .CXMLLocationPage 1223 1224 .SubLocation = Selection.Information(wdActiveEndPageNumber) 1225 .Line = Selection.Information(wdFirstCharacterLineNumber) 1226 .column = Selection.Information(wdFirstCharacterColumnNumber) 1227 1228 .Attributes.Add RID_STR_WORD_ATTRIBUTE_BORDERS_NOT_DISPLAYING 1229 .Values.Add invalidBorders 1230 1231 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_TABLE_BORDER 1232 1233 mAnalysis.IssuesCountArray(CID_TABLES) = mAnalysis.IssuesCountArray(CID_TABLES) + 1 1234 End With 1235 1236 mAnalysis.Issues.Add myIssue 1237 Set myIssue = Nothing 1238 End If 1239 Next aTable 1240FinalExit: 1241 Set myIssue = Nothing 1242 Exit Sub 1243 1244HandleErrors: 1245 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1246 Resume FinalExit 1247End Sub 1248Function GetInvalidBorder(aTable As Table) As String 1249 1250 Dim theResult As String 1251 theResult = "" 1252 1253 If IsInvalidBorderStyle(aTable.Borders(wdBorderTop).LineStyle) Then 1254 theResult = theResult + "Top, " 1255 End If 1256 If IsInvalidBorderStyle(aTable.Borders(wdBorderBottom).LineStyle) Then 1257 theResult = theResult + "Bottom, " 1258 End If 1259 If IsInvalidBorderStyle(aTable.Borders(wdBorderDiagonalDown).LineStyle) Then 1260 theResult = theResult + "Down Diagonal, " 1261 End If 1262 If IsInvalidBorderStyle(aTable.Borders(wdBorderDiagonalUp).LineStyle) Then 1263 theResult = theResult + "Up Diagonal, " 1264 End If 1265 If IsInvalidBorderStyle(aTable.Borders(wdBorderHorizontal).LineStyle) Then 1266 theResult = theResult + "Horizontal, " 1267 End If 1268 If IsInvalidBorderStyle(aTable.Borders(wdBorderLeft).LineStyle) Then 1269 theResult = theResult + "Left, " 1270 End If 1271 If IsInvalidBorderStyle(aTable.Borders(wdBorderRight).LineStyle) Then 1272 theResult = theResult + "Right, " 1273 End If 1274 If IsInvalidBorderStyle(aTable.Borders(wdBorderVertical).LineStyle) Then 1275 theResult = theResult + "Vertical, " 1276 End If 1277 1278 If theResult <> "" Then 1279 theResult = Left(theResult, (Len(theResult) - 2)) + "." 1280 End If 1281 1282 GetInvalidBorder = theResult 1283End Function 1284 1285Function IsInvalidBorderStyle(aStyle As WdLineStyle) As Boolean 1286 1287 Dim IsInvalid As Boolean 1288 1289 Select Case aStyle 1290 Case wdLineStyleDot, wdLineStyleDashSmallGap, wdLineStyleDashLargeGap, wdLineStyleDashDot, _ 1291 wdLineStyleDashDotDot, wdLineStyleTriple, wdLineStyleThinThickThinSmallGap, wdLineStyleThinThickMedGap, _ 1292 wdLineStyleThickThinMedGap, wdLineStyleThinThickThinMedGap, wdLineStyleThinThickLargeGap, _ 1293 wdLineStyleThickThinLargeGap, wdLineStyleThinThickThinLargeGap, wdLineStyleSingleWavy, _ 1294 wdLineStyleDoubleWavy, wdLineStyleDashDotStroked, wdLineStyleEmboss3D, wdLineStyleEngrave3D 1295 IsInvalid = True 1296 Case Else 1297 IsInvalid = False 1298 End Select 1299 1300 IsInvalidBorderStyle = IsInvalid 1301 1302End Function 1303 1304Private Sub Class_Initialize() 1305 Set mAnalysis = New DocumentAnalysis 1306End Sub 1307Private Sub Class_Terminate() 1308 Set mAnalysis = Nothing 1309End Sub 1310 1311Public Property Get Results() As DocumentAnalysis 1312 Set Results = mAnalysis 1313End Property 1314 1315Sub Analyze_NumberingTabs(currDoc As Document, docAnalysis As DocumentAnalysis) 1316 On Error GoTo HandleErrors 1317 Dim currentFunctionName As String 1318 currentFunctionName = "Analyze_NumberingTabs" 1319 1320 Dim tb As TabStop 1321 Dim customTabPos As Single 1322 Dim tabs As Integer 1323 Dim listLvl As Long 1324 Dim tp As Single 1325 Dim bHasAlignmentProblem As Boolean 1326 Dim bHasTooManyTabs As Boolean 1327 Dim myIssue As IssueInfo 1328 Dim p As Object 1329 1330 bHasAlignmentProblem = False 1331 bHasTooManyTabs = False 1332 1333 For Each p In currDoc.ListParagraphs 1334 tabs = 0 1335 For Each tb In p.TabStops 1336 If tb.customTab Then 1337 tabs = tabs + 1 1338 customTabPos = tb.Position 1339 End If 1340 Next 1341 1342 If tabs = 1 Then 1343 listLvl = p.Range.ListFormat.ListLevelNumber 1344 tp = p.Range.ListFormat.ListTemplate.ListLevels.item(listLvl).TabPosition 1345 If (p.Range.ListFormat.ListTemplate.ListLevels.item(listLvl).Alignment <> _ 1346 wdListLevelAlignLeft) Then 1347 ' ERROR: alignment problem 1348 bHasAlignmentProblem = True 1349 End If 1350 1351 If tp <> customTabPos Then 1352 p.Range.InsertBefore ("XXXXX") 1353 End If 1354 'OK - at least heuristically 1355 Else 1356 'ERROR: too many tabs 1357 bHasTooManyTabs = True 1358 End If 1359 Next 1360 1361 If (bHasAlignmentProblem) Then 1362 Set myIssue = New IssueInfo 1363 1364 With myIssue 1365 .IssueID = CID_INDEX_AND_REFERENCES 1366 .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES 1367 .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_TAB_ALIGNMENT 1368 .Location = .CLocationDocument 'Location string 1369 1370 .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES 1371 .SubTypeXML = CSTR_SUBISSUE_NUMBERING_TAB_ALIGNMENT 1372 .locationXML = .CXMLLocationDocument 1373 1374 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_TAB_ALIGNMENT 1375 1376 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ 1377 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 1378 End With 1379 docAnalysis.Issues.Add myIssue 1380 Set myIssue = Nothing 1381 End If 1382 1383 If (bHasTooManyTabs) Then 1384 Set myIssue = New IssueInfo 1385 1386 With myIssue 1387 .IssueID = CID_INDEX_AND_REFERENCES 1388 .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES 1389 .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_TAB_OVERFLOW 1390 .Location = .CLocationDocument 'Location string 1391 1392 .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES 1393 .SubTypeXML = CSTR_SUBISSUE_NUMBERING_TAB_OVERFLOW 1394 .locationXML = .CXMLLocationDocument 1395 1396 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_TAB_OVERFLOW 1397 1398 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ 1399 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 1400 End With 1401 docAnalysis.Issues.Add myIssue 1402 Set myIssue = Nothing 1403 End If 1404 1405FinalExit: 1406 Exit Sub 1407 1408HandleErrors: 1409 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1410 Set myIssue = Nothing 1411 Resume FinalExit 1412End Sub 1413 1414Sub Analyze_Numbering(currDoc As Document, docAnalysis As DocumentAnalysis) 1415 On Error GoTo HandleErrors 1416 Dim currentFunctionName As String 1417 currentFunctionName = "Analyze_Numbering" 1418 1419 Dim myIssue As IssueInfo 1420 Dim nFormatProblems As Integer 1421 Dim nAlignmentProblems As Integer 1422 nFormatProblems = 0 1423 nAlignmentProblems = 0 1424 1425 Dim lt As ListTemplate 1426 Dim lvl As ListLevel 1427 Dim I, l_, p1, p2, v1, v2 As Integer 1428 Dim display_levels As Integer 1429 Dim fmt, prefix, postfix, res As String 1430 1431 For Each lt In currDoc.ListTemplates 1432 l_ = 0 1433 For Each lvl In lt.ListLevels 1434 l_ = l_ + 1 1435 'Selection.TypeText Text:="List Number Format " + lvl.NumberFormat 1436 'Apply Heuristic 1437 fmt = lvl.NumberFormat 1438 p1 = InStr(fmt, "%") 1439 p2 = InStrRev(fmt, "%") 1440 v1 = val(Mid(fmt, p1 + 1, 1)) 1441 v2 = val(Mid(fmt, p2 + 1, 1)) 1442 display_levels = v2 - v1 + 1 1443 prefix = Mid(fmt, 1, p1 - 1) 1444 postfix = Mid(fmt, p2 + 2) 1445 'Check Heuristic 1446 res = prefix 1447 For I = 2 To display_levels 1448 res = "%" + Trim(Str(l_ - I + 1)) + "." + res 1449 Next 1450 res = res + "%" + Trim(Str(l_)) + postfix 1451 If (StrComp(res, fmt) <> 0) Then 1452 nFormatProblems = nFormatProblems + 1 1453 'Selection.TypeText Text:="Label Problem: NumberFormat=" + fmt + " Heuristic=" + res 1454 End If 1455 1456 'check alignment 1457 If (lvl.NumberPosition <> wdListLevelAlignLeft) Then 1458 nAlignmentProblems = nAlignmentProblems + 1 1459 'Selection.TypeText Text:="Number alignment problem" 1460 End If 1461 Next 1462 Next 1463 1464 If (nFormatProblems > 0) Then 1465 Set myIssue = New IssueInfo 1466 1467 With myIssue 1468 .IssueID = CID_INDEX_AND_REFERENCES 1469 .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES 1470 .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_FORMAT 1471 .Location = .CLocationDocument 'Location string 1472 1473 .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES 1474 .SubTypeXML = CSTR_SUBISSUE_NUMBERING_FORMAT 1475 .locationXML = .CXMLLocationDocument 1476 1477 .Attributes.Add RID_STR_WORD_ATTRIBUTE_COUNT 1478 .Values.Add nFormatProblems 1479 1480 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_FORMAT 1481 1482 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ 1483 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 1484 End With 1485 docAnalysis.Issues.Add myIssue 1486 Set myIssue = Nothing 1487 End If 1488 1489 If (nAlignmentProblems > 0) Then 1490 Set myIssue = New IssueInfo 1491 1492 With myIssue 1493 .IssueID = CID_INDEX_AND_REFERENCES 1494 .IssueType = RID_STR_WORD_ISSUE_INDEX_AND_REFERENCES 1495 .SubType = RID_STR_WORD_SUBISSUE_NUMBERING_ALIGNMENT 1496 .Location = .CLocationDocument 'Location string 1497 1498 .IssueTypeXML = CSTR_ISSUE_INDEX_AND_REFERENCES 1499 .SubTypeXML = CSTR_SUBISSUE_NUMBERING_ALIGNMENT 1500 .locationXML = .CXMLLocationDocument 1501 1502 .Attributes.Add RID_STR_WORD_ATTRIBUTE_COUNT 1503 .Values.Add nAlignmentProblems 1504 1505 AddIssueDetailsNote myIssue, 0, RID_STR_WORD_NOTE_NUMBERING_ALIGNMENT 1506 1507 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) = _ 1508 docAnalysis.IssuesCountArray(CID_INDEX_AND_REFERENCES) + 1 1509 End With 1510 docAnalysis.Issues.Add myIssue 1511 Set myIssue = Nothing 1512 End If 1513 1514FinalExit: 1515 Exit Sub 1516 1517HandleErrors: 1518 WriteDebug currentFunctionName & " : " & mAnalysis.name & ": " & Err.Number & " " & Err.Description & " " & Err.Source 1519 Set myIssue = Nothing 1520 Resume FinalExit 1521End Sub 1522 1523