Alot of Flashes changing windows

Ken Leidner · #1 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

macropod · #2 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