SaveAsWebPage Code Fix

S

Steve Lin

I have been coming to these groups for several years now trying to find
a solution to the Save As Web Page problem of having mouse-overs and
hyperlinks were together on the same shape and diagram. So I finally
got a chance recently to write some VBA code to fix that problem. Here
it is. Hopefully it will help others.

'Written by Steve Lin, Cognizant Design,
'[email protected]
Public Sub VisioUpdate()

Call WriteScreenTips
Call UpdateFramesetJS
Call UpdateHTM

End Sub
Public Sub WriteScreenTips()

Dim pags As Visio.Pages
Dim pag As Visio.Page
Dim shp As Visio.Shape
Dim sText As String

' Set up Constants
Const ForWriting = 2 ' Input OutPut mode
Const Create = True

Dim MyFile
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject

'On Error Resume Next

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files\ScreenTips.xml"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFile, ForWriting, Create)

Set pags = Visio.ActiveDocument.Pages

TSO.Writeline "<?xml version=""1.0"" encoding=""utf-8""?>"
TSO.Writeline "<VisioDocument>"
TSO.Writeline "<Pages>"


For Each pag In pags

TSO.Writeline "<Page ID=""" & pag.ID & """ >"
TSO.Writeline "<Shapes>"
For Each shp In pag.Shapes
sText = shp.Cells("Comment").ResultStr("")
If sText > "" Then
sText = "<Shape ID=" & Chr(34) & shp.ID & Chr(34) & "
Name=" & Chr(34) & shp.Name & Chr(34) & "><Tip>" & sText &
"</Tip></Shape>"
TSO.Writeline sText
End If
Next shp
TSO.Writeline "</Shapes>"
Next pag
TSO.Writeline "</Page>"
TSO.Writeline "</Pages>"
TSO.Writeline "</VisioDocument>"

TSO.Close
Set TSO = Nothing
Set FSO = Nothing

End Sub

Public Sub UpdateFramesetJS()

Dim sText As String

' Set up Constants
Const ForAppending = 8 ' Input OutPut mode
Const Create = True

Dim MyFile As String
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject

'On Error Resume Next

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files\frameset.js"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFile, ForAppending, Create)

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files/ScreenTips.xml"

TSO.Writeline "var xmlDataScreenTips = XMLData(" & Chr(34) & MyFile &
Chr(34) & ");"
TSO.Writeline "function GetScreenTip (pageID, shapeID)"
TSO.Writeline "{"
TSO.Writeline " var shapeObj = null;"
TSO.Writeline ""
TSO.Writeline " if (xmlDataScreenTips)"
TSO.Writeline " {"
TSO.Writeline " var pagesObj =
xmlDataScreenTips.selectSingleNode(""VisioDocument/Pages"");"
TSO.Writeline " if(!pagesObj)"
TSO.Writeline " {"
TSO.Writeline " return null;"
TSO.Writeline " }"
TSO.Writeline " "
TSO.Writeline " var pageQuerryString = './/Page[@ID = ""' +
pageID + '""]';"
TSO.Writeline " var pageObj =
pagesObj.selectSingleNode(pageQuerryString);"
TSO.Writeline " if(!pageObj)"
TSO.Writeline " {"
TSO.Writeline " return null;"
TSO.Writeline " }"
TSO.Writeline ""
TSO.Writeline " var shapeQuerryString = './/Shape[@ID = ""' +
shapeID + '""]';"
TSO.Writeline " shapeObj =
pageObj.selectSingleNode(shapeQuerryString);"
TSO.Writeline " }"
TSO.Writeline " return shapeObj;"
TSO.Writeline "}"

TSO.Close
Set TSO = Nothing
Set FSO = Nothing

End Sub

Public Sub UpdateHTM()

Dim sText As String

' Set up Constants
Const ForReading = 1 ' Input OutPut mode
Const ForWriting = 2 ' Input OutPut mode
Const Create = True

Dim MyFileHtm As String
Dim MyFileTxt As String
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject
Dim TSOO ' TextStreamObject

'On Error Resume Next

MyFileHtm = Left(Visio.ActiveDocument.Name,
Len(Visio.ActiveDocument.Name) - 4) & ".htm"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFileHtm, ForReading)

MyFileTxt = Left(MyFileHtm, Len(MyFileHtm) - 4) & ".txt"

Set TSOO = FSO.OpenTextFile(MyFileTxt, ForWriting, Create)

Do While sText <> "function UpdateTooltip (element, pageID, shapeID)"
sText = TSO.Readline
If sText <> "function UpdateTooltip (element, pageID, shapeID)"
Then
TSOO.Writeline sText
End If
Loop

TSOO.Writeline "function UpdateTooltip (element, pageID, shapeID)"
TSOO.Writeline "{"
TSOO.Writeline " if (isUpLevel)"
TSOO.Writeline " {"
TSOO.Writeline " var strHL, strProps;"
TSOO.Writeline ""
TSOO.Writeline " if(frmDrawing.event.type == ""focus"")"
TSOO.Writeline " {"
TSOO.Writeline " strHL = strFocusHLTooltipText;"
TSOO.Writeline " strProps = strFocusPropsTooltipText;"
TSOO.Writeline " }"
TSOO.Writeline " else"
TSOO.Writeline " {"
TSOO.Writeline " strHL = strHLTooltipText;"
TSOO.Writeline " strProps = strPropsTooltipText;"
TSOO.Writeline " }"
TSOO.Writeline ""
TSOO.Writeline " var strTooltip = """";"
TSOO.Writeline " if (element.origTitle)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip = element.origTitle.toString();"
TSOO.Writeline " }"
TSOO.Writeline ""
TSOO.Writeline " var shapeNodeScreenTip = GetScreenTip (pageID,
shapeID);"
TSOO.Writeline " if( shapeNodeScreenTip != null )"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip = shapeNodeScreenTip.text;"
TSOO.Writeline " }"
TSOO.Writeline " "
TSOO.Writeline " var shapeNode = FindShapeXML (pageID,
shapeID);"
TSOO.Writeline "/*"
TSOO.Writeline " if( shapeNode != null )"
TSOO.Writeline " {"
TSOO.Writeline " var propColl = shapeNode.selectNodes
(""Prop"");"
TSOO.Writeline " if (propColl != null && propColl.length >
0)"
TSOO.Writeline " {"
TSOO.Writeline " if (strTooltip.length > 0)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip += ""\n"";"
TSOO.Writeline " }"
TSOO.Writeline " strTooltip += propColl(0).text;
//strProps; s/b for each prop get text"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline " "
TSOO.Writeline " var hlObj = GetHLAction (shapeNode, pageID,
shapeID);"
TSOO.Writeline " if (hlObj != null && (hlObj.DoFunction.length >
0 || hlObj.Hyperlink.length > 0))"
TSOO.Writeline " {"
TSOO.Writeline " if (strTooltip.length > 0)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip += ""\n"";"
TSOO.Writeline " }"
TSOO.Writeline " if HLObj.Desc != ""undefined"" {"
TSOO.Writeline " strTooltip += HLObj.Desc; // strHL;
This fix from microsoft visio forum"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline "*/"
TSOO.Writeline " element.title = strTooltip;"
TSOO.Writeline " if (element.alt != null)"
TSOO.Writeline " {"
TSOO.Writeline " element.alt = strTooltip;"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline "}"
TSOO.Writeline ""

