' Copyright 2002 Stefan Ram
Option Explicit
Dim C As Variant
Dim CC As Variant
Dim CF As Variant
Dim CI As String
Dim CL As String
Dim CN As String
Dim CO As String
Dim CR As Word.Range
Dim CS As Word.Style
Dim CT As String
Dim D As Word.Document
Dim DL As Integer
Dim DP As Integer
Dim DN As String
Dim DS As String
Dim NI As Integer
Dim FN As String
Dim FI As Integer
Dim FX As String
Dim I As Integer
Dim IL As String
Dim IW As String
Dim J As Integer
Dim M As Integer
Dim ML As Integer
Dim MD As Integer
Dim NS As String
Const OQ = "( '"
Dim P As Word.Paragraph
Dim PA As String
Const PL = 0
Dim PN As Word.Paragraph
Dim PS As Word.Style
Const Q = "'"
Dim QE As String
Dim R As Range
Dim SP As Boolean
Dim T As String
Dim TD As String
Dim TT As String
Dim V As String
Dim VV As Variant
Dim WT As String
Dim WC As Integer
Dim WO As Integer
Const XL = 1
Sub Main()
TD = "c:\" ' you may edit this to your target directory
Set D = Word.ActiveDocument ' you may edit this to your source document
MD = XL
TT = ">"
FX = "xml"
IL = 0
QE = TT
For I = 0 To 31
IW = IW & "  "
Next I
FN = Replace(D.Name, ".", "_", , , vbBinaryCompare)
FI = FreeFile
Open TD & FN & "." & FX For Output As FI
Print #FI, "<?xml version=""1.0"" encoding=""us-ascii""?>" & vbLf;
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<doc:doc xmlns:fun=""http://www.purl.org/stefan_ram/xmlns/funren/"" xmlns:doc=""http://www.purl.org/stefan_ram/xmlns/docren/"">" & vbLf;
Print #FI, "<" & "doc:property" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
For Each VV In D.BuiltInDocumentProperties
On Error Resume Next
T = VV.Name
V = VV.Value
On Error GoTo 0
Print #FI, "<" & "fun:define" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:name" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(T)
WT = Mid(T, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:name" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:value" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(V)
WT = Mid(V, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:value" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "</" & "fun:define" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Next VV
Print #FI, "</" & "doc:property" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "doc:custom" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
For Each VV In D.CustomDocumentProperties
On Error Resume Next
T = VV.Name
V = VV.Value
On Error GoTo 0
Print #FI, "<" & "fun:define" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:name" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(T)
WT = Mid(T, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:name" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:value" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(V)
WT = Mid(V, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:value" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "</" & "fun:define" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Next VV
Print #FI, "</" & "doc:custom" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "doc:variable" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
For Each VV In D.Variables
On Error Resume Next
T = VV.Name
V = VV.Value
On Error GoTo 0
Print #FI, "<" & "fun:define" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:name" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(T)
WT = Mid(T, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:name" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "fun:value" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
WO = 0
For J = 1 To Len(V)
WT = Mid(V, J, 1)
WC = AscW(WT)
If WC < 32 Or WC > 126 Or WC = 92 Or WC = 39 Then
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "&#" & WC & ";";
Else
If Not WO Then
Print #FI, "<" & NS & "fun:text>";
WO = -1
End If
Print #FI, WT;
End If
Next J
If WO Then
Print #FI, "</" & NS & "fun:text>";
WO = 0
End If
Print #FI, "</" & "fun:value" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "</" & "fun:define" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Next VV
Print #FI, "</" & "doc:variable" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
DN = D.Name: DP = 0: NI = 1
Do While NI
DL = DP: DP = InStr(DP + 1, DN, ".", vbTextCompare): NI = DP:
Loop
DS = Left(DN, DL - 1)
Print #FI, "<" & "doc:docname" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & NS & "fun:text>";
For I = 1 To Len(DS)
CI = (Mid(DS, I, 1))
If Asc(CI) = 39 Then
CO = "\'"
ElseIf Asc(CI) = 92 Then
CO = "\\"
Else
CO = CI
Print #FI, CO;
End If
Next I
Print #FI, "</" & NS & "fun:text>";
Print #FI, "</" & "doc:docname" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "doc:docbody" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Set P = D.Paragraphs.First
Do While Not (P Is Nothing)
Set PN = P.Next
Print #FI, "<" & "doc:par" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Set PS = P.Style
PA = PS.NameLocal
Print #FI, "<" & "doc:style" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & NS & "fun:text>";
For I = 1 To Len(PA)
CI = (Mid(PA, I, 1))
If Asc(CI) = 39 Then
CO = "\'"
ElseIf Asc(CI) = 92 Then
CO = "\\"
Else
CO = CI
Print #FI, CO;
End If
Next I
Print #FI, "</" & NS & "fun:text>";
Print #FI, "</" & "doc:style" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Set R = P.Range
On Error Resume Next
CL = ""
ML = 0
CF = R.Characters.Last
Print #FI, "<" & "doc:parbody" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
For Each C In R.Characters
Set CR = C
Set CS = CR.Style
CT = CR.Text
CC = AscW(CT)
CN = CS.NameLocal
If C = CF And CC = 13 Then
Rem
Else
If CN <> CL Then
If ML Then
Print #FI, "</" & NS & "fun:text>";
ML = 0
End If
If Len(CL) And CL <> PA Then
Print #FI, "</" & "doc:span" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
SP = False
End If
If CN <> PA Then
Print #FI, "<" & "doc:span" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & "doc:style" & ">";
IL = IL + 2
Print #FI, vbLf & Left(IW, IL);
Print #FI, "<" & NS & "fun:text>";
For I = 1 To Len(CN)
CI = (Mid(CN, I, 1))
If Asc(CI) = 39 Then
CO = "\'"
ElseIf Asc(CI) = 92 Then
CO = "\\"
Else
CO = CI
Print #FI, CO;
End If
Next I
Print #FI, "</" & NS & "fun:text>";
Print #FI, "</" & "doc:style" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
SP = True
End If
End If
M = -1
If CC < 32 Or CC > 126 Or CC = 92 Or CC = 39 Then M = 0
If CC = 60 Or CC = 62 Or CC = 38 Then M = 0
If M Then
If Not ML Then
Print #FI, "<" & NS & "fun:text>";
ML = -1
End If
Print #FI, CT;
Else
If Not ML Then
Print #FI, "<" & NS & "fun:text>";
ML = -1
End If
Print #FI, "&#" & CC & ";";
End If
ML = True
CL = CN
End If
Next C
If ML Then
Print #FI, "</" & NS & "fun:text>";
ML = 0
End If
If SP Then ' DBM
Print #FI, "</" & "doc:span" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
SP = False
End If
Print #FI, "</" & "doc:parbody" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "</" & "doc:par" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Set P = PN
Loop
Print #FI, "</" & "doc:docbody" & ">";
IL = IL - 2
If IL < 0 Then Stop
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, vbLf & Left(IW, IL);
Print #FI, "</doc:doc>" & vbLf;
Close FI
End Sub