Retaining formatting?

[leecable]

So, after everyone's help. I have managed to sort my issue. With the help of gregs splitter, its split the document, retaining format. Which is exactly what I want.

The issue is, I want to know how todo it myself, rather than having to use gregs splitter..

Sub SplitNotes(delim As String, strFilename As String)
Dim doc As Document
 Dim arrNotes
 Dim I As Long
 Dim X As Long
 Dim Response As Integer
arrNotes = Split(ActiveDocument.Range, delim)
 Response = MsgBox("This will split the document into " & UBound(arrNotes) + 1 & " sections.Do you wish to proceed?", 4)
 If Response = 7 Then Exit Sub
 For I = LBound(arrNotes) To UBound(arrNotes)
 If Trim(arrNotes(I)) <> "" Then
 X = X + 1
 Set doc = Documents.Add
doc.Range = arrNotes(I)
doc.SaveAs ThisDocument.Path & "\" & strFilename & Format(X, "000")
doc.Close True
 End If
Next I
 End Sub
 Sub test()
'delimiter & filename
SplitNotes "delimiter", "Notes "
End Sub

So how do I go about adding it to this? Could someone add it, so that I can see a before and after? Its the easiest way my brain works!

[gmaxey]

Yours works to create the split documents, but those documents are not formatted. The reason is you are creating an array of strings (strings have text but not formatting) from the string of document text and then adding those strings to new documents.

My Add-In, basically gets the page layout of the document then copies and pastes (retaining the formatting) of range segments. So if your code would copy the text between the start of the document and first delimiter then paste it in a new document with the same page layout then it would work like mine. I don't publish that code because it took hours to develop and I hope people will use the addin and donate for my effort.

[leecable]

Ive found the relevant code in your splitter, but for the life of me, cant make it work to retain layout within my splitter! Im presuming its todo with the function at the end? I also dont want to post it, as I also want people to use it and see how good it is! You'll sure be getting a donation from myself when payday comes around!

[gmaxey]

If the code you found doesn't work then it is possible that it isn't the relevant code. Go ahead and post it. If you found it then others could as well.

[leecable]

If the code you found doesn't work then it is possible that it isn't the relevant code. Go ahead and post it. If you found it then others could as well.

Function SaveAsType(ByRef oDoc_Passed) As Long
SaveAsType = oDoc_Passed.SaveFormat
End Function

I'm guessing its to do with this bit Greg? Is a function something I can just add to the end of a script? I presume its going to have be manipulated in a certain way?

Thanks

[gmaxey]

All that function does is return a long value e.g., 15 indicating the type of source document. For example if the source document is a MacroEnabledXMLFormatTemplate, it returns 15.

I really can't make any sense of what your issue is unless you post your entire code. Splitting the source document into a string array as you have shown is not going to work though for the reasons I've stated. I'm not going to post the complete solution in the add-in as a tutorial either. I'm sorry.

[leecable]

Ok, that's fair enough..

Now, I have done some research, and I have discovered the PasteAndFormat method using wdFormatOriginalFormatting but, obviously this wont work, because of the string reason. So, im probably going to have to rewrite the entire thing, to take advantage of the clipboard?

[gmaxey]

Yes, that is one way with something like: .PasteAndFormat (wdFormatOriginalFormatting)

[leecable]

But, like I said. That wont work with the way my splitter works. Hmm, back to the drawing board.

[leecable]

So I am going to cheat and modify my normal template, so that its exactly how I want, and run it from there. That'll do the job untill I can work out how to do it any other way.

[gmaxey]

Since you have yet to post your splitter, then I can't say if it will work or not. Study this:

Sub ScratchMacro()
'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 7/13/2017
Dim lngParts As Long
Dim oRng1 As Range, oRng2 As Range, oRng3 As Range
Dim lngIndex As Long
Dim strDelim As String
Dim oDoc As Document
  strDelim = "///"
  Set oRng1 = ActiveDocument.Range
  Set oRng2 = ActiveDocument.Range
  lngParts = UBound(Split(oRng1.Text, strDelim)) + 1
    lngIndex = 1
    While lngIndex <= lngParts
      With oRng1.Find
        .Text = strDelim
        If .Execute Then
          If lngIndex = 1 Then
            Set oRng3 = oRng1
            oRng3.End = oRng1.Start
            oRng3.Start = ActiveDocument.Range.Start
          Else
            oRng2.Start = oRng1.End
            With oRng2.Find
              .Text = strDelim
              If .Execute Then
                Set oRng3 = oRng1
                oRng3.Start = oRng1.End '+ 1
                oRng3.End = oRng2.Start
              Else
                oRng3.Start = oRng1.End '+ 1
                oRng3.End = ActiveDocument.Range.End
              End If
            End With
          End If
          oRng3.Copy
          oRng1.Collapse wdCollapseEnd
          oRng2.Collapse wdCollapseEnd
        End If
      End With
      Set oDoc = Documents.Add(ActiveDocument.AttachedTemplate.FullName)
      oDoc.Content.Delete 'Strip template boiler plate text
      With Selection
        .PasteAndFormat (wdFormatOriginalFormatting)
        .EndKey Unit:=wdStory
        .MoveLeft Unit:=wdCharacter, Count:=1
        .Delete Unit:=wdCharacter, Count:=1
      End With
      oDoc.UpdateStylesOnOpen = False
      'I'll leave it to you to figure out how to save it.
      oDoc.Close wdDoNotSaveChanges
      lngIndex = lngIndex + 1
    Wend
