Alot of Flashes changing windows

Ken Leidner · #1 07-16-2018, 01:35 PM

Let me describe the task I am performing and then my problem, rather than the code. I have a word document that has groups of paragraphs that need to be re-ordered. Generally a group has about 5 or 6 paragraphs and there are about 350 such groups. The process is to find the next group and then place it into a new document, and repeat for the 350 groups. Along the way from time to time a new section will be created (Chapters). There are about 9 chapters.

I have many Application.ScreenUpdating = False statements but I still get screen flashing. I expect it is as I am changing from the source document’s window to the new document’s window. IE) Windows(ii).Activate or Windows(i).Activate where I and II have been set from ActiveWindow.Index statements.

Can this be fixed? At 700 flashes it looks like the computer is crashing or has a virus. Would using a different way to switch between the two documents work? IE) Documents(name).active be better?

The macro works, but has a visual issue for what seems like forever.

macropod · #2 07-16-2018, 04:19 PM

Most likely the screen flashing is because you're using Selections and/or switching document windows, neither of which is usually required. Without seeing the code though, it's impossible to know for sure, or to advise on how to change the code.

Guessed · #3 07-16-2018, 04:28 PM

Have you tried setting the Visible:=False when opening the new document?

Ken Leidner · #4 07-16-2018, 04:38 PM

Here is the code. I know the Heading is not correct, plan to fix based on the information I received on the footer, several days back.

The first document has the information to re-order the groups. After it is closed is when the issue arises.

Code:

' global the arrays
Dim ChapterArray(1 To 900) As Integer
Dim QuestionArray(1 To 900) As String
Dim answer(1 To 900) As String
Dim sta As Integer
Dim enda As Integer
Sub GenByChapter()
' Generate Technician questions by chapters
'
Dim p As Paragraph
Dim pstring As String
Dim MaxNumber As Integer
Dim TabLocation As Integer
Dim QuestionAnaswerRange As Range
Dim StartWord As String, EndWord As String, ftest As String
Dim OldChapter As Integer


' Get information of questions by chapter in arrays
' C:\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters.docx
Application.ScreenUpdating = False

Documents.Open FileName:="\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters 2018.docx", ConfirmConversions _
        :=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""
MaxNumber = 0
For Each p In ActiveDocument.Paragraphs
    ' convert paragraph to a string of characters
    pstring = p.Range.Text
    ' drop paragraph character
    pstring = Left(pstring, Len(pstring) - 1)
        ' Debug.Print ">" & pstring & ">" & Len(pstring);
    ' find the tab - chr(9) is a tab
    TabLocation = InStr(1, pstring, Chr(9))
    MaxNumber = MaxNumber + 1
    ChapterArray(MaxNumber) = Mid$(pstring, 1, TabLocation - 1)
    QuestionArray(MaxNumber) = Mid$(pstring, TabLocation + 1)
Next p
' close the document with the questions by chapter
ActiveWindow.Close
' focus on the question document
Windows("2018-2022 Tech Pool Macro.docm").Activate
'

Windows(1).Activate
Application.ScreenUpdating = False

' a = ActiveDocument.Name
' Windows(2).Activate
i = i
a = ActiveDocument.Name
i = ActiveWindow.Index
OldChapter = -9
    Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
b = ActiveDocument.Name
ii = ActiveWindow.Index
Application.ScreenUpdating = False

Windows(ii).Activate
Application.ScreenUpdating = False

Call setmargins

Windows(i).Activate
Application.ScreenUpdating = False
sta = 1
For kk = 1 To MaxNumber
    StartWord = QuestionArray(kk)
    EndWord = "~~"
    ' build the find for the question
    Set QuestionAnaswerRange = ActiveDocument.Content
    QuestionAnaswerRange.Find.ClearFormatting
    QuestionAnaswerRange.Find.Replacement.ClearFormatting
    With QuestionAnaswerRange.Find
        .Text = StartWord & "*" & EndWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False '
    End With
    ' do the find
    QuestionAnaswerRange.Find.Execute
    ' open the new window
    Windows(ii).Activate
    Application.ScreenUpdating = False

    ' see if a new chapter
    If OldChapter <> ChapterArray(kk) Then
        OldChapter = ChapterArray(kk)
        Call newchapter(OldChapter)
        sta = kk
        End If
    ' change formation back to normal
    Selection.Style = ActiveDocument.Styles("Normal")
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    'Selection.InsertParagraph
    ' get the found text
    ftext = QuestionAnaswerRange.Text
    ' find the first blank and then the ")"
    bl = InStr(ftext, " ")
    answer(kk) = Mid(ftext, bl + 1, 3)
    nl = InStr(ftext, Chr(13)) + 1
    fftext = QuestionArray(kk) & Chr(13) & Mid(ftext, nl)
    enda = kk
 '   Selection.TypeText (QuestionAnaswerRange.Text)
    Selection.TypeText (fftext)
    Selection.TypeParagraph
