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,
'(e-mail address removed)
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,
'(e-mail address removed)
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...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

Excel and Shift-JIS 5
It's working by hand, but not in Access VBA code 0
VBA Coding 3
Bookmark Macro throwing errors 1
Attachment Array? 5
Using Array for Attachments? 1
Excel won't open CSV file 0
VB how to connect two sub's 2

Top