Changing & refreshing shapes' custom properties from SQL Server

[StevenS]

Hi all,

I have a series of Visio 2003 diagrams with customized shapes which are
linked to a table in SQL Server, based on 4 fields. The charts are
published to HTML for our larger audience to use as a resource. This
functionality all works fine. Great actually.

However, as part of our process, 1 of those fields needs to change from
'STAGE1' to 'STAGE2' (as shown below), and I need to re-publish the
charts to HTML.

I have an MS-Access-based process ... that's NOT the issue ;-) ...
which I use to trigger, among other things, the code shown below. To
summarize, the code opens each Visio diagram found in a specified
folder, and processes each shape on each page. The process involves
locating shapes to be updated, update the value, and at the end of
processing each document, runs the Database Refresh add-on (which seems
to happen (too) fast.) .

The problem is that the code is failing at the point where I'm trying
to .Close the Visio diagram with the error message:

"This operation cannot be performed while doing in-place editing.". If
I remove the .Close method, the chart doesn't show any change.

Can someone please tell me what I'm doing wrong ?

Thanks,
Steven.


Private Sub cmdUpdateToProd_Click()

Dim myDB As Database
Dim myRS As Recordset

Dim myVisio As VisOcx.DrawingControl
Dim myVisioDocument As Visio.Document
Dim myVisioAppln As Visio.Application

Dim myVisioPages As Visio.Pages
Dim myVisioPage As Visio.Page

Dim myVisioShapes As Visio.Shapes
Dim myVisioShape As Visio.Shape

Dim myVisioShapeCell As Visio.Cell

' Dim myVisioMasters As Visio.Masters
' Dim myVisioMaster As Visio.Master

Dim sVisioFile As String
Dim sShapeName As String
Dim sShapeNum As String
Dim sShapeType As String
Dim sShapeText As String
Dim sPrompts(3) As String
Dim sChar As String

Dim iPromptIndex As Integer
Dim lPos As Long
Dim lLen As Long
Dim bNumStarted As Boolean
Dim bChartUpdated As Boolean

Screen.MousePointer = 11
bChartUpdated = False

PageNumber.SetFocus
cmdUpdateToProd.Enabled = False
cmdIntranet.Enabled = False

' Lookup Visio file name in table to see if it is new or not.
Set myDB = CurrentDb
Set myRS = myDB.OpenRecordset("select Filename, FileStatus,
OtherColumns from dbo_table"), dbOpenDynaset, dbSeeChanges,
dbPessimistic)

myRS.OpenRecordset

Do While Not myRS.EOF
' Open the Visio diagram and locate each use of a prompt.
sVisioFile = myRS!Filename
sVisioFile = "\\ServerAndPathName\Visio Call Flows\" &
sVisioFile & ".vsd"

Set myVisio = New VisOcx.DrawingControl
myVisio.Src = sVisioFile

Set myVisioDocument = myVisio.Document
Set myVisioAppln = myVisioDocument.Application

'Iterate through all pages in a drawing.
Set myVisioPages = myVisioDocument.Pages
For Each myVisioPage In myVisioPages

' Iterate through all shapes in the page.
Set myVisioShapes = myVisioPage.Shapes
For Each myVisioShape In myVisioShapes

' Extract portions of the shape's name for later
processing.
sShapeName = myVisioShape.Name
lPos = InStr(sShapeName, ".")
If lPos > 0 Then
sShapeNum = Mid(sShapeName, lPos + 1)
sShapeName = Left(sShapeName, lPos - 1)
Else
sShapeNum = ""
End If
sShapeType = Left(sShapeName, 4)

' Support for charts not yet using new PromptsDB-Play
object ...
' Unfortunately, this will NOT support the generic menu
shapes, nor
' play shapes which don't have 5 contiguous digits.
sShapeText = myVisioShape.Text
If Left(sShapeText, 4) = "PLAY" Then
sShapeType = "Play"
End If

If sShapeType = "Play" Or sShapeType = "Menu" Then
' At this point, we have a shape whose database
link needs to be updated.
If myVisioShape.CellExists("Prop.Status", True)
Then
Set myVisioShapeCell =
myVisioShape.Cells("Prop.Status")
sChar = myVisioShapeCell.Formula
sChar = Mid(sChar, 2, Len(sChar) - 2) '
original value COMES WITH leading & trailing quotes (!)
If sChar = "STAGE1" Then
' Need to change custom Prop.Status to
'Production'
myVisioShapeCell.Formula = Chr(34) &
"STAGE2" & Chr(34)
bChartUpdated = True
End If
Set myVisioShapeCell = Nothing
End If
End If

Next 'myVisioShape
Set myVisioShapes = Nothing
Next 'myVisioPage

myRS.Edit
If bChartUpdated Then
myVisioAppln.Addons("Database Refresh").Run ("")
myVisioDocument.Save
myVisioDocument.Close ' Code fails here.
myRS!FileStatus = "Prototype prompts updated to
production."
Else
myRS!FileStatus = "No Prototype prompts to update."
End If
myRS.Update
Me.Refresh
Me.Repaint

Set myVisioPages = Nothing
Set myVisioAppln = Nothing
Set myVisioDocument = Nothing

myRS.MoveNext
Loop

myRS.Close

Set myRS = Nothing
Set myDB = Nothing

Screen.MousePointer = 0

End Sub