'       Debug.Print QuestionAnaswerRange.Text
If StartWord = "T2B09" Then
    kk = kk
    End If
Windows(1).Activate

Application.ScreenUpdating = False

 Next
'output a page break
    Windows(ii).Activate

Selection.InsertBreak Type:=wdPageBreak
     'spill the answers
For iii = sta To enda
    Selection.TypeText (QuestionArray(iii) & " " & answer(iii))
    Selection.TypeParagraph
Next
Windows(1).Activate

 Application.ScreenUpdating = True
 
 ' ww = ww
' Selection.InsertParagraph
'Dim MyText As String
 ' MyText = "<Replace this with your text>"
'  Selection.TypeText (MyText)
'objSelection.TypeParagraph (" ")
'objSelection.TypeText "This text was apstringended to an existing Word document."
    End Sub
Sub newchapter(i)
' Dim i As Integer
If i <> 1 Then
    'output a page break
     Selection.InsertBreak Type:=wdPageBreak
     'spill the answers
     For ii = sta To enda
        Selection.TypeText (QuestionArray(ii) & " " & answer(ii))
        Selection.TypeParagraph
        Next
    

    Selection.InsertBreak Type:=wdSectionBreakNextPage
    End If
'set up new page heading for chapter
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
' Selection.HeaderFooter.LinkToPrevious = False
With ActiveDocument.Sections.Last
    With .Headers(1)
        .LinkToPrevious = False
    End With
    With .Headers(2)
        .LinkToPrevious = False
    End With
    With .Headers(3)
        .LinkToPrevious = False
    End With
 End With

Selection.Font.Size = 20
Selection.Font.Name = "Arial"
secNum = Selection.Information(wdActiveEndSectionNumber)
ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Text = vbNullString
ActiveDocument.Sections(i).Headers(wdHeaderFooterPrimary).Range.Text = "Questions for chapter " & i
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.TypeParagraph
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument

Selection.TypeParagraph
' change formation back to normal
Selection.Style = ActiveDocument.Styles("Normal")
Selection.Font.Name = "Arial"

    End Sub
    
Sub newdoc()
'
' newdoc Macro
' new doc
'

'
    Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0
    Selection.TypeParagraph
End Sub

Sub setmargins()
    With ActiveDocument.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.3)
        .BottomMargin = InchesToPoints(0.3)
        .LeftMargin = InchesToPoints(0.4)
        .RightMargin = InchesToPoints(0.3)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .PageWidth = InchesToPoints(8.5)
        .PageHeight = InchesToPoints(11)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
End Sub

macropod · #5 07-23-2018, 09:13 PM

As suspected, you have lots of 'Windows(#).Activate' and 'Selection' code in there. There is no need for either. For example:
you might use:

Code:

Sub GenByChapter()
' Generate Technician questions by chapters
'
Dim p As Paragraph
Dim pstring As String
Dim MaxNumber As Long
Dim TabLocation As Long
Dim QuestionAnswerRange As Range
Dim StartWord As String, EndWord As String, ftest As String
Dim OldChapter As Long
MaxNumber = 0

Dim Doc1 As Document, Doc2 As Document

Windows("2018-2022 Tech Pool Macro.docm").Activate
Set Doc1 = ActiveDocument
Application.ScreenUpdating = False

Set Doc2 = Documents.Open(FileName:="\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters 2018.docx", _
  ReadOnly:=True, AddToRecentFiles:=False, Visible:=False)
With Doc2
  For Each p In .Paragraphs
    ' convert paragraph to a string of characters
    pstring = Split(p.Range.Text, vbCr)(0)
    TabLocation = InStr(1, pstring, Chr(9))
    MaxNumber = MaxNumber + 1
    ChapterArray(MaxNumber) = Mid$(pstring, 1, TabLocation - 1)
    QuestionArray(MaxNumber) = Mid$(pstring, TabLocation + 1)
  Next p
  ' close the document with the questions by chapter
  .Close False
