I have recently migrated Office 2003 to Office 2007, Most of Word VBA Macro code written in Office 2003 Word VBA, same code when I try to execute in Word 2007 VBA I am getting huge performance issue and all most 10 time Word 2007 is slow compare to Word 2003
Please find the below code writting in Word VBA 2003
Private Sub cmdChk_Click()
Dim COMMONERRORS, OTHERERRORS
Dim DocType, PageFormat As String
Dim PageCount, lastpageno, position As Integer
Dim FirstPos, PgNo
Dim Numbers
Dim TotalLine, TotalPage As Integer
Dim ParaJustifyCount
Dim TotalErrors
Dim LeadingSpaceCount
Dim TotalLErrors
Dim x, y, z, AA
Dim TOC_no
Dim StartTime, EndTime
StartTime = DateTime.Now
cmdChk.Visible = False
cmbDocType.Visible = False
cmbPageFormat.Visible = False
cmbTOC.Visible = False
Label1.Visible = False
Label2.Visible = False
frmPre_DQA.Height = 65
frmPre_DQA.Width = 220
Label3.Visible = True
ProgressBar1.Visible = True
lblPercent.Visible = True
Label5.Visible = True
frmPre_DQA.Caption = "Job in Progress...."
MousePointer = fmMousePointerHourGlass
DocType = cmbDocType.Value
PageFormat = cmbPageFormat.Value
Dim T_Margin, B_Margin, L_Margin, R_Margin, Gttr, H_Dist, F_Dist
Dim Final_TM, Final_BM, Final_LM, Final_RM, Final_Gttr, Final_HD, Final_FD
Dim ER1, ER2, ER3, ER4 As String
Label3.Caption = "Checking Page Setup..."
DoEvents
ProgressBar1.Value = 1
T_Margin = ActiveDocument.PageSetup.TopMargin
B_Margin = ActiveDocument.PageSetup.BottomMargin
L_Margin = ActiveDocument.PageSetup.LeftMargin
R_Margin = ActiveDocument.PageSetup.RightMargin
Gttr = ActiveDocument.PageSetup.Gutter
H_Dist = ActiveDocument.PageSetup.HeaderDistance
F_Dist = ActiveDocument.PageSetup.FooterDistance
Final_TM = PointsToInches(ActiveDocument.PageSetup.TopMargin)
Final_BM = PointsToInches(ActiveDocument.PageSetup.BottomMargin)
Final_LM = PointsToInches(ActiveDocument.PageSetup.LeftMargin)
Final_RM = PointsToInches(ActiveDocument.PageSetup.RightMargin)
Final_Gttr = PointsToInches(ActiveDocument.PageSetup.Gutter)
Final_HD = PointsToInches(ActiveDocument.PageSetup.HeaderDistance)
Final_FD = PointsToInches(ActiveDocument.PageSetup.FooterDistance)
If cmbPageFormat.Value = "5.5 X 8.5" Then
If T_Margin <> 36 Then
ER2 = "Set Top Margin to 0.5 which is " & Final_TM
End If
If B_Margin <> 36 Then
ER2 = ER2 & vbNewLine & "Set Bottom Margin to 0.5 which is " & Final_BM
End If
If L_Margin <> 36 Then
ER2 = ER2 & vbNewLine & "Set Left Margin to 0.5 which is " & Final_LM
End If
If R_Margin <> 36 Then
ER2 = ER2 & vbNewLine & "Set Right Margin to 0.5 which is " & Final_RM
End If
If Gttr <> 0 Then
ER2 = ER2 & vbNewLine & "Set Gutter to 0 which is " & Final_Gttr
End If
If H_Dist <> 18 Then
ER2 = ER2 & vbNewLine & "Set Header Distance to .25 which is " & Final_HD
End If
If F_Dist <> 18 Then
ER2 = ER2 & vbNewLine & "Set Footer Distance to .25 which is " & Final_FD
End If
If (ActiveDocument.PageSetup.MirrorMargins <> 0) Then
ER2 = ER2 & vbNewLine & "Uncheck Mirror Margin"
End If
If (ActiveDocument.PageSetup.PageHeight <> 612) Then
ER2 = ER2 & vbNewLine & "Set Page Height to 8.5"
End If
If (ActiveDocument.PageSetup.PageWidth <> 396) Then
ER2 = ER2 & vbNewLine & "Set Page Width to 5.5"
End If
If (ActiveDocument.PageSetup.PaperSize <> 22) Then
ER2 = ER2 & vbNewLine & "Set Paper size to custom"
End If
If (ActiveDocument.PageSetup.Orientation <> 0) Then
ER2 = ER2 & vbNewLine & "Set Page orientation to Portrait"
End If
If (ActiveDocument.PageSetup.OddAndEvenPagesHeaderFooter <> -1) Then
ER2 = ER2 & vbNewLine & "Check Different header and footer option"
End If
If (ActiveDocument.PageSetup.VerticalAlignment <> 0) Then
ER2 = ER2 & vbNewLine & "Set Vertical Allignment to Top in Layout section"
End If
Else
If T_Margin <> 36 Then
ER2 = ER2 & vbNewLine & "Set Top Margin to 0.5 which is " & Final_TM
End If
ProgressBar1.Value = 1
lblPercent.Caption = 1
DoEvents
If B_Margin <> 57.6 Then
ER2 = ER2 & vbNewLine & "Set Bottom Margin to 0.8 which is " & Final_BM
End If
ProgressBar1.Value = 2
lblPercent.Caption = 2
DoEvents
If L_Margin <> 28.8 Then
ER2 = ER2 & vbNewLine & "Set Inside Margin to 0.4 which is " & Final_LM
End If
ProgressBar1.Value = 3
lblPercent.Caption = 3
DoEvents
If R_Margin <> 46.8 Then
ER2 = ER2 & vbNewLine & "Set Outside Margin to 0.65 which is " & Final_RM
End If
ProgressBar1.Value = 4
lblPercent.Caption = 4
DoEvents
If Gttr <> 18 Then
ER2 = ER2 & vbNewLine & "Set Gutter to 0.25 which is " & Final_Gttr
End If
ProgressBar1.Value = 5
lblPercent.Caption = 5
DoEvents
If H_Dist <> 28.8 Then
ER2 = ER2 & vbNewLine & "Set Header Distance to 0.4 which is " & Final_HD
End If
ProgressBar1.Value = 6
lblPercent.Caption = 6
DoEvents
If F_Dist <> 28.8 Then
ER2 = ER2 & vbNewLine & "Set Footer Distance to 0.4 which is " & Final_FD
End If
ProgressBar1.Value = 7
lblPercent.Caption = 7
DoEvents
If (ActiveDocument.PageSetup.MirrorMargins <> -1) Then
ER2 = ER2 & vbNewLine & "Check Mirror Margin"
End If
ProgressBar1.Value = 8
lblPercent.Caption = 8
DoEvents
If (ActiveDocument.PageSetup.PageHeight <> 792) Then
ER2 = ER2 & vbNewLine & "Set Page Height to 11"
End If
ProgressBar1.Value = 9
lblPercent.Caption = 9
DoEvents
If (ActiveDocument.PageSetup.PageWidth <> 612) Then
ER2 = ER2 & vbNewLine & "Set Page Width to 8.5"
End If
ProgressBar1.Value = 10
lblPercent.Caption = 10
DoEvents
If (ActiveDocument.PageSetup.PaperSize <> 2) Then
ER2 = ER2 & vbNewLine & "Set Paper size to Letter"
End If
If (ActiveDocument.PageSetup.Orientation <> 0) Then
ER2 = ER2 & vbNewLine & "Set Page orientation to Portrait"
End If
If (ActiveDocument.PageSetup.OddAndEvenPagesHeaderFooter <> -1) Then
ER2 = ER2 & vbNewLine & "Check Different header and footer option"
End If
If (ActiveDocument.PageSetup.VerticalAlignment <> 0) Then
ER2 = ER2 & vbNewLine & "Set Vertical Allignment to Top in Layout section"
End If
End If
If ER2 <> "" Then
ER1 = ER1 & ER2
End If
Dim var1, var2, var3, var4
Dim I, j, m, n, o, GrayCount, TotalGrayCount, totaltables As Integer
Dim TotalCell, istable, TotalTUCount, PBPAGE, PBLINE, TUCount, ActualValue, TotalValue As Integer
Dim SingleValue, ErrorPageCount, Totalerrorpagecount
Label3.Caption = "Checking Page Count..."
DoEvents
PageCount = Selection.Information(wdNumberOfPagesInDocument)
var1 = PageCount Mod 2
If var1 = 1 Then
ER1 = ER1 & vbNewLine & "File has not Even number of Pages"
End If
ProgressBar1.Value = 10
Label3.Caption = "Checking Footer..."
DoEvents
ProgressBar1.Value = 11
If PageFormat = "5.5 X 8.5" Then
Selection.HomeKey unit:=wdStory
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or _
ActiveWindow.ActivePane.View.Type = wdMasterView Then
ActiveWindow.ActivePane.View.Type = wdPageView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.WholeStory
If (Selection.Paragraphs.TabStops.Item(1).position <> 324) Then
ER3 = ER3 & vbNewLine & "Wrong Tab Size in odd Footer"
End If
Selection.MoveLeft unit:=wdWord, Count:=2, Extend:=wdExtend
var2 = (Selection.Text)
If DocType <> var2 Then
ER3 = ER3 & vbNewLine & DocType & " not spelled correctly in Odd page"
End If
Selection.WholeStory
If (Selection.Font.Size <> 10 Or Selection.Font.Name <> "Times New Roman") Then
ER3 = ER3 & vbNewLine & "Wrong size or font type in Odd page"
End If
ActiveWindow.ActivePane.View.NextHeaderFooter
Selection.MoveRight unit:=wdWord, Count:=2
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
var3 = (Selection.Text)
If DocType <> var3 Then
ER3 = ER3 & vbNewLine & DocType & " not spelled correctly in Even page"
End If
Selection.WholeStory
If (Selection.Paragraphs.TabStops.Item(1).position <> 324) Then
ER3 = ER3 & vbNewLine & "Wrong Tab Size in Even Footer"
End If
If (Selection.Font.Size <> 10 Or Selection.Font.Name <> "Times New Roman") Then
ER3 = ER3 & vbNewLine & "Wrong size or font type in Even page"
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Else
Selection.HomeKey unit:=wdStory
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or _
ActiveWindow.ActivePane.View.Type = wdMasterView Then
ActiveWindow.ActivePane.View.Type = wdPageView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
If (Selection.ParagraphFormat.LeftIndent <> InchesToPoints(0)) Then
ER3 = ER3 & vbNewLine & "Left Position is incorrect in Page Footer"
End If
Selection.WholeStory
If (Selection.Paragraphs.TabStops.Item(1).position <> 518.4) Then
ER3 = ER3 & vbNewLine & "Wrong Tab Size in Page Footer"
End If
Selection.MoveLeft unit:=wdWord, Count:=2, Extend:=wdExtend
var3 = (Selection.Text)
If cmbDocType <> var3 Then
ER3 = ER3 & vbNewLine & DocType & " not spelled correctly in Odd Page"
End If
Selection.WholeStory
If (Selection.Font.Size <> 10 Or Selection.Font.Name <> "Times New Roman") Then
ER3 = ER3 & vbNewLine & "Wrong size or font type in Odd page"
End If
ActiveWindow.ActivePane.View.NextHeaderFooter
If (Selection.ParagraphFormat.LeftIndent <> InchesToPoints(0)) Then
ER3 = ER3 & vbNewLine & "Left Position is incorrect in Page Footer"
End If
Selection.MoveRight unit:=wdWord, Count:=2
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
var4 = (Selection.Text)
If cmbDocType <> var4 Then
ER3 = ER3 & vbNewLine & DocType & " not spelled correctly in Even page"
End If
Selection.WholeStory
If (Selection.Paragraphs.TabStops.Item(1).position <> 518.4) Then
ER3 = ER3 & vbNewLine & "Wrong Tab Size in Page Footer"
End If
If (Selection.Font.Size <> 10 Or Selection.Font.Name <> "Times New Roman") Then
ER3 = ER3 & vbNewLine & "Wrong size or font type in Even page"
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
End If
If ER3 <> "" Then
ER1 = ER1 & ER3
End If
COMMONERRORS = ER1
If COMMONERRORS <> "" Then
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 60.4, _
28.8, 187.2, 170.4).Select
Selection.ShapeRange.Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 153)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 102, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = 170.65
Selection.ShapeRange.Width = 187.2
Selection.ShapeRange.TextFrame.MarginLeft = 5.04
Selection.ShapeRange.TextFrame.MarginRight = 5.04
Selection.ShapeRange.TextFrame.MarginTop = 5.04
Selection.ShapeRange.TextFrame.MarginBottom = 5.04
Selection.ShapeRange.RelativeHorizontalPosition = _
wdRelativeHorizontalPositionColumn
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionParagraph
Selection.ShapeRange.Left = InchesToPoints(0.09)
Selection.ShapeRange.Top = InchesToPoints(-0.1)
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.WrapFormat.Type = wdWrapNone
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
Selection.TypeText Text:=COMMONERRORS
Selection.WholeStory
Selection.Font.ColorIndex = wdBlue
Selection.Font.Size = 8
Selection.HomeKey unit:=wdLine
Selection.TypeText Text:="Common Errors"
Selection.HomeKey unit:=wdLine, Extend:=wdExtend
Selection.Font.Bold = True
Selection.Font.ColorIndex = wdViolet
Selection.EndKey unit:=wdLine
Selection.TypeParagraph
Selection.MoveDown unit:=wdScreen, Count:=1
Selection.HomeKey unit:=wdStory
End If
ProgressBar1.Value = 13
lblPercent.Caption = 13
DoEvents
Label3.Caption = "Checking Para Justify..."
DoEvents
Selection.EndKey unit:=wdStory
numberofpages = ActiveDocument.BuiltInDocumentProperties("Number of Pages")
lastpageno = Selection.Information(wdActiveEndPageNumber)
position = Selection.Information(wdFirstCharacterLineNumber)
Selection.HomeKey unit:=wdStory
x = 13
I = 13
For a = 0 To numberofpages
If Selection.Information(wdWithInTable) <> True Then
If Asc(Selection.Text) <> 13 And Asc(Selection.Text) <> 12 Then
If Selection.ParagraphFormat.Alignment = wdAlignParagraphLeft Then
Selection.HomeKey
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[!^013]*^013"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = True
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Font.ColorIndex = wdRed
End If
End If
End If
I = I + 0.01
j = I
x = I
If j < 40 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
If (a = 416) Then
om = 1
End If
Next a
ProgressBar1.Value = 40
If cmbTOC.Value = "YES" Then
totaltables = ActiveDocument.Tables.Count
Selection.HomeKey unit:=wdStory
For I = 1 To totaltables
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=I, Name:=""
Selection.MoveDown unit:=wdLine, Count:=1
If Selection.Information(wdWithInTable) = True Then
If Selection.Cells.Shading.BackgroundPatternColor = wdColorGray05 Then
TOC_no = I
Selection.Tables(1).Select
Selection.HomeKey unit:=wdLine
If Selection.Cells.Shading.BackgroundPatternColor <> wdColorGray05 Then
If Selection.Cells.Shading.BackgroundPatternColor <> wdColorGray70 Then
Toc_Table_Error = "Shading color is not 70 percent gray"
End If
Selection.EndKey unit:=wdLine, Extend:=wdExtend
Selection.MoveLeft unit:=wdCharacter, Count:=1, Extend:=wdExtend
If Selection.Font.Size <> 9 Or Selection.Font.Name <> "Arial" Or Selection.Font.ColorIndex <> wdWhite Then
Toc_Table_Error1 = "Toc Heading is wrong"
End If
End If
Selection.Tables(1).Select
If Selection.Borders(wdBorderBottom).LineStyle = Options.DefaultBorderLineStyle Then
Toc_Table_Error2 = "Toc underline should be none"
End If
Toc_Table_Error_Final = Toc_Table_Error + vbNewLine + Toc_Table_Error1 + vbNewLine + Toc_Table_Error2
Else
GoTo NextLevel:
End If
If Toc_Table_Error_Final = vbNewLine + vbNewLine Then
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 260.4, _
28.8, 87.2, 70.4).Select
Selection.ShapeRange.Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 153)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 102, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.TextFrame.MarginLeft = 5.04
Selection.ShapeRange.TextFrame.MarginRight = 5.04
Selection.ShapeRange.TextFrame.MarginTop = 5.04
Selection.ShapeRange.TextFrame.MarginBottom = 5.04
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionParagraph
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.WrapFormat.Type = wdWrapNone
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
Selection.TypeText Text:="No Error Found for TOC Table"
Selection.WholeStory
Selection.Font.ColorIndex = wdBlue
Selection.Font.Size = 8
Selection.MoveDown unit:=wdScreen, Count:=1
Selection.HomeKey unit:=wdStory
Else
ActiveDocument.Shapes.AddTextbox(msoTextOrientationHorizontal, 260.4, _
28.8, 87.2, 70.4).Select
Selection.ShapeRange.Select
Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 153)
Selection.ShapeRange.Fill.Visible = msoTrue
Selection.ShapeRange.Fill.Solid
Selection.ShapeRange.TextFrame.TextRange.Select
Selection.Collapse
Selection.ShapeRange.Fill.Transparency = 0#
Selection.ShapeRange.Line.Weight = 2.25
Selection.ShapeRange.Line.DashStyle = msoLineSolid
Selection.ShapeRange.Line.Style = msoLineSingle
Selection.ShapeRange.Line.Transparency = 0#
Selection.ShapeRange.Line.Visible = msoTrue
Selection.ShapeRange.Line.ForeColor.RGB = RGB(255, 102, 0)
Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.TextFrame.MarginLeft = 5.04
Selection.ShapeRange.TextFrame.MarginRight = 5.04
Selection.ShapeRange.TextFrame.MarginTop = 5.04
Selection.ShapeRange.TextFrame.MarginBottom = 5.04
Selection.ShapeRange.RelativeVerticalPosition = _
wdRelativeVerticalPositionParagraph
Selection.ShapeRange.LockAnchor = False
Selection.ShapeRange.WrapFormat.Type = wdWrapNone
Selection.ShapeRange.WrapFormat.Side = wdWrapBoth
Selection.ShapeRange.WrapFormat.DistanceTop = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceBottom = InchesToPoints(0)
Selection.ShapeRange.WrapFormat.DistanceLeft = InchesToPoints(0.13)
Selection.ShapeRange.WrapFormat.DistanceRight = InchesToPoints(0.13)
Selection.TypeText Text:=Toc_Table_Error_Final
Selection.WholeStory
Selection.Font.ColorIndex = wdBlue
Selection.Font.Size = 8
Selection.MoveDown unit:=wdScreen, Count:=1
Selection.HomeKey unit:=wdStory
End If
Exit For
End If
NextLevel:
Next I
End If
x = 40
I = 40
Label3.Caption = "Checking Leading Spaces..."
DoEvents
Selection.EndKey unit:=wdStory
PgNo = Selection.Information(wdActiveEndPageNumber)
FirstPos = Selection.Information(wdFirstCharacterLineNumber)
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find.ParagraphFormat
.SpaceBeforeAuto = False
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceSingle
End With
Do While Selection.Find.Execute(findtext:="^?", Format:=True, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
If Asc(Selection.Text) <> 13 And Selection.Font.Size <> 10 And Selection.Font.Name <> "Franklin Gothic Demi" Then
Selection.Font.ColorIndex = wdRed
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
I = I + 0.25
j = I
x = j
If j < 60 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
DoEvents
Selection.HomeKey unit:=wdStory
Do While Selection.Find.Execute(findtext:=ChrW(8532), Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.Font.ColorIndex = wdRed
Loop
x = 60
I = 60
Label3.Caption = "Checking Ordinals Formating..."
DoEvents
Selection.HomeKey unit:=wdStory
Do While Selection.Find.Execute(findtext:="--", Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.Font.ColorIndex = wdRed
I = I + 0.5
j = I
y = j
If j < 61 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Font.Superscript = False
x = 61
I = 61
Do While Selection.Find.Execute(findtext:="(sm)", Format:=True, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
If Selection.Font.Superscript <> True Then
Selection.Font.ColorIndex = wdRed
End If
I = I + 0.5
j = I
x = j
If j < 62 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Font.Superscript = False
x = 62
I = 62
Do While Selection.Find.Execute(findtext:="(tm)", Format:=True, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
If Selection.Font.Superscript <> True Then
Selection.Font.ColorIndex = wdRed
End If
I = I + 0.5
j = I
x = j
If j < 63 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Font.Superscript = False
x = 63
I = 63
Do While Selection.Find.Execute(findtext:="(r)", Format:=True, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
If Selection.Font.Superscript <> True Then
Selection.Font.ColorIndex = wdRed
End If
I = I + 0.5
j = I
x = j
If j < 64 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
x = 64
I = 64
Do While Selection.Find.Execute(findtext:="^#st", Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=2, Extend:=wdExtend
If Selection.Font.Superscript = False Then
Selection.Font.ColorIndex = wdRed
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
I = I + 0.5
j = I
x = j
If j < 65 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
x = 65
I = 65
Do While Selection.Find.Execute(findtext:="^#nd", Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=2, Extend:=wdExtend
If Selection.Font.Superscript = False Then
Selection.Font.ColorIndex = wdRed
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
I = I + 0.5
j = I
x = j
If j < 66 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
x = 66
I = 66
Do While Selection.Find.Execute(findtext:="^#rd", Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=2, Extend:=wdExtend
If Selection.Font.Superscript = False Then
Selection.Font.ColorIndex = wdRed
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
I = I + 0.5
j = I
x = j
If j < 67 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
x = 67
I = 67
Do While Selection.Find.Execute(findtext:="^#th", Format:=False, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.MoveRight unit:=wdCharacter, Count:=1
Selection.MoveLeft unit:=wdCharacter, Count:=2, Extend:=wdExtend
If Selection.Font.Superscript = False Then
Selection.Font.ColorIndex = wdRed
End If
Selection.MoveRight unit:=wdCharacter, Count:=1
I = I + 0.5
j = I
x = j
If j < 68 Then
ProgressBar1.Value = j
lblPercent.Caption = CInt(x)
DoEvents
End If
Loop
m = 90
x = 90
Label3.Caption = "Checking Table Underline..."
DoEvents
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
If Selection.Tables.Count = 0 Then
ER1 = ER1 & vbNewLine & "No Table Found"
ProgressBar1.Value = 100
lblPercent.Caption = 100
DoEvents
Else
Selection.GoTo What:=wdGoToTable, Which:=wdGoToLast
Selection.Tables(1).Select
Selection.MoveDown unit:=wdLine
PgNo = Selection.Information(wdActiveEndAdjustedPageNumber)
FirstPos = Selection.Information(wdFirstCharacterLineNumber)
If cmbTOC.Value = "YES" Then
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=1, Name:=""
Else
Selection.HomeKey unit:=wdStory
End If
Selection.GoTo What:=wdGoToTable, Which:=wdGoToFirst, Count:=TOC_no, Name:=""
Do
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
Selection.Tables(1).Select
If (Selection.Borders(wdBorderBottom) <> True) Then
Selection.EndKey unit:=wdLine
Selection.SelectRow
Selection.Shading.Texture = wdTextureNone
Selection.Shading.ForegroundPatternColorIndex = wdAuto
Selection.Shading.BackgroundPatternColorIndex = wdBlue
TUCount = 1
TotalTUCount = TotalTUCount + TUCount
Selection.MoveDown unit:=wdLine
If (Selection.Information(wdActiveEndAdjustedPageNumber) = PgNo) And _
(Selection.Information(wdFirstCharacterLineNumber) = FirstPos) Then
ProgressBar1.Value = 95
lblPercent.Caption = 95
DoEvents
Exit Do
End If
Else
Selection.MoveDown unit:=wdLine
If (Selection.Information(wdActiveEndAdjustedPageNumber) = PgNo) And _
(Selection.Information(wdFirstCharacterLineNumber) = FirstPos) Then
ProgressBar1.Value = 95
lblPercent.Caption = 95
DoEvents
Exit Do
End If
End If
m = m + 0.5
n = m
If n <= 95 Then
ProgressBar1.Value = n
End If
Loop
End If
ActiveWindow.View.Type = wdNormalView
m = 95
x = 95
Label3.Caption = "Checking Blank Rows..."
DoEvents
istable = ActiveDocument.Tables.Count
If istable = 0 Then
GoTo Final:
Else
Selection.GoTo What:=wdGoToTable, Which:=wdGoToLast
Selection.Tables(1).Select
Selection.MoveDown unit:=wdLine
Selection.Font.ColorIndex = wdGray50
Selection.HomeKey unit:=wdStory
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
Selection.Tables(1).Select
Selection.HomeKey
Selection.SelectRow
TotalCell = Selection.Cells.Count
ActualValue = (13 * TotalCell)
Selection.HomeKey
Do
If Selection.Information(wdWithInTable) = True Then
TotalValue = 0
For I = 1 To TotalCell
SingleValue = 0
Selection.MoveEnd unit:=wdCell
SingleValue = Asc(Selection.Text)
TotalValue = TotalValue + SingleValue
Selection.MoveRight unit:=wdCharacter, Count:=1
Next I
If ActualValue <> TotalValue Then
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.MoveDown unit:=wdLine, Count:=1
If Selection.Information(wdWithInTable) = True Then
Selection.SelectRow
TotalCell = Selection.Cells.Count
ActualValue = (13 * TotalCell)
Selection.HomeKey unit:=wdLine
Else
If Selection.Font.ColorIndex <> wdGray50 Then
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
Selection.Tables(1).Select
Selection.HomeKey
Selection.SelectRow
TotalCell = Selection.Cells.Count
ActualValue = (13 * TotalCell)
Selection.HomeKey
Else
Exit Do
End If
End If
Else
Selection.MoveLeft unit:=wdCharacter, Count:=1
Selection.SelectRow
If Selection.Borders(wdBorderBottom).LineStyle <> wdLineStyleNone Or Selection.Borders(wdBorderTop).LineStyle <> wdLineStyleNone Then
Selection.MoveDown unit:=wdLine, Count:=1
Else
Selection.Font.ColorIndex = wdRed
Selection.Shading.BackgroundPatternColorIndex = wdTeal
Selection.MoveDown unit:=wdLine, Count:=1
End If
End If
Else
If Selection.Font.ColorIndex <> wdGray50 Then
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
Selection.Tables(1).Select
Selection.HomeKey
Selection.SelectRow
TotalCell = Selection.Cells.Count
ActualValue = (13 * TotalCell)
Selection.HomeKey
Else
Exit Do
End If
End If
m = m + 0.5
n = m
x = n
If n <= 99 Then
ProgressBar1.Value = n
lblPercent.Caption = x
DoEvents
End If
Loop While True
End If
Final:
Selection.WholeStory
TOTTABLE = Selection.Tables.Count
Selection.MoveLeft unit:=wdCharacter
If Selection.Information(wdWithInTable) = True Then TOTTABLE = TOTTABLE - 1
For I = 1 To TOTTABLE
Application.Browser.Target = wdBrowseTable
Application.Browser.Next
Selection.Tables(1).Select
TOTCELL = Selection.Cells.Count
Selection.MoveLeft unit:=wdCharacter
For j = 2 To TOTCELL
If (Selection.ParagraphFormat.FirstLineIndent + Selection.ParagraphFormat.LeftIndent) < 0 And Selection.ParagraphFormat.FirstLineIndent < 0 Then
Selection.Shading.BackgroundPatternColor = wdColorBrightGreen
ElseIf Selection.ParagraphFormat.LeftIndent < 0 And Selection.ParagraphFormat.FirstLineIndent >= 0 Then
Selection.Shading.BackgroundPatternColor = wdColorBrightGreen
End If
Selection.MoveRight unit:=wdCell
Next
Next
Selection.HomeKey unit:=wdStory
Selection.Find.Font.ColorIndex = wdRed
Do While Selection.Find.Execute(findtext:="^?", Format:=True, _
MatchCase:=False, MatchWildcards:=False, MatchWholeWord:=False, _
MatchSoundsLike:=False, Wrap:=wdFindStop, MatchAllWordForms:=False) = True
Selection.Shading.BackgroundPatternColorIndex = wdBlue
ErrorPageCount = Selection.Information(wdActiveEndAdjustedPageNumber) & ", "
Totalerrorpagecount = Totalerrorpagecount & ErrorPageCount
Loop
If Totalerrorpagecount <> "" Then
frmErrorReport.txtErrorReport.Text = "Error found in following Pages: " & vbNewLine & vbNewLine & Totalerrorpagecount
frmErrorReport.txtErrorReport.ForeColor = RGB(0, 0, 255)
frmErrorReport.txtErrorReport.Font.Size = 7
ElseIf COMMONERRORS = "" Then
frmErrorReport.txtErrorReport.Text = "No Error found in the Document"
frmErrorReport.txtErrorReport.ForeColor = wdBlue
frmErrorReport.txtErrorReport.ForeColor = RGB(0, 0, 255)
Else
frmErrorReport.txtErrorReport.Text = "Found Only Common Errors rest of the File is Okay"
frmErrorReport.txtErrorReport.ForeColor = wdBlue
frmErrorReport.txtErrorReport.ForeColor = RGB(0, 0, 255)
frmErrorReport.cmdGotoErr.Visible = False
End If
If TotalTUCount > 0 Then
frmErrorReport.txtErrorReport.Text = frmErrorReport.txtErrorReport.Text & vbNewLine & vbNewLine & "Please check for Table Underline marking in blue shading manually"
End If
ProgressBar1.Value = 100
lblPercent.Caption = 100
DoEvents
ActiveWindow.View.Type = wdPrintView
Unload frmPre_DQA
EndTime = DateTime.Now
MsgBox "Start Time is... " & StartTime & vbCrLf & "End Time is... " & EndTime
frmErrorReport.StartUpPosition = 0
frmErrorReport.Show
Exit Sub
End Sub