Create Name of document to first word of it

[Aeneon]

Hey guy´s I´ve made a macro which split marked parts of a document into separate files.

Sub wcs()
wildcardsearch "/startreq", "/endreq"
End Sub

Public Sub wildcardsearch(str_wc1 As String, str_wc2 As String)
Dim new_document As Document
Dim i As Long
Dim note_collection As Collection
Dim pfad As String
Dim title As String


pfad = ActiveDocument.path
Set colNotes = collection_of_ranges(ActiveDocument, str_wc1, str_wc2)

If MsgBox("This will create " & _
colNotes.Count & _
" documents on the same folder. Do you wish to proceed?", vbYesNo) = vbNo Then
Exit Sub
End If


For i = 1 To colNotes.Count
Set docNew = Documents.Add
colNotes(i).Copy
docNew.Content.Paste
'search the /start & /end and replace them by nothing

docNew.Content.find.ClearFormatting
docNew.Content.find.Replacement.ClearFormatting
With Selection.find
.Text = "/startreq"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.find.Execute replace:=wdReplaceAll

docNew.Content.find.ClearFormatting
docNew.Content.find.Replacement.ClearFormatting
With Selection.find
.Text = "/endreq"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.find.Execute replace:=wdReplaceAll

'find the first word in the document and select it for create the title (if first word is space then delete the first word)

X = True
i = 2
ActiveDocument.Words(2).Select
title = Selection
Do While X
If Len(title) <= 3 Then
If Len(title) < 2 Then
title = ""
End If
i = i + 1
ActiveDocument.Words.Item(i).Select
title = title + Selection
Else
X = False
End If
Loop

' check for existing files
n = 0
X = True
Do While X
If Dir(pfad + title + ".docx") = "" Then
'function to save the document
docNew.SaveAs Filename:=pfad & "/" & title, FileFormat:=wdFormatDocument
docNew.Close SaveChanges:=True
X = False

Else
n = n + 1
title = title + str(n)
End If
Loop
Next


End Sub



Function collection_of_ranges(oDoc As Document, str_wc1 As String, str_wc2 As String) As Collection
Dim colReturn As Collection
Dim rngSearch As Range
Dim rngFound As Range


Set colReturn = New Collection
Set rngSearch = oDoc.Content
Set rngFound = rngSearch.Duplicate

Do
'wildcard search to find the keywords
With rngSearch.find
.MatchWildcards = True
.Text = "/startreq*/endreq"
.ClearFormatting
.Execute

If .Found Then
'copy the content between the keywords
rngFound.Start = rngSearch.Start
rngFound.End = rngSearch.End
colReturn.Add rngFound.Duplicate
rngSearch.Collapse wdCollapseEnd
rngFound.Start = rngSearch.End
rngSearch.End = oDoc.Content.End
Else
Exit Do
End If
End With
Loop Until rngSearch.Start >= ActiveDocument.Content.End

Set collection_of_ranges = colReturn
End Function

Private Sub class_inizialise()

End Sub



I want to apply a number to the file if the document already exist in the same location so i´ve to check if there is a document
how can i do this ?

[Doug Robbins]

See the article "How to save a documentusing a filename that gets incremented by 1 each time if the filename alreadyexists” at:
http://www.word.mvps.org/FAQs/MacrosVBA/SaveIncrementedFilename.htm (http://www.word.mvps.org/FAQs/MacrosVBA/SaveIncrementedFilename.htm)

[Aeneon]

See the article "How to save a documentusing a filename that gets incremented by 1 each time if the filename alreadyexists” at:
http://www.word.mvps.org/FAQs/MacrosVBA/SaveIncrementedFilename.htm (http://www.word.mvps.org/FAQs/MacrosVBA/SaveIncrementedFilename.htm)



you´re my hero !
but i´ve made some desicions because the programm didn´t work like i wanted.

X = True
Do While X
ActiveDocument.Words.First.Select
If Selection.Characters.Count <= 1 Then
Selection.Delete
Else
X = False
End If
Loop
title = Selection

i need to check if the first word / character is a regular text type and not a picture or a backslash how do i fix this ? (i quess deleting the stuff istn a good idea after all)

[Doug Robbins]

Use:

Dim Title As String
With ActiveDocument
If .Words(1).InlineShapes.Count = 1 Then
Title = .Words(2)
If Asc(Title) = 13 Then
Title = .Words(3)
End If
Else
Title = .Words(1)
End If
End With
Title = Replace(Title, "\", "-")

[Aeneon]

doesn´t work:
runtime error 54
wrong filename or number

it doesn´t get any string inside title, i solved it like this:
If .Words(1).InlineShapes.Count < 1 Then

[Doug Robbins]

Using

Dim Title As String
With ActiveDocument
If .Words(1).InlineShapes.Count = 1 Then
Title = .Words(2)
If Asc(Title) = 13 Then
Title = .Words(3)
End If
Else
Title = .Words(1)
End If
End With
Title = Replace(Title, "\", "-")
MsgBox Title

Displays the first word in the document whether it is preceded by a picture or a picture followed by a carriage return.

Show us all of the the code that you are now using and indicate which line of code is causing the error. What is at the beginning of your document?