Click here to Skip to main content
15,886,873 members
Search within:


Performance issue of macro in word 2007, macro written in word 2003
Please Sign up or sign in to vote.
1.00/5 (1 vote)
See more:
VBA
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


VB
'Option Explicit
Private Sub cmdChk_Click()
'Variable Declaration
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
'Capturing Values
DocType = cmbDocType.Value
PageFormat = cmbPageFormat.Value
'******************************************************************************************
'Checking for Page Setup
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 = PointsToInches(ActiveDocument.PageSetup.TopMargin)
'B_Margin = PointsToInches(ActiveDocument.PageSetup.BottomMargin)
'L_Margin = PointsToInches(ActiveDocument.PageSetup.LeftMargin)
'R_Margin = PointsToInches(ActiveDocument.PageSetup.RightMargin)
'Gttr = PointsToInches(ActiveDocument.PageSetup.Gutter)
'H_Dist = PointsToInches(ActiveDocument.PageSetup.HeaderDistance)
'F_Dist = PointsToInches(ActiveDocument.PageSetup.FooterDistance)

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
'******************************************************************************************
'Checking Total Page Count
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
'******************************************************************************************
'Cheking Page Footer
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
'******************************************************************************************
'Checking for ParaJustify
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(wdActiveEndAdjustedPageNumber) = lastpageno) And _
'        (Selection.Information(wdFirstCharacterLineNumber) = position) Then
'        Exit Do
'    Else
    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
                'Selection.MoveDown unit:=wdLine, Count:=1
            End If
        End If
    End If
    'Selection.MoveDown unit:=wdLine
    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
'******************************************************************************************
' Find TOC Table
If cmbTOC.Value = "YES" Then
  '  maindocwithext = ActiveDocument.Name
  '  lenghtofname = Len(maindocwithext)
  '  maindoc = Left(maindocwithext, lenghtofname - 4)
    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
        
        
     'Trapping toc table no. to use for last row formatting of table
        
        TOC_no = I
        
        Selection.Tables(1).Select
        Selection.HomeKey unit:=wdLine
        'checking for toc heading
            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
            
            'MsgBox Toc_Table_Error_Final
            
            Else
            
              GoTo NextLevel:
            
            End If
            
            
  '**********Place Toc Error*********************
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
'********************************************
'        Selection.Copy
'        'Selection.TypeText Text:="Mitra"
'        Documents.Add DocumentType:=wdNewBlankDocument
'        'Documents.Add Template:="Normal", NewTemplate:=False
'        Selection.Paste
'
'          maindoc2 = ActiveDocument.Name
'
'        Windows(maindoc).Activate
      
'*************************************************
'Checking Leading Space
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
'******************************************************************************************



'******************************************************************************************
'cheking symbols....
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
'******************************************************************************************
'Checking Ordinals Formating
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
' CheCking Table Underline
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
    ' takes time in execution
    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
'******************************************************************************************
' CheCking blank Row
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
   ' takes time in execution
    Do
        If Selection.Information(wdWithInTable) = True Then
            TotalValue = 0
            For I = 1 To TotalCell
                SingleValue = 0
                Selection.MoveEnd unit:=wdCell
                'Selection.MoveDown unit:=wdParagraph, Count:=1, Extend:=wdExtend
                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

'Call Mitra_Chk_tbl_width

End If
'******************************************************************************************
Final:
'Replace TOC Position


'*******************************************
'Check_Table_Negative_Indent()
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





'Counting Pages with Errors

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
Posted
Updated 1-Aug-12 1:01am
v4
Add a Solution
Comments
Malli_S 1-Aug-12 7:03am    
OMG ! Sorry to say, but nobody will look into your (such a big) code. Try to explain the functionality you've implemented. Discuss the performance of these features, and then get into code level details. That will help you to point out the exact problem. Posting full code like this won't help neither you nor us to solve the problem.
Kenneth Haugland 1-Aug-12 7:11am    
I'll give you a 5 for that, but I cant... :)
Malli_S 1-Aug-12 10:22am    
My pleasure. :)
Kenneth Haugland 1-Aug-12 7:08am    
Malli_S is right. So the question is, what functions were updated from 2003 to 2005? Perhaps you are using somethings that is not fully supported in the new version, that could be the issue. But Im not going to go through all that code, its simply too much :)
Omprakash1981 1-Aug-12 7:40am    
Actually the whole code is written for the formatting of the document. It consists of font,white space,gray scale etc .

1 solution

Im terribly sorry but no one is going to go through all that code for you. Its not like there are any obvius mistakes in it, so youll have to either find out what s taking so long by debuging, or you must simply resort yourself to the official manual from microsoft.,
 
Share this answer
 
Posted
Add a Solution

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

  Print Answers RSS
Top Experts
Last 24hrsThis month
Related Questions
Create 2007 word Macro
Problem in RUN macro in WORD 2007
MS word macro - replace in highlighted text then unhighlight text
How to convert MS Word 2007 Addin to Word Macro?
Macro is not running in Word 2010 ?
Word Macros and Windows Application
How to track revisions (versions) in word 2003, word 2007 and word 2010 VBA
Macro to browse for and insert picture into word doc?
vbScript Word macro embed PDF
Is it possible to have VBA code or a macro for a word template in .dot or dotx

Advertise
Privacy
Cookies
Terms of Use
Last Updated 1 Aug 2012
Layout: fixed | fluid
Copyright © CodeProject, 1999-2024
All Rights Reserved.

Web02 2.8:2024-04-02:1

CodeProject, 20 Bay Street, 11th Floor Toronto, Ontario, Canada M5J 2N8 +1 (416) 849-8900