End With
OldChapter = -9
Set Doc2 = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
Call SetMargins(Doc2)
'...
Application.ScreenUpdating = True
End Sub
'...
Sub SetMargins(Doc As Document)
With Doc.PageSetup
'...
End With
End Sub

Ken Leidner · #6 07-31-2018, 09:02 AM

Well I got some time and re-wrote the code. It works as far as the code produces the end product, but I still have the flashing. Its less time, about 7 seconds and then about another 15 seconds on the clock (spinning circle) before I can view anything.

So I must still be doing something wrong. I expect its the outdoc.Activate and the orginialdoc.Activate statements, but I don't understand how to tell the code which document to look in or output the information into without them.

I made two changes in trying to help

Set QuestionAnaswerRange = orginialdoc.Content rather than the

ActiveDocument.Content

and up a few lines I commented out the line ' orginialdoc.Activate
The change on the screen was, I see a gray screen (the new document) and the cursor jumps around with the clock icon. Same amount of time as before the changes.

Here is the code

' global the arrays

Code:

Option Explicit
Dim ChapterArray(1 To 900) As Integer
Dim UniqueChapterArray(1 To 900) As Integer

Dim QuestionArray(1 To 900) As String
Dim answer(1 To 900) As String
Dim sta As Integer
Dim enda As Integer
Dim fchapterbreak As Boolean
Sub GenByChapter()

' Generate Technician questions by chapters
'
Dim p As Paragraph
Dim pstring As String
Dim MaxNumber As Integer
Dim UniqueMaxNumber As Integer
Dim TabLocation As Integer
Dim QuestionAnaswerRange As Range
Dim StartWord As String
Dim EndWord As String
Dim ftext As String
Dim fftext As String
Dim OldChapter As Integer
Dim bl As Integer
Dim nl As Integer
Dim iii As Integer
Dim orginialdoc As Document
Dim questiondoc As Document
Dim outdoc As Document
Dim kk As Integer
Dim sect As Section

fchapterbreak = True
' Get information of questions by chapter in arrays
' C:\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters.docx
Set orginialdoc = ActiveDocument
Application.ScreenUpdating = False

Set questiondoc = Documents.Open(FileName:="\Users\Kenneth\Documents\Amateur Radio\New q downloads\questions by chapters 2018.docx", ConfirmConversions _
        :=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", _
        PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", _
        WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:="")
MaxNumber = 0
UniqueMaxNumber = 0
For Each p In questiondoc.Paragraphs
    ' convert paragraph to a string of characters
    pstring = p.Range.Text
    ' drop paragraph character
    pstring = Left(pstring, Len(pstring) - 1)
        ' Debug.Print ">" & pstring & ">" & Len(pstring);
    ' find the tab - chr(9) is a tab
    TabLocation = InStr(1, pstring, Chr(9))
    MaxNumber = MaxNumber + 1
    ChapterArray(MaxNumber) = Mid$(pstring, 1, TabLocation - 1)
    QuestionArray(MaxNumber) = Mid$(pstring, TabLocation + 1)
    If UniqueMaxNumber <> 0 Then
        If ChapterArray(MaxNumber) <> UniqueChapterArray(UniqueMaxNumber) Then
            UniqueMaxNumber = UniqueMaxNumber + 1
            UniqueChapterArray(UniqueMaxNumber) = ChapterArray(MaxNumber)
        End If
    End If
    If UniqueMaxNumber = 0 Then
        UniqueMaxNumber = 1
        UniqueChapterArray(UniqueMaxNumber) = ChapterArray(MaxNumber)
    End If
Next p
' close the document with the questions by chapter
questiondoc.Close
Set questiondoc = Nothing
' focus on the question document
orginialdoc.Activate

Application.ScreenUpdating = False

OldChapter = -9
 Set outdoc = Documents.Add(Template:="Normal", NewTemplate:=False, DocumentType:=0)
