Y
YOUNGHEE
I can change Master's custom property buy using Master.Open method.
But When I open document next time, Master's change is not saved.
So I add doc.save method. But it raised error.
I see the below message in the help file.
Message : Until a document has been saved, the Save method generates an
error.
How can I save Stencil file?
Please Help me.....
Private Sub ProcessCustomPropertySet()
Dim docsObj As Visio.Documents
Dim docObj As Visio.Document
Dim mstObj As Visio.Master
Dim mstObjCopy As Visio.Master
Dim shpObj As Visio.Shape
Dim cellObj As Visio.Cell
' On Error Resume Next
If (MsgBox("All of Master's Custom Property will be changed. " + vbCr +
Do you continue?", vbCritical + vbOKCancel, _
"Apply Custom Property Set") = vbOK) Then
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rsProperty As New ADODB.Recordset
Dim strConn As String
Dim i As Integer
Dim rownum As Integer
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=C:\visio\VisioDBHandle\visio_automation.mdb;Persist Security
Info=False"
con.ConnectionString = strConn
con.Open
Set docsObj = vsoapp.Documents
For Each docObj In docsObj
If InStr(1, UCase(docObj.Name), ".VSS", vbTextCompare) > 0 Then
rs.Open "SELECT CTABLE_NAME FROM STENCIL WHERE STENCIL_NAME
= '" + docObj.Name + "'", con
If Not rs.EOF Then
rsProperty.Open "SELECT * FROM " + rs(0), con
For Each mstObj In docObj.Masters
Set mstObjCopy = mstObj.Open
Set shpObj = mstObjCopy.Shapes(1)
shpObj.DeleteSection visSectionProp
rsProperty.MoveFirst
While Not rsProperty.EOF
shpObj.AddSection visSectionProp
rownum = shpObj.AddRow(visSectionProp,
visRowLast, 0)
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsValue)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Value")), """""", """" +
rsProperty.Fields("Value") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsPrompt)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Prompt")), """""", """" +
rsProperty.Fields("Prompt") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsLabel)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Label")), """""", """" +
rsProperty.Fields("Label") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsFormat)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Format")), """""", """" +
rsProperty.Fields("Format") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsSortKey)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Sortkey")), """""", """" +
rsProperty.Fields("Sortkey") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsType)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Type")), 0, rsProperty.Fields("Type"))
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsInvis)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Invisible")), 0,
rsProperty.Fields("Invisible"))
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsAsk)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Ask")), 0, rsProperty.Fields("Ask"))
rsProperty.MoveNext
Wend
mstObjCopy.Close
Next
rsProperty.Close
End If
rs.Close
'docObj.Save
End If
Next
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub
But When I open document next time, Master's change is not saved.
So I add doc.save method. But it raised error.
I see the below message in the help file.
Message : Until a document has been saved, the Save method generates an
error.
How can I save Stencil file?
Please Help me.....
Private Sub ProcessCustomPropertySet()
Dim docsObj As Visio.Documents
Dim docObj As Visio.Document
Dim mstObj As Visio.Master
Dim mstObjCopy As Visio.Master
Dim shpObj As Visio.Shape
Dim cellObj As Visio.Cell
' On Error Resume Next
If (MsgBox("All of Master's Custom Property will be changed. " + vbCr +
Do you continue?", vbCritical + vbOKCancel, _
"Apply Custom Property Set") = vbOK) Then
Dim con As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim rsProperty As New ADODB.Recordset
Dim strConn As String
Dim i As Integer
Dim rownum As Integer
strConn = "Provider=Microsoft.Jet.OLEDB.4.0;Data
Source=C:\visio\VisioDBHandle\visio_automation.mdb;Persist Security
Info=False"
con.ConnectionString = strConn
con.Open
Set docsObj = vsoapp.Documents
For Each docObj In docsObj
If InStr(1, UCase(docObj.Name), ".VSS", vbTextCompare) > 0 Then
rs.Open "SELECT CTABLE_NAME FROM STENCIL WHERE STENCIL_NAME
= '" + docObj.Name + "'", con
If Not rs.EOF Then
rsProperty.Open "SELECT * FROM " + rs(0), con
For Each mstObj In docObj.Masters
Set mstObjCopy = mstObj.Open
Set shpObj = mstObjCopy.Shapes(1)
shpObj.DeleteSection visSectionProp
rsProperty.MoveFirst
While Not rsProperty.EOF
shpObj.AddSection visSectionProp
rownum = shpObj.AddRow(visSectionProp,
visRowLast, 0)
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsValue)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Value")), """""", """" +
rsProperty.Fields("Value") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsPrompt)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Prompt")), """""", """" +
rsProperty.Fields("Prompt") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsLabel)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Label")), """""", """" +
rsProperty.Fields("Label") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsFormat)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Format")), """""", """" +
rsProperty.Fields("Format") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsSortKey)
cellObj.Formula =
IIf(IsNull(rsProperty.Fields("Sortkey")), """""", """" +
rsProperty.Fields("Sortkey") + """")
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsType)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Type")), 0, rsProperty.Fields("Type"))
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsInvis)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Invisible")), 0,
rsProperty.Fields("Invisible"))
Set cellObj = shpObj.CellsSRC(visSectionProp,
rownum, visCustPropsAsk)
cellObj.ResultIU =
IIf(IsNull(rsProperty.Fields("Ask")), 0, rsProperty.Fields("Ask"))
rsProperty.MoveNext
Wend
mstObjCopy.Close
Next
rsProperty.Close
End If
rs.Close
'docObj.Save
End If
Next
End If
Exit Sub
errHandler:
MsgBox Err.Description
End Sub