Do While sText <> "function GetHLAction (shapeNode, pageID, shapeID)"
sText = TSO.Readline
Loop
TSOO.Writeline sText

Do While Not TSO.AtEndOfStream()
sText = TSO.Readline
TSOO.Writeline sText
Loop

TSO.Close
Set TSO = Nothing

FSO.DeleteFile MyFileHtm
FSO.CopyFile MyFileTxt, MyFileHtm, True
'FSO.DeleteFile MyFileTxt

Set FSO = Nothing

End Sub
 
D

David Parker [Visio MVP]

Thank you Steve - I got it to work after sorting out the CRLFs from
Cut'n'Paste
I suggest that the 3 called functions are changed to Private...

Steve Lin said:
I have been coming to these groups for several years now trying to find
a solution to the Save As Web Page problem of having mouse-overs and
hyperlinks were together on the same shape and diagram. So I finally
got a chance recently to write some VBA code to fix that problem. Here
it is. Hopefully it will help others.

'Written by Steve Lin, Cognizant Design,
'[email protected]
Public Sub VisioUpdate()

Call WriteScreenTips
Call UpdateFramesetJS
Call UpdateHTM

End Sub
Public Sub WriteScreenTips()

Dim pags As Visio.Pages
Dim pag As Visio.Page
Dim shp As Visio.Shape
Dim sText As String