outdoc.Activate
Application.ScreenUpdating = False
Call setmargins(outdoc)
Application.ScreenUpdating = False
sta = 1
For kk = 1 To MaxNumber
    orginialdoc.Activate
    StartWord = QuestionArray(kk)
    EndWord = "~~"
    ' build the find for the question
    Set QuestionAnaswerRange = ActiveDocument.Content
    QuestionAnaswerRange.Find.ClearFormatting
    QuestionAnaswerRange.Find.Replacement.ClearFormatting
    With QuestionAnaswerRange.Find
        .Text = StartWord & "*" & EndWord
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False '
    End With
    ' do the find
    QuestionAnaswerRange.Find.Execute
    ' see if a new chapter
    If OldChapter <> ChapterArray(kk) Then
        OldChapter = ChapterArray(kk)
        Call newchapter(OldChapter, outdoc)
        sta = kk
        End If
    ' change formation back to normal
    outdoc.Activate
    Selection.Style = ActiveDocument.Styles("Normal")
  
    Selection.Font.Name = "Arial"
    Selection.Font.Size = 10
    'Selection.InsertParagraph
    ' get the found text
    ftext = QuestionAnaswerRange.Text
    ' find the first blank and then the ")"
    bl = InStr(ftext, " ")
    answer(kk) = Mid(ftext, bl + 1, 3)
    nl = InStr(ftext, Chr(13)) + 1
    fftext = QuestionArray(kk) & Chr(13) & Mid(ftext, nl)
    enda = kk
 'GoTo exitout
    Selection.TypeText (fftext)
    Selection.TypeParagraph
'       Debug.Print QuestionAnaswerRange.Text
next
'output a page break
outdoc.Activate
Selection.InsertBreak Type:=wdPageBreak
     'spill the answers
For iii = sta To enda
    Selection.TypeText (QuestionArray(iii) & " " & answer(iii))
    Selection.TypeParagraph
Next
kk = 0
For Each sect In outdoc.Sections
    ' unlink
    With sect.Headers(wdHeaderFooterPrimary)
        .LinkToPrevious = False
        kk = kk + 1
        .Range.Text = "Questions for chapter " & UniqueChapterArray(kk)
        .Range.Font.Size = 20
        .Range.Font.Name = "Arial"
        .Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
    End With
Next sect
orginialdoc.Activate
exitout:
 Application.ScreenUpdating = True
    End Sub
Sub newchapter(i, outdoc)
 Dim ii As Integer
 outdoc.Activate
If Not fchapterbreak Then
    'output a page break
     Selection.StartOf unit:=wdParagraph
            Selection.Collapse Direction:=wdCollapseEnd
            Selection.InsertBreak (wdPageBreak)
     'spill the answers
     For ii = sta To enda
        Selection.TypeText (QuestionArray(ii) & " " & answer(ii))
        Selection.TypeParagraph
        Next
    Selection.StartOf unit:=wdParagraph
    Selection.Collapse Direction:=wdCollapseEnd
    Selection.InsertBreak (wdSectionBreakNextPage)
Else
    fchapterbreak = False
    End If
    End Sub
Sub setmargins(outdoc)
'Dim qdoc As Document
    With outdoc.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.3)
        .BottomMargin = InchesToPoints(0.3)
        .LeftMargin = InchesToPoints(0.4)
        .RightMargin = InchesToPoints(0.3)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .PageWidth = InchesToPoints(8.5)
        .PageHeight = InchesToPoints(11)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
End Sub

Pecoflyer · #7 07-31-2018, 09:14 AM

Hi Ken
don't forget to wrap yopur code with tags (#button). It makes the thread easier to read and the code easier to copy if need be.
I did it for you this time.
Thanks

macropod · #8 07-31-2018, 02:36 PM

Quote:

Originally Posted by Ken Leidner

So I must still be doing something wrong. I expect its the outdoc.Activate and the orginialdoc.Activate statements, but I don't understand how to tell the code which document to look in or output the information into without them.

As shown in the code I posted, you refer to the documents by the variables assigned to them (i.e. Doc1, Doc2). So, instead of statements like:
orginialdoc.Activate
you would reference the same document via:

Code:

With orginialdoc
…
End With

You still have a lot of unnecessary Select activity going on, too... And you don't need to keep inserting:
Application.ScreenUpdating = False
Once is enough. Moreover, once you've got the code working, you can set the Visible property of any document you open to False, further reducing the scope for flickering.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Windows 10 – Changing the Office 2007 Product Key.	ansentry	Office	2	12-07-2015 07:41 PM
Convert Ofc 2000/Windows XP OS docs to Windows 7 OS which has NO Ofc Version Loaded	mylittleturbott	Office	2	03-17-2014 03:18 PM
Problem typing alot of text into a middle column	noelr	Word Tables	3	10-02-2013 02:19 PM
Outlook requests password afeter changing windows password	pask	Outlook	5	03-16-2012 08:43 AM
screen flashes black when writing	docsobeck	PowerPoint	0	02-01-2010 11:09 AM