epuglise
asked on
Memory Problem Word Form
Anyone have any experience with memory leaks and Word Forms? When I open a Word document with my macros, the memory usage for winword skyrockets... and eventually crashes Word. Any way to reset that other than shutting down word and restarting?
Ask any questions you need to... this territory is very unfamiliar to me and I don't know what information to provide to determine why I have this memory problem...
Ask any questions you need to... this territory is very unfamiliar to me and I don't know what information to provide to determine why I have this memory problem...
Can you post your code? Maybe there is a memory leak in it....
SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
DreamBoat:
I'll give that a try!!
Thanks
Sasho:
I wouldn't even know what a memory leak in my code looked like. The computer's not dripping, so I thought everything was ok!! ;) If you know what to look for and find a leak that keeps me from crashing, I'll add points (I'm a paying member, so I hand 'em out generously!)
You asked for it...
Const TAILORINGFOLDER = "Tailoring_Area"
Const REDLINEFOLDER = "Redlined_Versions"
Const PROJECTFOLDER = "Project_Enabler"
Const MASTERFOLDER = "Enabler"
Const ENDOFTEXTMARKER = "~~THE END~~"
Const LASTFIELDMARKER = "END"
'*************************
'* THIS CODE IS REQUIRED FOR CONVERSION AND BY END USERS *
'*************************
Sub CreateRationaleTextField()
'Debug.Print "Now entering: CreateRationaleTextField"
Set dd_Rationale = Selection.FormFields.Add( _
Range:=Selection.Range, Type:=wdFieldFormTextInput
With dd_Rationale
.Name = "Rationale"
.HelpText = "Insert your rationale here."
.TextInput.Width = 512
End With
End Sub
Sub CreateStatementField()
'Debug.Print "Now entering: CreateStatementField"
'
' CreateStatementField Macro
' by
Dim OrigGuideText As String
'THIS NEEDS TO BE CHANGED!!!: IT TRUNCATES TEXT!
'OrigGuideText = Left(Selection.Range.Text,
OrigGuideText = Selection.Range.Text
Debug.Print "This is origguidetext: " & OrigGuideText
Debug.Print Len(OrigGuideText)
If Len(OrigGuideText) <= 255 Then
Debug.Print "Len is <= 255"
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = OrigGuideText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=OrigGuideText, Format:=""
End With
'Selection.Comments.Add Range:=Selection.Range
'Selection.TypeText Text:=OrigGuideText
Else
Debug.Print "I'm in the else"
Dim NumLoops As Integer
NumLoops = (Len(OrigGuideText) / 255) + 1
Debug.Print NumLoops
Dim Counter As Integer
Dim CurrText As String
Counter = 1
Do While Counter <= NumLoops
CurrText = Left(OrigGuideText, 255)
Debug.Print "CurrText = " & CurrText
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = CurrText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=CurrText, Format:=""
End With
Selection.MoveRight unit:=wdCell, Count:=1
Selection.MoveLeft unit:=wdCell
Selection.MoveRight unit:=wdCharacter
OrigGuideText = Mid$(OrigGuideText, 256)
Counter = Counter + 1
'Selection.Comments.Add Range:=Selection.Range
'Selection.TypeText Text:=OrigGuideText
Loop
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=1
End If
End Sub
'*************************
'* END OF CODE THAT IS REQUIRED FOR *
'* CONVERSION AND BY END USERS *
'*************************
'*************************
'* THIS CODE IS FOR CONVERTING ENABLER *
'* DOCUMENTS INTO TAILORING TOOLS. *
'*************************
Sub ACreateTailoringReport()
Debug.Print "Now entering: CreateTailoringReport"
'
' CreateTailoringReport Macro
' by
'
'This is just a reminder to the conversion person:
Dim Response
Response = MsgBox("Have you checked for and eliminated hyperlinks?", 4, "REMINDER!")
If Response = vbNo Then
Exit Sub
End If
'THIS IS A TEMPORARY ITEM SEE MODULE HEADER FOR MORE INFO
'NOTE that for this to work, the paragraph markers must be
'VISIBLE!
RemoveHiddenText
'Make the Table:
MakeTable
'Create Rationale Column/Fields
InsertRationaleFields
'Label Tailoring Type Column and Create Guidance DropDowns
InsertGuideDropDown
'Create end of document bookmark
InsertEndMark
'Replace Guidance DropDowns with Requirements DropDowns for SPP statements.
' There are SPP statements with "{" and with "("
FindRequiredItems1
FindRequiredItems2
'Delete input fields for Headings and Intro Text
DeleteIntroSectionFields
'Replace Guidance Statements with form fields
'This needs to be fixed for text longer than 255 char
FindGuidanceUpdateStatemen
'Delete the end-of-document markers:
RemoveEndMarks
'Insert Filename/Path autotext for future reference
' NormalTemplate.AutoTextEnt
Selection.Range
End Sub
Sub RemoveHiddenText()
'
' RemoveBadStuff Macro
' by
' This is to remove hidden text from draft (test) documents
' the final documents shouldn't have any hidden text... might have some hyperlinks
With Selection.Find
.ClearFormatting
.Font.Hidden = True
.Replacement.ClearFormatti
.Replacement.Font.Hidden = False
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Sub MakeTable()
With Selection
.WholeStory
.ConvertToTable Separator:=wdSeparateByPar
NumRows:=409, Format:=wdTableFormatNone,
ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:= _
True, ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False _
, AutoFit:=True, AutoFitBehavior:=wdAutoFit
.InsertColumns
.Style = ActiveDocument.Styles("Nor
.Columns.PreferredWidthTyp
.Columns.PreferredWidth = InchesToPoints(2.5)
.InsertColumns
.Style = ActiveDocument.Styles("Nor
.Tables(1).AutoFitBehavior
.Columns.PreferredWidthTyp
.Columns.PreferredWidth = InchesToPoints(1)
.MoveUp unit:=wdLine, Count:=1
.InsertRowsAbove 1
.MoveLeft unit:=wdCharacter, Count:=1
.MoveRight unit:=wdCell
.MoveRight unit:=wdCell
.TypeText Text:="Statement"
.MoveRight unit:=wdCell
'Return to top of doc
.WholeStory
.MoveLeft unit:=wdCharacter, Count:=1
End With
End Sub
Sub InsertRationaleFields()
Debug.Print "Now entering: InsertRationaleFields"
'
' InsertRationaleFields Macro
' by
With Selection
'Go to the top of the doc:
.WholeStory
.MoveLeft unit:=wdCharacter, Count:=1
'Move to Rationale Column:
.MoveRight unit:=wdCell
End With
'Create one instance of the Rationale Field
CreateRationaleTextField
With Selection
'Copy the text field...
.SelectCell
.Copy
'...then paste copies of the field in the entire column.
.SelectColumn
.Paste
.MoveUp unit:=wdLine, Count:=1
.Delete unit:=wdCharacter, Count:=1
End With
End Sub
Sub InsertGuideDropDown()
Debug.Print "Now entering: InsertGuideDropDown"
'
' InsertReqDropDown Macro
' by
'
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
Set dd_Guide = Selection.FormFields.Add(R
dd_Guide.Name = "Guidance"
dd_Guide.HelpText = "This item is Guidance."
dd_Guide.ExitMacro = "DropDownChangeResult"
With dd_Guide.DropDown.ListEntr
.Add Name:="<Guidance>"
.Add Name:="Applicable"
.Add Name:="Delete"
.Add Name:="Modify"
.Add Name:="New Practice"
.Add Name:="Id Ext Reference"
.Add Name:="Not Applicable"
.Add Name:="Add Comment"
.Add Name:="DEFAULT Statement"
End With
With Selection
.SelectCell
.Copy
.SelectColumn
.Paste
.MoveUp unit:=wdLine, Count:=1
.Delete unit:=wdCharacter, Count:=1
.TypeText Text:="Tailoring Type"
End With
End Sub
Sub InsertEndMark()
'
' InsertEndMark Macro
' Macro recorded 9/9/2004 by
'
With Selection
.WholeStory
.EndKey unit:=wdLine
.TypeText ENDOFTEXTMARKER
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.PreviousField.Select
.FormFields(1).Name = LASTFIELDMARKER
End With
End Sub
Sub FindRequiredItems1()
Debug.Print "Now entering: FindRequiredItems1"
'
' FindRequiredItems Macro
' by
'
Selection.GoTo wdGoToLine, wdGoToFirst
With Selection.Find
.ClearFormatting
Do While .Execute(FindText:="{SPP")
With Selection
With Selection.Find
.Text = "{SPP"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=2
If Selection.FormFields(1).Na
Exit Do
End If
Selection.Delete
InsertReqDropDown
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
End With
Loop
End With
End Sub
Sub FindRequiredItems2()
Debug.Print "Now entering: FindRequiredItems2"
'
' FindRequiredItems Macro
' by
'
Selection.GoTo wdGoToLine, wdGoToFirst
With Selection.Find
.ClearFormatting
Do While .Execute(FindText:="(SPP")
With Selection
With Selection.Find
.Text = "(SPP"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=2
If Selection.FormFields(1).Na
Exit Do
End If
Selection.Delete
InsertReqDropDown
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
End With
Loop
End With
End Sub
Sub InsertReqDropDown()
Debug.Print "Now entering: InsertReqDropDown"
'
' InsertReqDropDown Macro
' by
'
Set dd_Req = Selection.FormFields.Add(R
dd_Req.Name = "Requirement"
dd_Req.HelpText = "This item is a Requirement."
dd_Req.ExitMacro = "DropDownChangeResult"
With dd_Req.DropDown.ListEntrie
.Add Name:="<Required>"
.Add Name:="Comply"
.Add Name:="Deviation"
.Add Name:="Waiver"
.Add Name:="Alternate Practice"
.Add Name:="Add Comment"
End With
End Sub
Sub DeleteIntroSectionFields()
'
' DeleteFields Macro
' by
'
'Go to the top of the document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
With Selection.Find
.ClearFormatting
.Text = "Entry Criteria"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
With Selection
.MoveLeft unit:=wdCell
.HomeKey unit:=wdStory, Extend:=wdExtend
.Delete unit:=wdCharacter, Count:=1
.TypeText Text:="Tailoring Type"
.MoveRight unit:=wdCell
.TypeText Text:="Rationale"
End With
End Sub
Sub FindGuidanceUpdateStatemen
Debug.Print "Now entering: FindGuidanceUpdateStatemen
'
' EndOfDocBookmark Macro
'
' THIS MACRO WILL NOT WORK IF THERE ARE ANY HYPERLINKS IN THE TXT! (For now)
'Go to the top of the document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
'Go to the first field in the document
Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1
'Find each Guidance Field and update the Statement field,
'until you get to the end of the document.
Do Until Selection.FormFields(1).Na
Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1
If Selection.FormFields(1).Na
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.Copy
CreateStatementField
End If
Loop
End Sub
Sub RemoveEndMarks()
'
' RemoveEndMarks Macro
'
'Go to beginning of document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
'Find the end text and replace with nothing (delete it)
With Selection.Find
.Text = ENDOFTEXTMARKER
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Delete End form field
Selection.EndKey unit:=wdStory
Selection.MoveLeft
Selection.Delete unit:=wdCharacter, Count:=1
Selection.Style = "normal"
'Return to top of document
Selection.HomeKey unit:=wdStory
End Sub
'*************************
'* THIS IS THE END OF THE CODE THAT *
'* CONVERTS DOCUMENTS INTO TAILORING TOOL. *
'*************************
'*************************
'* THIS IS THE CODE THAT THE USERS NEED *
'* SO THAT THE TAILORING TOOL WILL WORK *
'*************************
Sub DropDownChangeResult()
Dim CurrentDDValue As Integer
Dim UserChoice As String
CurrentDDValue = Selection.FormFields(1).Dr
UserChoice = Selection.FormFields(1).Dr
' 9-13 removed all of the UnProtect/Protect from the Case statments and moved them
' before and after. The "delete" case did not have unprotect/protect (but it does now)
UnProtect
Select Case UserChoice
Case "Applicable"
Call setBackgroundColor(wdColor
Case "Delete", "Modify"
Call setBackgroundColor(wdColor
Case "Waiver", "Deviation"
Call setBackgroundColor(wdColor
'RemoveRequirementText
StrikeoutRequirementText
Case "Id Ext Reference"
IdExtRef
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "New Practice"
NewPractice
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "Alternate Practice"
Call setBackgroundColor(wdColor
AltPractice
MoveToRationaleCell
Case "Add Comment"
NewComment
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "Delete Row"
DeleteRow
Case "DEFAULT Statement"
ResetDefText
Case Else
Call setBackgroundColor(wdColor
End Select
Protect
End Sub
Sub RemoveRequirementText()
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.SelectCell
Selection.Copy
Selection.Cut
End Sub
Sub StrikeoutRequirementText()
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.SelectCell
With Selection.Font
.StrikeThrough = True
.Color = wdColorRed
End With
End Sub
Sub ResetDefText()
Dim Response, Style
Dim Title As String, Msg As String
Msg = "Are you sure you want to reset the Statement Text?"
Title = "WARNING!!"
Style = vbYesNo + vbExclamation + vbDefaultButton2
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then
Exit Sub
End If
Dim DefaultText
Selection.GoToNext wdGoToField
Selection.GoToNext wdGoToField
DefaultText = Selection.FormFields(1).Te
Selection.Delete
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = DefaultText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=DefaultText, Format:=""
End With
End Sub
Sub MoveToRationaleCell()
Selection.GoToNext wdGoToField
End Sub
Sub NewComment()
InsertTableRow ("Comment")
End Sub
Sub IdExtRef()
InsertTableRow ("ExtRef")
End Sub
Sub NewPractice()
InsertTableRow ("NewPractice")
End Sub
Sub AltPractice()
InsertTableRow ("AltPractice")
End Sub
Sub Protect()
ActiveDocument.Protect Password:="", NoReset:=True, Type:=wdAllowOnlyFormField
End Sub
Sub UnProtect()
ActiveDocument.UnProtect Password:=""
End Sub
Sub InsertTableRow(RowType As String)
Debug.Print "Now Entering: InsertTableRow"
'
' InsertTableRow Macro
' by
'
'Id Req Type
Dim ReqType As String
ReqType = Selection.FormFields(1).Na
Debug.Print "ReqType= " & ReqType
'Set current row dropdown to "default" <...> value:
If RowType <> "AltPractice" Then
Selection.FormFields(1).Dr
End If
'insert row
Selection.InsertRowsBelow
'populate row with fields
'create Tailoring Type Field
CreateNewRowDropDown (RowType)
'insert Rationale Field
Selection.MoveRight unit:=wdCell, Count:=1
CreateRationaleTextField
'Create Statement Field
Selection.MoveRight unit:=wdCell, Count:=1
InsertNewStatementField
Select Case RowType
Case "Comment"
Selection.SelectCell
Selection.Style = "body"
Selection.Font.Italic = True
Case "ExtRef"
Selection.SelectCell
Selection.Style = "body"
Selection.Font.Bold = True
End Select
'Return to Beginning of Row
Selection.SelectRow
Selection.MoveLeft unit:=wdCharacter, Count:=1
End Sub
Sub InsertNewStatementField()
Selection.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = False
.HelpText = ""
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
End With
End Sub
Sub CreateNewRowDropDown(NewRo
Set dd_NewRow = Selection.FormFields.Add( _
Range:=Selection.Range, Type:=wdFieldFormDropDown)
dd_NewRow.Name = NewRowType
dd_NewRow.HelpText = "This item is Guidance."
dd_NewRow.ExitMacro = "DropDownChangeResult"
With dd_NewRow.DropDown.ListEnt
Select Case NewRowType
Case "NewPractice"
.Add Name:="New Practice"
.Add Name:="Delete Row"
Case "AltPractice"
.Add Name:="Alternate Practice"
.Add Name:="Delete Row"
Case "Comment"
.Add Name:="Comment"
.Add Name:="Delete Row"
Case "ExtRef"
.Add Name:="ID Ext Reference"
.Add Name:="Delete Row"
End Select
End With
End Sub
Sub DeleteRow()
Debug.Print "Now entering: DeleteRow"
'This macro deletes a row that was previously added by the user
'The macro should first prompt the user with an "Are You Sure"
'Then remove the row if the user clicks ok, cancel will return the dd value
'to the first entry in the dd... which is the only other value besides "Delete Row"
Dim Msg, Style, Title, Response
Msg = "Do you really want to delete the row?" ' Define message.
Style = vbYesNo + vbExclamation + vbDefaultButton2 ' Define buttons.
Title = "WARNING: YOU ARE ABOUT TO DELETE A ROW!!" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
Selection.Rows.Delete
Else
Selection.FormFields(1).Dr
End If
End Sub
Sub setBackgroundColor(vColor As Variant)
Selection.Cells.Shading.Ba
End Sub
Sub GenDocs()
'
' GenDocs Macro
' by
'
Dim CurrDocName, CurrDocPath
CurrDocName = ActiveDocument.Name
CurrDocPath = ActiveDocument.Path
'Generate the "Clean" Version of the CurrentDoc
'But first, a warning:
Dim Response, Style
Dim Title As String, Msg As String
Msg = "You are about to overwrite the Clean and Redline files for " & CurrDocName & ". If you would like to CANCEL and save the existing files please do so before proceeding. To PROCEED anyway, click the OK button."
Title = "WARNING!!"
Style = vbOKCancel + vbExclamation + vbDefaultButton2
Response = MsgBox(Msg, Style, Title)
If Response = vbCancel Then
Exit Sub
End If
' mdm - response is not checked
' ep - response checking added
ChangeFileOpenDirectory "..\" & TAILORINGFOLDER & "\"
ActiveDocument.SaveAs FileName:="T_" & CurrDocName, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
With Selection
.HomeKey unit:=wdLine
.MoveUp unit:=wdLine, Count:=1
.HomeKey unit:=wdStory
.Rows.Delete
.Columns.Delete
.Columns.Delete
.Rows.ConvertToText Separator:=wdSeparateByPar
.Fields.Unlink
End With
ActiveDocument.Save
ChangeFileOpenDirectory "..\" & REDLINEFOLDER & "\"
ActiveDocument.SaveAs FileName:="R_" & CurrDocName, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
'''' NEEDS CLEANING '''''
ActiveDocument.Compare Name:="..\" & ENABLERfolder & "\1SPP-521_090304.doc"
Selection.WholeStory
Selection.HomeKey unit:=wdLine
ActiveDocument.Save
End Sub
'*************************
'* THIS IS THE END OF THE CODE THAT *
'* THE USERS NEED *
'*************************
I'll give that a try!!
Thanks
Sasho:
I wouldn't even know what a memory leak in my code looked like. The computer's not dripping, so I thought everything was ok!! ;) If you know what to look for and find a leak that keeps me from crashing, I'll add points (I'm a paying member, so I hand 'em out generously!)
You asked for it...
Const TAILORINGFOLDER = "Tailoring_Area"
Const REDLINEFOLDER = "Redlined_Versions"
Const PROJECTFOLDER = "Project_Enabler"
Const MASTERFOLDER = "Enabler"
Const ENDOFTEXTMARKER = "~~THE END~~"
Const LASTFIELDMARKER = "END"
'*************************
'* THIS CODE IS REQUIRED FOR CONVERSION AND BY END USERS *
'*************************
Sub CreateRationaleTextField()
'Debug.Print "Now entering: CreateRationaleTextField"
Set dd_Rationale = Selection.FormFields.Add( _
Range:=Selection.Range, Type:=wdFieldFormTextInput
With dd_Rationale
.Name = "Rationale"
.HelpText = "Insert your rationale here."
.TextInput.Width = 512
End With
End Sub
Sub CreateStatementField()
'Debug.Print "Now entering: CreateStatementField"
'
' CreateStatementField Macro
' by
Dim OrigGuideText As String
'THIS NEEDS TO BE CHANGED!!!: IT TRUNCATES TEXT!
'OrigGuideText = Left(Selection.Range.Text,
OrigGuideText = Selection.Range.Text
Debug.Print "This is origguidetext: " & OrigGuideText
Debug.Print Len(OrigGuideText)
If Len(OrigGuideText) <= 255 Then
Debug.Print "Len is <= 255"
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = OrigGuideText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=OrigGuideText, Format:=""
End With
'Selection.Comments.Add Range:=Selection.Range
'Selection.TypeText Text:=OrigGuideText
Else
Debug.Print "I'm in the else"
Dim NumLoops As Integer
NumLoops = (Len(OrigGuideText) / 255) + 1
Debug.Print NumLoops
Dim Counter As Integer
Dim CurrText As String
Counter = 1
Do While Counter <= NumLoops
CurrText = Left(OrigGuideText, 255)
Debug.Print "CurrText = " & CurrText
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = CurrText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=CurrText, Format:=""
End With
Selection.MoveRight unit:=wdCell, Count:=1
Selection.MoveLeft unit:=wdCell
Selection.MoveRight unit:=wdCharacter
OrigGuideText = Mid$(OrigGuideText, 256)
Counter = Counter + 1
'Selection.Comments.Add Range:=Selection.Range
'Selection.TypeText Text:=OrigGuideText
Loop
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=1
End If
End Sub
'*************************
'* END OF CODE THAT IS REQUIRED FOR *
'* CONVERSION AND BY END USERS *
'*************************
'*************************
'* THIS CODE IS FOR CONVERTING ENABLER *
'* DOCUMENTS INTO TAILORING TOOLS. *
'*************************
Sub ACreateTailoringReport()
Debug.Print "Now entering: CreateTailoringReport"
'
' CreateTailoringReport Macro
' by
'
'This is just a reminder to the conversion person:
Dim Response
Response = MsgBox("Have you checked for and eliminated hyperlinks?", 4, "REMINDER!")
If Response = vbNo Then
Exit Sub
End If
'THIS IS A TEMPORARY ITEM SEE MODULE HEADER FOR MORE INFO
'NOTE that for this to work, the paragraph markers must be
'VISIBLE!
RemoveHiddenText
'Make the Table:
MakeTable
'Create Rationale Column/Fields
InsertRationaleFields
'Label Tailoring Type Column and Create Guidance DropDowns
InsertGuideDropDown
'Create end of document bookmark
InsertEndMark
'Replace Guidance DropDowns with Requirements DropDowns for SPP statements.
' There are SPP statements with "{" and with "("
FindRequiredItems1
FindRequiredItems2
'Delete input fields for Headings and Intro Text
DeleteIntroSectionFields
'Replace Guidance Statements with form fields
'This needs to be fixed for text longer than 255 char
FindGuidanceUpdateStatemen
'Delete the end-of-document markers:
RemoveEndMarks
'Insert Filename/Path autotext for future reference
' NormalTemplate.AutoTextEnt
Selection.Range
End Sub
Sub RemoveHiddenText()
'
' RemoveBadStuff Macro
' by
' This is to remove hidden text from draft (test) documents
' the final documents shouldn't have any hidden text... might have some hyperlinks
With Selection.Find
.ClearFormatting
.Font.Hidden = True
.Replacement.ClearFormatti
.Replacement.Font.Hidden = False
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = True
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute Replace:=wdReplaceAll
End With
End Sub
Sub MakeTable()
With Selection
.WholeStory
.ConvertToTable Separator:=wdSeparateByPar
NumRows:=409, Format:=wdTableFormatNone,
ApplyShading:=True, ApplyFont:=True, ApplyColor:=True, ApplyHeadingRows:= _
True, ApplyLastRow:=False, ApplyFirstColumn:=True, ApplyLastColumn:=False _
, AutoFit:=True, AutoFitBehavior:=wdAutoFit
.InsertColumns
.Style = ActiveDocument.Styles("Nor
.Columns.PreferredWidthTyp
.Columns.PreferredWidth = InchesToPoints(2.5)
.InsertColumns
.Style = ActiveDocument.Styles("Nor
.Tables(1).AutoFitBehavior
.Columns.PreferredWidthTyp
.Columns.PreferredWidth = InchesToPoints(1)
.MoveUp unit:=wdLine, Count:=1
.InsertRowsAbove 1
.MoveLeft unit:=wdCharacter, Count:=1
.MoveRight unit:=wdCell
.MoveRight unit:=wdCell
.TypeText Text:="Statement"
.MoveRight unit:=wdCell
'Return to top of doc
.WholeStory
.MoveLeft unit:=wdCharacter, Count:=1
End With
End Sub
Sub InsertRationaleFields()
Debug.Print "Now entering: InsertRationaleFields"
'
' InsertRationaleFields Macro
' by
With Selection
'Go to the top of the doc:
.WholeStory
.MoveLeft unit:=wdCharacter, Count:=1
'Move to Rationale Column:
.MoveRight unit:=wdCell
End With
'Create one instance of the Rationale Field
CreateRationaleTextField
With Selection
'Copy the text field...
.SelectCell
.Copy
'...then paste copies of the field in the entire column.
.SelectColumn
.Paste
.MoveUp unit:=wdLine, Count:=1
.Delete unit:=wdCharacter, Count:=1
End With
End Sub
Sub InsertGuideDropDown()
Debug.Print "Now entering: InsertGuideDropDown"
'
' InsertReqDropDown Macro
' by
'
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
Set dd_Guide = Selection.FormFields.Add(R
dd_Guide.Name = "Guidance"
dd_Guide.HelpText = "This item is Guidance."
dd_Guide.ExitMacro = "DropDownChangeResult"
With dd_Guide.DropDown.ListEntr
.Add Name:="<Guidance>"
.Add Name:="Applicable"
.Add Name:="Delete"
.Add Name:="Modify"
.Add Name:="New Practice"
.Add Name:="Id Ext Reference"
.Add Name:="Not Applicable"
.Add Name:="Add Comment"
.Add Name:="DEFAULT Statement"
End With
With Selection
.SelectCell
.Copy
.SelectColumn
.Paste
.MoveUp unit:=wdLine, Count:=1
.Delete unit:=wdCharacter, Count:=1
.TypeText Text:="Tailoring Type"
End With
End Sub
Sub InsertEndMark()
'
' InsertEndMark Macro
' Macro recorded 9/9/2004 by
'
With Selection
.WholeStory
.EndKey unit:=wdLine
.TypeText ENDOFTEXTMARKER
.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
.PreviousField.Select
.FormFields(1).Name = LASTFIELDMARKER
End With
End Sub
Sub FindRequiredItems1()
Debug.Print "Now entering: FindRequiredItems1"
'
' FindRequiredItems Macro
' by
'
Selection.GoTo wdGoToLine, wdGoToFirst
With Selection.Find
.ClearFormatting
Do While .Execute(FindText:="{SPP")
With Selection
With Selection.Find
.Text = "{SPP"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=2
If Selection.FormFields(1).Na
Exit Do
End If
Selection.Delete
InsertReqDropDown
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
End With
Loop
End With
End Sub
Sub FindRequiredItems2()
Debug.Print "Now entering: FindRequiredItems2"
'
' FindRequiredItems Macro
' by
'
Selection.GoTo wdGoToLine, wdGoToFirst
With Selection.Find
.ClearFormatting
Do While .Execute(FindText:="(SPP")
With Selection
With Selection.Find
.Text = "(SPP"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Selection.GoTo What:=wdGoToField, Which:=wdGoToPrevious, Count:=2
If Selection.FormFields(1).Na
Exit Do
End If
Selection.Delete
InsertReqDropDown
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
End With
Loop
End With
End Sub
Sub InsertReqDropDown()
Debug.Print "Now entering: InsertReqDropDown"
'
' InsertReqDropDown Macro
' by
'
Set dd_Req = Selection.FormFields.Add(R
dd_Req.Name = "Requirement"
dd_Req.HelpText = "This item is a Requirement."
dd_Req.ExitMacro = "DropDownChangeResult"
With dd_Req.DropDown.ListEntrie
.Add Name:="<Required>"
.Add Name:="Comply"
.Add Name:="Deviation"
.Add Name:="Waiver"
.Add Name:="Alternate Practice"
.Add Name:="Add Comment"
End With
End Sub
Sub DeleteIntroSectionFields()
'
' DeleteFields Macro
' by
'
'Go to the top of the document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
With Selection.Find
.ClearFormatting
.Text = "Entry Criteria"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
With Selection
.MoveLeft unit:=wdCell
.HomeKey unit:=wdStory, Extend:=wdExtend
.Delete unit:=wdCharacter, Count:=1
.TypeText Text:="Tailoring Type"
.MoveRight unit:=wdCell
.TypeText Text:="Rationale"
End With
End Sub
Sub FindGuidanceUpdateStatemen
Debug.Print "Now entering: FindGuidanceUpdateStatemen
'
' EndOfDocBookmark Macro
'
' THIS MACRO WILL NOT WORK IF THERE ARE ANY HYPERLINKS IN THE TXT! (For now)
'Go to the top of the document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
'Go to the first field in the document
Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1
'Find each Guidance Field and update the Statement field,
'until you get to the end of the document.
Do Until Selection.FormFields(1).Na
Selection.GoTo What:=wdGoToField, Which:=wdGoToNext, Count:=1
If Selection.FormFields(1).Na
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.Copy
CreateStatementField
End If
Loop
End Sub
Sub RemoveEndMarks()
'
' RemoveEndMarks Macro
'
'Go to beginning of document
Selection.WholeStory
Selection.MoveLeft unit:=wdCharacter, Count:=1
'Find the end text and replace with nothing (delete it)
With Selection.Find
.Text = ENDOFTEXTMARKER
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
'Delete End form field
Selection.EndKey unit:=wdStory
Selection.MoveLeft
Selection.Delete unit:=wdCharacter, Count:=1
Selection.Style = "normal"
'Return to top of document
Selection.HomeKey unit:=wdStory
End Sub
'*************************
'* THIS IS THE END OF THE CODE THAT *
'* CONVERTS DOCUMENTS INTO TAILORING TOOL. *
'*************************
'*************************
'* THIS IS THE CODE THAT THE USERS NEED *
'* SO THAT THE TAILORING TOOL WILL WORK *
'*************************
Sub DropDownChangeResult()
Dim CurrentDDValue As Integer
Dim UserChoice As String
CurrentDDValue = Selection.FormFields(1).Dr
UserChoice = Selection.FormFields(1).Dr
' 9-13 removed all of the UnProtect/Protect from the Case statments and moved them
' before and after. The "delete" case did not have unprotect/protect (but it does now)
UnProtect
Select Case UserChoice
Case "Applicable"
Call setBackgroundColor(wdColor
Case "Delete", "Modify"
Call setBackgroundColor(wdColor
Case "Waiver", "Deviation"
Call setBackgroundColor(wdColor
'RemoveRequirementText
StrikeoutRequirementText
Case "Id Ext Reference"
IdExtRef
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "New Practice"
NewPractice
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "Alternate Practice"
Call setBackgroundColor(wdColor
AltPractice
MoveToRationaleCell
Case "Add Comment"
NewComment
Call setBackgroundColor(wdColor
MoveToRationaleCell
Case "Delete Row"
DeleteRow
Case "DEFAULT Statement"
ResetDefText
Case Else
Call setBackgroundColor(wdColor
End Select
Protect
End Sub
Sub RemoveRequirementText()
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.SelectCell
Selection.Copy
Selection.Cut
End Sub
Sub StrikeoutRequirementText()
Selection.MoveRight unit:=wdCell
Selection.MoveRight unit:=wdCell
Selection.SelectCell
With Selection.Font
.StrikeThrough = True
.Color = wdColorRed
End With
End Sub
Sub ResetDefText()
Dim Response, Style
Dim Title As String, Msg As String
Msg = "Are you sure you want to reset the Statement Text?"
Title = "WARNING!!"
Style = vbYesNo + vbExclamation + vbDefaultButton2
Response = MsgBox(Msg, Style, Title)
If Response = vbNo Then
Exit Sub
End If
Dim DefaultText
Selection.GoToNext wdGoToField
Selection.GoToNext wdGoToField
DefaultText = Selection.FormFields(1).Te
Selection.Delete
Selection.FormFields.Add Range:=Selection.Range, Type:= _
wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = True
.HelpText = DefaultText
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
.TextInput.EditType Type:=wdRegularText, Default:=DefaultText, Format:=""
End With
End Sub
Sub MoveToRationaleCell()
Selection.GoToNext wdGoToField
End Sub
Sub NewComment()
InsertTableRow ("Comment")
End Sub
Sub IdExtRef()
InsertTableRow ("ExtRef")
End Sub
Sub NewPractice()
InsertTableRow ("NewPractice")
End Sub
Sub AltPractice()
InsertTableRow ("AltPractice")
End Sub
Sub Protect()
ActiveDocument.Protect Password:="", NoReset:=True, Type:=wdAllowOnlyFormField
End Sub
Sub UnProtect()
ActiveDocument.UnProtect Password:=""
End Sub
Sub InsertTableRow(RowType As String)
Debug.Print "Now Entering: InsertTableRow"
'
' InsertTableRow Macro
' by
'
'Id Req Type
Dim ReqType As String
ReqType = Selection.FormFields(1).Na
Debug.Print "ReqType= " & ReqType
'Set current row dropdown to "default" <...> value:
If RowType <> "AltPractice" Then
Selection.FormFields(1).Dr
End If
'insert row
Selection.InsertRowsBelow
'populate row with fields
'create Tailoring Type Field
CreateNewRowDropDown (RowType)
'insert Rationale Field
Selection.MoveRight unit:=wdCell, Count:=1
CreateRationaleTextField
'Create Statement Field
Selection.MoveRight unit:=wdCell, Count:=1
InsertNewStatementField
Select Case RowType
Case "Comment"
Selection.SelectCell
Selection.Style = "body"
Selection.Font.Italic = True
Case "ExtRef"
Selection.SelectCell
Selection.Style = "body"
Selection.Font.Bold = True
End Select
'Return to Beginning of Row
Selection.SelectRow
Selection.MoveLeft unit:=wdCharacter, Count:=1
End Sub
Sub InsertNewStatementField()
Selection.FormFields.Add Range:=Selection.Range, Type:=wdFieldFormTextInput
Selection.PreviousField.Se
With Selection.FormFields(1)
.Name = "Statement"
.EntryMacro = ""
.ExitMacro = ""
.Enabled = True
.OwnHelp = False
.HelpText = ""
.OwnStatus = False
.StatusText = ""
.TextInput.Width = 512
End With
End Sub
Sub CreateNewRowDropDown(NewRo
Set dd_NewRow = Selection.FormFields.Add( _
Range:=Selection.Range, Type:=wdFieldFormDropDown)
dd_NewRow.Name = NewRowType
dd_NewRow.HelpText = "This item is Guidance."
dd_NewRow.ExitMacro = "DropDownChangeResult"
With dd_NewRow.DropDown.ListEnt
Select Case NewRowType
Case "NewPractice"
.Add Name:="New Practice"
.Add Name:="Delete Row"
Case "AltPractice"
.Add Name:="Alternate Practice"
.Add Name:="Delete Row"
Case "Comment"
.Add Name:="Comment"
.Add Name:="Delete Row"
Case "ExtRef"
.Add Name:="ID Ext Reference"
.Add Name:="Delete Row"
End Select
End With
End Sub
Sub DeleteRow()
Debug.Print "Now entering: DeleteRow"
'This macro deletes a row that was previously added by the user
'The macro should first prompt the user with an "Are You Sure"
'Then remove the row if the user clicks ok, cancel will return the dd value
'to the first entry in the dd... which is the only other value besides "Delete Row"
Dim Msg, Style, Title, Response
Msg = "Do you really want to delete the row?" ' Define message.
Style = vbYesNo + vbExclamation + vbDefaultButton2 ' Define buttons.
Title = "WARNING: YOU ARE ABOUT TO DELETE A ROW!!" ' Define title.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
Selection.Rows.Delete
Else
Selection.FormFields(1).Dr
End If
End Sub
Sub setBackgroundColor(vColor As Variant)
Selection.Cells.Shading.Ba
End Sub
Sub GenDocs()
'
' GenDocs Macro
' by
'
Dim CurrDocName, CurrDocPath
CurrDocName = ActiveDocument.Name
CurrDocPath = ActiveDocument.Path
'Generate the "Clean" Version of the CurrentDoc
'But first, a warning:
Dim Response, Style
Dim Title As String, Msg As String
Msg = "You are about to overwrite the Clean and Redline files for " & CurrDocName & ". If you would like to CANCEL and save the existing files please do so before proceeding. To PROCEED anyway, click the OK button."
Title = "WARNING!!"
Style = vbOKCancel + vbExclamation + vbDefaultButton2
Response = MsgBox(Msg, Style, Title)
If Response = vbCancel Then
Exit Sub
End If
' mdm - response is not checked
' ep - response checking added
ChangeFileOpenDirectory "..\" & TAILORINGFOLDER & "\"
ActiveDocument.SaveAs FileName:="T_" & CurrDocName, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
With Selection
.HomeKey unit:=wdLine
.MoveUp unit:=wdLine, Count:=1
.HomeKey unit:=wdStory
.Rows.Delete
.Columns.Delete
.Columns.Delete
.Rows.ConvertToText Separator:=wdSeparateByPar
.Fields.Unlink
End With
ActiveDocument.Save
ChangeFileOpenDirectory "..\" & REDLINEFOLDER & "\"
ActiveDocument.SaveAs FileName:="R_" & CurrDocName, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
True, WritePassword:="", ReadOnlyRecommended:=False
False, SaveNativePictureFormat:=F
SaveAsAOCELetter:=False
'''' NEEDS CLEANING '''''
ActiveDocument.Compare Name:="..\" & ENABLERfolder & "\1SPP-521_090304.doc"
Selection.WholeStory
Selection.HomeKey unit:=wdLine
ActiveDocument.Save
End Sub
'*************************
'* THIS IS THE END OF THE CODE THAT *
'* THE USERS NEED *
'*************************
[quote]
Selection.EndKey unit:=wdStory
Selection.MoveLeft
[/quote]
You're trying to get to the top of the document?
That can be replaced with:
Selection.HomeKey Unit:=wdStory
Sir, I think you should send me an email so that I can invite you into our Word VBA Training BETA course...
It's going slowly, but it IS going.
:)
Selection.EndKey unit:=wdStory
Selection.MoveLeft
[/quote]
You're trying to get to the top of the document?
That can be replaced with:
Selection.HomeKey Unit:=wdStory
Sir, I think you should send me an email so that I can invite you into our Word VBA Training BETA course...
It's going slowly, but it IS going.
:)
epuglise.
the error sounds to me like you had some recursion going on (a function calling itself again and again). Do you have any startup code in this document?
Jan
the error sounds to me like you had some recursion going on (a function calling itself again and again). Do you have any startup code in this document?
Jan
ASKER
start up code? Not sure what that is. Unless Word created that on its own, I didn't create any.
Also, does anyone know if Autoformatting could be a performance issue with word? If it is, is there a way to turn it off in my code?
thanks!!
Also, does anyone know if Autoformatting could be a performance issue with word? If it is, is there a way to turn it off in my code?
thanks!!
OMG. Get RID of autoformatting. Heck yes, it bloats hell out of files, for one thing.
If you can send me your file, I will do my best to clean up your code. BUT that has to be outside the scope of this question, which should be answered separately.
You've got my addy.
I replied to your last email.
If you can send me your file, I will do my best to clean up your code. BUT that has to be outside the scope of this question, which should be answered separately.
You've got my addy.
I replied to your last email.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
I split the points because I did three things that solved this problem:
1. turn off autoformatting (Dreamboat)
2. Export code, reimport it (Dreamboat)
3. "reset" my normal.dot
Folks thanks to all!!!
1. turn off autoformatting (Dreamboat)
2. Export code, reimport it (Dreamboat)
3. "reset" my normal.dot
Folks thanks to all!!!