lbl_Exit:
  Exit Sub
End Sub

[leecable]

Sub ScratchMacro()
     'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 7/13/2017
    Dim lngParts As Long
    Dim oRng1 As Range, oRng2 As Range, oRng3 As Range
    Dim lngIndex As Long
    Dim strDelim As String
    Dim oDoc As Document
    strDelim = "Aziylut"
    Set oRng1 = ActiveDocument.Range
    Set oRng2 = ActiveDocument.Range
    lngParts = UBound(Split(oRng1.Text, strDelim)) + 1
    lngIndex = 1
    While lngIndex <= lngParts
        With oRng1.Find
            .Text = strDelim
            If .Execute Then
                If lngIndex = 1 Then
                    Set oRng3 = oRng1
                    oRng3.End = oRng1.Start
                    oRng3.Start = ActiveDocument.Range.Start
                Else
                    oRng2.Start = oRng1.End
                    With oRng2.Find
                        .Text = strDelim
                        If .Execute Then
                            Set oRng3 = oRng1
                            oRng3.Start = oRng1.End '+ 1
                            oRng3.End = oRng2.Start
                        Else
                            oRng3.Start = oRng1.End '+ 1
                            oRng3.End = ActiveDocument.Range.End
                        End If
                    End With
                End If
                oRng3.Copy
                oRng1.Collapse wdCollapseEnd
                oRng2.Collapse wdCollapseEnd
            End If
        End With
        Set oDoc = Documents.Add(ActiveDocument.AttachedTemplate.FullName)
        oDoc.Content.Delete 'Strip template boiler plate text
        With Selection
            .PasteAndFormat (wdFormatOriginalFormatting)
            .EndKey Unit:=wdStory
            .MoveLeft Unit:=wdCharacter, Count:=1
            .Delete Unit:=wdCharacter, Count:=1
        End With
        oDoc.UpdateStylesOnOpen = False
                 'I'll leave it to you to figure out how to save it.
            X = X + 1
            ActiveDocument.SaveAs2 ThisDocument.Path & "\" & Notes & Format(X, "000")
        oDoc.Close wdDoNotSaveChanges
        lngIndex = lngIndex + 1
    Wend
End Sub

Not going to Lie Greg, I cant thank you enough. I've gone from a novice who can read no VBA, so actually understanding what is happening and why its happening...in less than 5 days. I really appreciate all of your help!

[leecable]

Sub ScratchMacro() 
     'A basic Word macro coded by Greg Maxey, http://gregmaxey.com/word_tips.html, 7/13/2017
    Dim lngParts As Long 
    Dim oRng1 As Range, oRng2 As Range, oRng3 As Range, oRng4 as Range
    Dim lngIndex As Long 
    Dim strDelim As String 
    Dim oDoc As Document 
    strDelim = "Aziylut" 
    Set oRng1 = ActiveDocument.Range 
    Set oRng2 = ActiveDocument.Range 
    lngParts = UBound(Split(oRng1.Text, strDelim)) + 1 
    lngIndex = 1 
    While lngIndex <= lngParts 
        With oRng1.Find 
            .Text = strDelim 
            If .Execute Then 
                If lngIndex = 1 Then 
                    Set oRng3 = oRng1 
                    oRng3.End = oRng1.Start 
                    oRng3.Start = ActiveDocument.Range.Start 
                Else 
                    oRng2.Start = oRng1.End 
                    With oRng2.Find 
                        .Text = strDelim 
                        If .Execute Then 
                            Set oRng3 = oRng1 
                            oRng3.Start = oRng1.End '+ 1
                            oRng3.End = oRng2.Start 
                        Else 
                            oRng3.Start = oRng1.End '+ 1
                            oRng3.End = ActiveDocument.Range.End 
                        End If 
                    End With 
                End If 
                oRng3.Copy 
                oRng1.Collapse wdCollapseEnd 
                oRng2.Collapse wdCollapseEnd 
            End If 
        End With 
        Set oDoc = Documents.Add(ActiveDocument.AttachedTemplate.FullName) 
        oDoc.Content.Delete 'Strip template boiler plate text
        With Selection 
            .PasteAndFormat (wdFormatOriginalFormatting) 
            .EndKey Unit:=wdStory 
            .MoveLeft Unit:=wdCharacter, Count:=1 
            .Delete Unit:=wdCharacter, Count:=1 
        End With 
        oDoc.UpdateStylesOnOpen = False 
 Set oRng4 = oDoc.Range 
        With oRng4.Find 
            .Text = "Title" 
            If .Execute Then 
                oRng4.MoveEndUntil Chr(13) 
                oRng4.Start = oRng4.Start + 7 
            End If 
        End With 
        ActiveDocument.SaveAs2 ThisDocument.Path & "\" & oRng4.text 
        oDoc.Close wdDoNotSaveChanges 
        lngIndex = lngIndex + 1 
    Wend 
End Sub

So much so, ive managed to merge both scripts, so now it finds the texts, copys, pastes, finds 'title' as uses it as the filename.

[gmaxey]

Now you just need to develop your SaveAs to ensure that you don't write over existing files.