thdltools/VBAProjects
1
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

This revision is from 06-14-04. All changes primarily to the NewMacros code.

Browse source
This commit is contained in:
thangarson 2004-08-11 21:26:28 +00:00
parent 2b2899bac0
commit 78c43d8211
3 changed files with 47 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
WordToXML/ItalicOptions.frm
View file

@ -5,7 +5,7 @@ Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} ItalicOptions
ClientLeft = 30 ClientLeft = 30
ClientTop = 480 ClientTop = 480
ClientWidth = 7125 ClientWidth = 7125
OleObjectBlob = "ItalicOptions061104.frx":0000 OleObjectBlob = "ItalicOptions061404.frx":0000
StartUpPosition = 1 'CenterOwner StartUpPosition = 1 'CenterOwner
End End
Attribute VB_Name = "ItalicOptions" Attribute VB_Name = "ItalicOptions"

BIN
WordToXML/ItalicOptions.frx
View file

Binary file not shown.

53
WordToXML/NewMacros.bas
View file

@ -111,7 +111,37 @@ Attribute convert.VB_ProcData.VB_Invoke_Func = "Project.NewMacros.Macro1"
For n = 0 To c For n = 0 To c
Selection.TypeText Text:=outDoc(n) Selection.TypeText Text:=outDoc(n)
Next n Next n
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "&"
.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
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "&"
.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
MsgBox ("Conversion Done! Paste contents of new document into XML editor.")
End Sub End Sub
Sub doHeaders() Sub doHeaders()
@ -415,9 +445,10 @@ Function iterateRange(ByVal rng)
ElseIf char1.Style = "Hyperlink,hl" Then ElseIf char1.Style = "Hyperlink,hl" Then
textToDis = char1.Hyperlinks(1).TextToDisplay textToDis = char1.Hyperlinks(1).TextToDisplay
outStr = Left(outStr, Len(outStr) - (14 + Len(textToDis))) leftPt = InStr(outStr, " HYPERLINK") - 1
outStr = outStr & "<a href=""" & char1.Hyperlinks(1).Address & """>" _ outStr = Left(outStr, leftPt)
& textToDis & "</a>" outStr = outStr & "<xref n=""" & char1.Hyperlinks(1).Address & """>" _
& textToDis & "</xref>"
n = n + Len(textToDis) n = n + Len(textToDis)
Else: Else:
@ -439,6 +470,13 @@ Function iterateRange(ByVal rng)
Application.StatusBar = statusStr Application.StatusBar = statusStr
End If End If
Next n Next n
If InStr(outStr, "HYPERLINK") Then
sInd = InStr(outStr, " HYPERLINK")
hind = InStr(outStr, "http")
eInd = InStr(hind, outStr, """")
linkURL = Mid(outStr, hind, eInd - hind)
outStr = "<xref n=""" & linkURL & """>" & Mid(outStr, (eInd + 2)) & "</xref>"
End If
iterateRange = outStr & closeTag iterateRange = outStr & closeTag
End Function End Function
Function iterateNote(ByVal rng As Range) Function iterateNote(ByVal rng As Range)
@ -463,9 +501,10 @@ Function iterateNote(ByVal rng As Range)
ElseIf char1.Style = "Hyperlink,hl" Then ElseIf char1.Style = "Hyperlink,hl" Then
textToDis = char1.Hyperlinks(1).TextToDisplay textToDis = char1.Hyperlinks(1).TextToDisplay
outStr = Left(outStr, Len(outStr) - 1) leftPt = InStr(outStr, " HYPERLINK") - 1
outStr = outStr & "<a href=""" & char1.Hyperlinks(1).Address & """>" _ outStr = Left(outStr, leftPt)
& textToDis & "</a>" outStr = outStr & "<xref n=""" & char1.Hyperlinks(1).Address & """>" _
& textToDis & "</xref>"
ct = ct + Len(textToDis) - 2 ct = ct + Len(textToDis) - 2
Else: Else: