syredronning

...of my recent programming (first since 1987, w000t!)

And BTW, the script error was somewhere else than I expected, so it works here now, too! :)

(Sorry that the formatting looks so lousy, that's lj's problem, my original is with indents.)

And no, please NO TROUBLESHOOTING or TIPS, ok? :) I'm just ventilating my happiness.

Attribute VB_Name = "NewMacros"
Dim mkdirname As String
Dim foldernameshort As String
Dim cfgfile As String
Sub makeanewfolder()
'makes a new folder for the help snippets
'under the path of the Active Document, if not already existent
'then checks if a cfg file of that name exists and deletes it, if yes

Dim path As String
Dim foldername As String

path = "" ' active document path

mkdirname = "" 'subdirectory path for help snippets

foldername = "" 'variables...
foldernamelength = ""
foldernameshort = ""

'reads the path of the active document and makes a new subdirectory
path = ActiveDocument.path 'Options.DefaultFilePath(ActiveDocument.path)
MsgBox path
If Not Right(path, 1) = "\" Then path = path & "\"

'shortens the active document name by 4 to remove the .doc
foldername = ActiveDocument.Name
foldernamelength = Len(foldername)
foldernamelength = foldernamelength - 4
foldernameshort = Left(foldername, foldernamelength)
mkdirname = path & foldernameshort & "\"
'MsgBox mkdirname
If (Dir(mkdirname, vbDirectory) <> "") Then
existsfile = True: MsgBox "Gibt's schon!"
Else
existsfile = False: MsgBox "Gibt's noch nicht!": MkDir mkdirname
End If

'builds the conversion batch filename with path and name
cfgfile = mkdirname & foldernameshort & "_convert.txt"

'checks if a file of this name already exists and deletes it, if yes
If (Dir(cfgfile) <> "") Then
existsfile = True: Kill cfgfile: MsgBox "File Deleted": Exit Sub
Else
MsgBox "The conversion file doesn't exist!"
Exit Sub
End If
End Sub
Sub writebatch(doctitle As String)
'appends the actual entry to the convert.bat file

cfgfile = mkdirname & foldernameshort & "_convert.txt" '"C:\Dokumente und Einstellungen\pictures\Eigene Dateien\convert.txt" 'txt because it is easier viewable
Open cfgfile For Append As #1
Print #1, "# Batch file for RTF conversion"
Print #1, "C:\Programme\SCHEMA\MarkupKit\Bin\rtf2hsdl.exe " & doctitle & ".rtf"
Print #1, "#"
Print #1, "# End"
Close #1
End Sub
Sub cleanup()
'deletes old convert.bat before starting a new one for this document
'i.e. with every new doc conversion the old one is overwritten so far

If (Dir(cfgfile) <> "") Then
'(Dir("C:\Dokumente und Einstellungen\pictures\Eigene Dateien\convert.txt") <> "") Then
existsfile = True: Kill cfgfile: MsgBox "File Deleted": Exit Sub
Else
MsgBox "The convert file doesn't exist!"
Exit Sub
End If

End Sub

Sub askforconversion()
'subroutine at the end to ask if the batch conversion shall be started now

Dim result As Integer
Dim mtitle As String

mtitle = "Conversion"
result = MsgBox(prompt:="Doc was sucessfully split! Do you want to start the batch conversion to HTML now?", _
Title:=mtitle, _
Buttons:=vbYesNo + vbQuestion)

Select Case result
Case Is = vbYes
MsgBox prompt:="Here the shell will start the batch process in the future!", _
Title:=mtitle, _
Buttons:=vbInformation
Case Is = vbNo
MsgBox prompt:="Splitting done without conversion!", _
Title:=mtitle, _
Buttons:=vbInformation
End Select
End Sub
Sub copy_chapters_schleife2()
'Headers not all complete for filename?
'( still in headline!
'Abbruch offensichtlich noch unsauber?!
'noch keine Speicherung in neue Folder!

Dim chapter As Range
Dim par As Paragraph
Dim paragraphcounter As Integer
Dim firstpar As Range
Dim doctitle As String
Dim chapterend As Boolean

paragraphcounter = ActiveDocument.Paragraphs.Count
j = 1

makeanewfolder 'makes new subfolder for snippets if necessary and checks for

Do While j <= paragraphcounter
If ActiveDocument.Paragraphs(j).Style = "Überschrift 3" Then
'MsgBox "Jetzt geht's los! In Zeile " & j
ActiveDocument.Paragraphs(j).Range.Select

Set firstpar = ActiveDocument.Paragraphs(j).Range 'take heading3 text and work with it
doctitle = ""
titlecounter = 0
tc = 1
titlecounter = firstpar.Words.Count
Do Until tc = titlecounter ' maybe needs to be shortened to avoid problems with crlf
orangetext = Trim(firstpar.Words(tc).Text)
'MsgBox orangetext
If Left(orangetext, 1) = "(" Then Exit Do 'removes ( in file name
doctitle = doctitle + orangetext
tc = tc + 1
Loop

writebatch (doctitle)

j = j + 1 'goto next paragraph of chapter
k = j 'counter for paragraphs from j downwards
chapterend = False
Do
Selection.MoveDown Unit:=wdParagraph, Extend:=wdExtend
k = k + 1
If ActiveDocument.Paragraphs(k).Style = "Überschrift 1" Then chapterend = True Else
If ActiveDocument.Paragraphs(k).Style = "Überschrift 2" Then chapterend = True Else
If ActiveDocument.Paragraphs(k).Style = "Überschrift 3" Then chapterend = True Else
If k = paragraphcounter Then chapterend = True Else
Loop Until chapterend

Selection.Copy

'Changes to the new director, opens a new doc,
'paste the contents and saves and closes

ChangeFileOpenDirectory mkdirname
Documents.Add DocumentType:=wdNewBlankDocument
Selection.Paste

ActiveDocument.SaveAs FileName:=doctitle, _
FileFormat:=wdFormatRTF, LockComments:=False, Password:="", _
AddToRecentFiles:=True, WritePassword:="", ReadOnlyRecommended:=False, _
EmbedTrueTypeFonts:=False, SaveNativePictureFormat:=False, SaveFormsData _
:=False, SaveAsAOCELetter:=False
ActiveDocument.Close

Selection.Collapse 'removes the actual selection

Else: j = j + 1

End If

Loop

askforconversion ' for the future batch conversion

End Sub