' Set up Constants
Const ForWriting = 2 ' Input OutPut mode
Const Create = True

Dim MyFile
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject

'On Error Resume Next

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files\ScreenTips.xml"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFile, ForWriting, Create)

Set pags = Visio.ActiveDocument.Pages

TSO.Writeline "<?xml version=""1.0"" encoding=""utf-8""?>"
TSO.Writeline "<VisioDocument>"
TSO.Writeline "<Pages>"


For Each pag In pags

TSO.Writeline "<Page ID=""" & pag.ID & """ >"
TSO.Writeline "<Shapes>"
For Each shp In pag.Shapes
sText = shp.Cells("Comment").ResultStr("")
If sText > "" Then
sText = "<Shape ID=" & Chr(34) & shp.ID & Chr(34) & "
Name=" & Chr(34) & shp.Name & Chr(34) & "><Tip>" & sText &
"</Tip></Shape>"
TSO.Writeline sText
End If
Next shp
TSO.Writeline "</Shapes>"
Next pag
TSO.Writeline "</Page>"
TSO.Writeline "</Pages>"
TSO.Writeline "</VisioDocument>"

TSO.Close
Set TSO = Nothing
Set FSO = Nothing

End Sub

Public Sub UpdateFramesetJS()

Dim sText As String

' Set up Constants
Const ForAppending = 8 ' Input OutPut mode
Const Create = True

Dim MyFile As String
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject

'On Error Resume Next

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files\frameset.js"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFile, ForAppending, Create)

MyFile = Left(Visio.ActiveDocument.Name, Len(Visio.ActiveDocument.Name)
- 4) & "_files/ScreenTips.xml"

TSO.Writeline "var xmlDataScreenTips = XMLData(" & Chr(34) & MyFile &
Chr(34) & ");"
TSO.Writeline "function GetScreenTip (pageID, shapeID)"
TSO.Writeline "{"
TSO.Writeline " var shapeObj = null;"
TSO.Writeline ""
TSO.Writeline " if (xmlDataScreenTips)"
TSO.Writeline " {"
TSO.Writeline " var pagesObj =
xmlDataScreenTips.selectSingleNode(""VisioDocument/Pages"");"
TSO.Writeline " if(!pagesObj)"
TSO.Writeline " {"
TSO.Writeline " return null;"
TSO.Writeline " }"
TSO.Writeline " "
TSO.Writeline " var pageQuerryString = './/Page[@ID = ""' +
pageID + '""]';"
TSO.Writeline " var pageObj =
pagesObj.selectSingleNode(pageQuerryString);"
TSO.Writeline " if(!pageObj)"
TSO.Writeline " {"
TSO.Writeline " return null;"
TSO.Writeline " }"
TSO.Writeline ""
TSO.Writeline " var shapeQuerryString = './/Shape[@ID = ""' +
shapeID + '""]';"
TSO.Writeline " shapeObj =
pageObj.selectSingleNode(shapeQuerryString);"
TSO.Writeline " }"
TSO.Writeline " return shapeObj;"
TSO.Writeline "}"

TSO.Close
Set TSO = Nothing
Set FSO = Nothing

End Sub

Public Sub UpdateHTM()

Dim sText As String

' Set up Constants
Const ForReading = 1 ' Input OutPut mode
Const ForWriting = 2 ' Input OutPut mode
Const Create = True

Dim MyFileHtm As String
Dim MyFileTxt As String
Dim FSO ' FileSystemObject
Dim TSO ' TextStreamObject
Dim TSOO ' TextStreamObject

'On Error Resume Next

MyFileHtm = Left(Visio.ActiveDocument.Name,
Len(Visio.ActiveDocument.Name) - 4) & ".htm"

Set FSO = CreateObject("Scripting.FileSystemObject")
Set TSO = FSO.OpenTextFile(MyFileHtm, ForReading)

MyFileTxt = Left(MyFileHtm, Len(MyFileHtm) - 4) & ".txt"

Set TSOO = FSO.OpenTextFile(MyFileTxt, ForWriting, Create)

Do While sText <> "function UpdateTooltip (element, pageID, shapeID)"
sText = TSO.Readline
If sText <> "function UpdateTooltip (element, pageID, shapeID)"
Then
TSOO.Writeline sText
End If
Loop

TSOO.Writeline "function UpdateTooltip (element, pageID, shapeID)"
TSOO.Writeline "{"
TSOO.Writeline " if (isUpLevel)"
TSOO.Writeline " {"
TSOO.Writeline " var strHL, strProps;"
TSOO.Writeline ""
TSOO.Writeline " if(frmDrawing.event.type == ""focus"")"
TSOO.Writeline " {"
TSOO.Writeline " strHL = strFocusHLTooltipText;"
TSOO.Writeline " strProps = strFocusPropsTooltipText;"
TSOO.Writeline " }"
TSOO.Writeline " else"
TSOO.Writeline " {"
TSOO.Writeline " strHL = strHLTooltipText;"
TSOO.Writeline " strProps = strPropsTooltipText;"
TSOO.Writeline " }"
TSOO.Writeline ""
TSOO.Writeline " var strTooltip = """";"
TSOO.Writeline " if (element.origTitle)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip = element.origTitle.toString();"
TSOO.Writeline " }"
TSOO.Writeline ""
TSOO.Writeline " var shapeNodeScreenTip = GetScreenTip (pageID,
shapeID);"
TSOO.Writeline " if( shapeNodeScreenTip != null )"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip = shapeNodeScreenTip.text;"
TSOO.Writeline " }"
TSOO.Writeline " "
TSOO.Writeline " var shapeNode = FindShapeXML (pageID,
shapeID);"
TSOO.Writeline "/*"
TSOO.Writeline " if( shapeNode != null )"
TSOO.Writeline " {"
TSOO.Writeline " var propColl = shapeNode.selectNodes
(""Prop"");"
TSOO.Writeline " if (propColl != null && propColl.length >
0)"
TSOO.Writeline " {"
TSOO.Writeline " if (strTooltip.length > 0)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip += ""\n"";"
TSOO.Writeline " }"
TSOO.Writeline " strTooltip += propColl(0).text;
//strProps; s/b for each prop get text"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline " "
TSOO.Writeline " var hlObj = GetHLAction (shapeNode, pageID,
shapeID);"
TSOO.Writeline " if (hlObj != null && (hlObj.DoFunction.length >
0 || hlObj.Hyperlink.length > 0))"
TSOO.Writeline " {"
TSOO.Writeline " if (strTooltip.length > 0)"
TSOO.Writeline " {"
TSOO.Writeline " strTooltip += ""\n"";"
TSOO.Writeline " }"
TSOO.Writeline " if HLObj.Desc != ""undefined"" {"
TSOO.Writeline " strTooltip += HLObj.Desc; // strHL;
This fix from microsoft visio forum"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline "*/"
TSOO.Writeline " element.title = strTooltip;"
TSOO.Writeline " if (element.alt != null)"
TSOO.Writeline " {"
TSOO.Writeline " element.alt = strTooltip;"
TSOO.Writeline " }"
TSOO.Writeline " }"
TSOO.Writeline "}"
TSOO.Writeline ""

Do While sText <> "function GetHLAction (shapeNode, pageID, shapeID)"
sText = TSO.Readline
Loop
TSOO.Writeline sText

Do While Not TSO.AtEndOfStream()
sText = TSO.Readline
TSOO.Writeline sText
Loop

TSO.Close
Set TSO = Nothing

FSO.DeleteFile MyFileHtm
FSO.CopyFile MyFileTxt, MyFileHtm, True
'FSO.DeleteFile MyFileTxt

Set FSO = Nothing

End Sub
Click to expand...
 
Top