Please tell us in plain English (sorry, my French would not be up to it)
briefly what it is that you are trying to do. That will probably be easier
than trying to figure it out from your code. After all, if the code was
doing what you want, we would not even be discussing it.
Which document is intended to be the active document at the time you use
Set doc = ActiveDocument
If it is source or target, why not just use the relevant one of them rather
than create a new reference?
Then with
With ActiveDocument.PageSetup
what document are we referring to?
Then you break out into using Selection all over the place so it is little
wonder that Word got lost.
You will find your code much easier to debug if you indent each With End
WIth, Do Loop, If... Else...End If construction, as below, but having said
all of that, you might get away with putting a Source.Activate command
before the final Loop command after you close Target. No promises though.
Private Sub cmdExporttotal_Click()
'
' stuckliste Macro
' Macro created 06.11.2003 by Mihai Kovacs
'
On Error GoTo EROARE
GoTo START
'error mesage
EROARE:
MsgBox "Error number" & Err & ":" & Error(Err)
End
START:
Dim Source, Target As Document
Dim doc As Document
Dim arange, r As Range
Dim fname, nume, s, Status As String
'hide frmIntimpinare
Status = txtInput.Value
Unload frmIntimpinare
'Open document
ChDir "C:\Program Files\Reflection\User\Export"
Documents.Open FileName:="lpsd7ro2", ConfirmConversions:=False,
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="",
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="",
WritePasswordTemplate:="", Format:=wdOpenFormatText
'Back to begining of document
Selection.HomeKey Unit:=wdStory
'Setez sourec si definesc selectia
'Set sourec = ActiveDocument
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k2S*&k0S", MatchWildcards:=True,
Wrap:=wdFindContinue, Forward:=False) = True
'copy selectia
Set arange = Selection.Range
'new document
Set Target = Documents.Add
'introducing the new selection in the new document
Target.Range.FormattedText = arange.FormattedText
'delete selection
arange.Delete
'preparing for name of doc - finding the product cod
Set doc = ActiveDocument
Set r = doc.Range
'finding product cod (begins always with 0 and has 12 numbers)
With r.Find
Text = "0[0-9]{11}"
MatchWildcards = True
Execute
If .Found Then
's has the name of the product
s = r.Text
End If
End With
'START:
'Formating page
With ActiveDocument.PageSetup
Orientation = wdOrientLandscape
TopMargin = CentimetersToPoints(0.46)
BottomMargin = CentimetersToPoints(0.5)
LeftMargin = CentimetersToPoints(1)
RightMargin = CentimetersToPoints(0.46)
Gutter = CentimetersToPoints(0)
HeaderDistance = CentimetersToPoints(0)
FooterDistance = CentimetersToPoints(0)
PageWidth = CentimetersToPoints(29.7)
PageHeight = CentimetersToPoints(21)
End With
'Selecting all and font is 7
Selection.WholeStory
Selection.Font.Size = 7
'Finding 1flexibler insering new line once
Application.DisplayAlerts = wdAlertsNone
With Selection.Find
Text = "1flexibler"
Replacement.Text = ""
Forward = True
Wrap = wdFindAsk
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
'Descend one page and a line for finding
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=2,
Name:=""
Selection.Find.ClearFormatting
Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1,
Name:=""
Selection.Find.ClearFormatting
'Loop to find and insert page break
With ActiveDocument.Content.Find
Do While .Execute(findtext:="1flexibler", Forward:=True) = True
'Selection.WholeStory
With Selection.Find
Text = "1flexibler"
Replacement.Text = ""
Forward = True
Wrap = wdFindStop
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
'Selection.Find.Execute
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
'Descend one line
Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext,
Count:=1, Name:=""
Selection.Find.ClearFormatting
Loop
'Go to end of the document
End With
Selection.EndKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Finding and deleting last two page breaks
With Selection.Find
Text = "^m"
Replacement.Text = ""
Forward = False
Wrap = wdFindAsk
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
Selection.Find.Execute
With Selection
If .Find.Forward = True Then
Collapse Direction:=wdCollapseStart
Else
Collapse Direction:=wdCollapseEnd
End If
Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
Collapse Direction:=wdCollapseEnd
Else
Collapse Direction:=wdCollapseStart
End If
Find.Execute
End With
With Selection
If .Find.Forward = True Then
Collapse Direction:=wdCollapseStart
Else
Collapse Direction:=wdCollapseEnd
End If
Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
Collapse Direction:=wdCollapseEnd
Else
Collapse Direction:=wdCollapseStart
End If
Find.Execute
End With
'Back to begining
Selection.HomeKey Unit:=wdStory
'Delete &k2S
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k2S", MatchWildcards:=True,
Wrap:=wdFindContinue, Forward:=False) = True
'copy selection
Set arange = Selection.Range
'delete selectia
arange.Delete
Loop
End With
'delete end &k0S
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k0S", MatchWildcards:=True,
Wrap:=wdFindContinue, Forward:=False) = True
'copy selectia
Set arange = Selection.Range
'delete selectia
arange.Delete
Loop
End With
'save and close the new doc
Target.SaveAs FileName:="C:\Documents and Settings\user\My
Documents\Stuckliste\export\" & s & " status " & Status,
WritePassword:="automotive", ReadOnlyRecommended:=True
'delete duplicate line with bezeichnung
' Selection.HomeKey wdStory
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
' With Selection.Find
' .Text = "( Bezei*^13)( Bezei*^13)"
' .Replacement.Text = "\1"
' .Forward = True
' .Wrap = wdFindContinue
' .Format = False
' .MatchCase = False
' .MatchWholeWord = False
' .MatchAllWordForms = False
' .MatchSoundsLike = False
' .MatchWildcards = True
' End With
' Selection.Find.Execute Replace:=wdReplaceAll
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
Target.Close
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
Loop
End With
ActiveDocument.Close (False)
'Mesaj gata
MsgBox "Gata!", vbOKOnly, "Info"
Documents("Import stk.doc").Close False
End Sub
--
Please post any further questions or followup to the newsgroups for the
benefit of others who may be interested. Unsolicited questions forwarded
directly to me will only be answered on a paid consulting basis.
Hope this helps
Doug Robbins - Word MVP
mihai said:
Yes your guess is right. Here is the whole code. Thanks for help.
Private Sub cmdExporttotal_Click()
'
' stuckliste Macro
' Macro created 06.11.2003 by Mihai Kovacs
'
On Error GoTo EROARE
GoTo START
'error mesage
EROARE:
MsgBox "Error number" & Err & ":" & Error(Err)
End
START:
Dim Source, Target As Document
Dim doc As Document
Dim arange, r As Range
Dim fname, nume, s, Status As String
'hide frmIntimpinare
Status = txtInput.Value
Unload frmIntimpinare
'Open document
ChDir "C:\Program Files\Reflection\User\Export"
Documents.Open FileName:="lpsd7ro2", ConfirmConversions:=False, _
ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="",
_
PasswordTemplate:="", Revert:=False, WritePasswordDocument:="",
_
WritePasswordTemplate:="", Format:=wdOpenFormatText
'Back to begining of document
Selection.HomeKey Unit:=wdStory
'Setez sourec si definesc selectia
'Set sourec = ActiveDocument
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k2S*&k0S", MatchWildcards:=True, _
Wrap:=wdFindContinue, Forward:=False) = True
'copy selectia
Set arange = Selection.Range
'new document
Set Target = Documents.Add
'introducing the new selection in the new document
Target.Range.FormattedText = arange.FormattedText
'delete selection
arange.Delete
'preparing for name of doc - finding the product cod
Set doc = ActiveDocument
Set r = doc.Range
'finding product cod (begins always with 0 and has 12 numbers)
With r.Find
Text = "0[0-9]{11}"
MatchWildcards = True
Execute
If .Found Then
's has the name of the product
s = r.Text
End If
End With
'START:
'Formating page
With ActiveDocument.PageSetup
Orientation = wdOrientLandscape
TopMargin = CentimetersToPoints(0.46)
BottomMargin = CentimetersToPoints(0.5)
LeftMargin = CentimetersToPoints(1)
RightMargin = CentimetersToPoints(0.46)
Gutter = CentimetersToPoints(0)
HeaderDistance = CentimetersToPoints(0)
FooterDistance = CentimetersToPoints(0)
PageWidth = CentimetersToPoints(29.7)
PageHeight = CentimetersToPoints(21)
End With
'Selecting all and font is 7
Selection.WholeStory
Selection.Font.Size = 7
'Finding 1flexibler insering new line once
Application.DisplayAlerts = wdAlertsNone
With Selection.Find
Text = "1flexibler"
Replacement.Text = ""
Forward = True
Wrap = wdFindAsk
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
Selection.Find.Execute
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
'Descend one page and a line for finding
Selection.GoTo What:=wdGoToPage, Which:=wdGoToFirst, Count:=2,
Name:=""
Selection.Find.ClearFormatting
Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1,
Name:=""
Selection.Find.ClearFormatting
'Loop to find and insert page break
With ActiveDocument.Content.Find
Do While .Execute(findtext:="1flexibler", Forward:=True) = True
'Selection.WholeStory
With Selection.Find
Text = "1flexibler"
Replacement.Text = ""
Forward = True
Wrap = wdFindStop
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
'Selection.Find.Execute
Selection.Find.Execute
Selection.HomeKey Unit:=wdLine
Selection.InsertBreak Type:=wdPageBreak
'Descend one line
Selection.GoTo What:=wdGoToLine, Which:=wdGoToNext, Count:=1,
Name:=""
Selection.Find.ClearFormatting
Loop
'Go to end of the document
End With
Selection.EndKey Unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
'Finding and deleting last two page breaks
With Selection.Find
Text = "^m"
Replacement.Text = ""
Forward = False
Wrap = wdFindAsk
Format = False
MatchCase = False
MatchWholeWord = False
MatchWildcards = False
MatchSoundsLike = False
MatchAllWordForms = False
End With
Selection.Find.Execute
With Selection
If .Find.Forward = True Then
Collapse Direction:=wdCollapseStart
Else
Collapse Direction:=wdCollapseEnd
End If
Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
Collapse Direction:=wdCollapseEnd
Else
Collapse Direction:=wdCollapseStart
End If
Find.Execute
End With
With Selection
If .Find.Forward = True Then
Collapse Direction:=wdCollapseStart
Else
Collapse Direction:=wdCollapseEnd
End If
Find.Execute Replace:=wdReplaceOne
If .Find.Forward = True Then
Collapse Direction:=wdCollapseEnd
Else
Collapse Direction:=wdCollapseStart
End If
Find.Execute
End With
'Back to begining
Selection.HomeKey Unit:=wdStory
'Delete &k2S
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k2S", MatchWildcards:=True, _
Wrap:=wdFindContinue, Forward:=False) = True
'copy selection
Set arange = Selection.Range
'delete selectia
arange.Delete
Loop
End With
'delete end &k0S
Selection.Find.ClearFormatting
With Selection.Find
Do While .Execute(findtext:="&k0S", MatchWildcards:=True, _
Wrap:=wdFindContinue, Forward:=False) = True
'copy selectia
Set arange = Selection.Range
'delete selectia
arange.Delete
Loop
End With
'save and close the new doc
Target.SaveAs FileName:="C:\Documents and Settings\user\My
Documents\Stuckliste\export\" & s _
& " status " & Status, WritePassword:="automotive",
ReadOnlyRecommended:=True
'delete duplicate line with bezeichnung
' Selection.HomeKey wdStory
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
' With Selection.Find
' .Text = "( Bezei*^13)( Bezei*^13)"
' .Replacement.Text = "\1"
' .Forward = True
' .Wrap = wdFindContinue
' .Format = False
' .MatchCase = False
' .MatchWholeWord = False
' .MatchAllWordForms = False
' .MatchSoundsLike = False
' .MatchWildcards = True
' End With
' Selection.Find.Execute Replace:=wdReplaceAll
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
Target.Close
' Selection.Find.ClearFormatting
' Selection.Find.Replacement.ClearFormatting
Loop
End With
ActiveDocument.Close (False)
'Mesaj gata
MsgBox "Gata!", vbOKOnly, "Info"
Documents("Import stk.doc").Close False
End Sub
