- Joined
- Jan 3, 2012
- Messages
- 1
- Reaction score
- 0
Hi all,
********* URGENT ASSISTANCE NEEDED *********
It's been a long long time that I have been struggling to get rid of the save options message window while saving shape's fill in VB6 code.
Actually I am getting the Save Options Window whne trying to save the older versions of Visio files in Visio 2003.
Please see the code below:
Sub StencilFill()
Dim mstObj As Visio.Master, mstObjCopy As Visio.Master
Dim StnObj As Visio.Document
Dim appVisio As Visio.Application
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim curPageIndx As Integer, curShapeIndx As Integer ' Loop variable
Dim lRet As Long
On Error GoTo ErrBlock
' Set the default pathname
PathName = txtBrowse.Text & "\" '"C:\VisioTemp\"
PathFileName = PathName & "*.vsd"
' Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
' Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
'Set appVisio = CreateObject("visio.application")
Set appVisio = New Visio.Application
Do While CurrFileName <> ""
' Open the file
PathFileName = PathName & CurrFileName
Set StnObj = appVisio.Documents.Open(PathFileName)
For curShapeIndx = 1 To StnObj.Masters.Count
Set mstObj = StnObj.Masters(curShapeIndx)
Set mstObjCopy = mstObj.Open
Set shpsObj = mstObjCopy.Shapes
Set shpObj = shpsObj(1)
If InStr(mstObj.Name, "Joint") = 0 Then
' Find the top shape
ShapesCnt = shpsObj.Count
Dim vsdShape As Visio.Shape
Dim i1, j As Integer
For i1 = 1 To ShapesCnt
Set vsdShape = shpsObj.Item(i1)
If vsdShape.Shapes.Count > 0 Then
' Loop through all the shapes on the page to find their locations
For j = 1 To vsdShape.Shapes.Count
vsdShape.Shapes(j).Cells("FillPattern") = 0
Next j
Else
vsdShape.Cells("FillPattern") = 0
End If
Next i1
End If
mstObjCopy.Close
Next curShapeIndx
StnObj.Application.AlertResponse = 6
StnObj.Save
StnObj.Close
Set StnObj = Nothing
CurrFileName = Dir
Loop
appVisio.Quit
ErrBlock:
MsgBox Err.Description
MsgBox "The following error occured: " & vbNewLine & "Error # " & Err.Number & vbNewLine & Err.Description, vbCritical, "Open Error"
End Sub
********* URGENT ASSISTANCE NEEDED *********
It's been a long long time that I have been struggling to get rid of the save options message window while saving shape's fill in VB6 code.
Actually I am getting the Save Options Window whne trying to save the older versions of Visio files in Visio 2003.
Please see the code below:
Sub StencilFill()
Dim mstObj As Visio.Master, mstObjCopy As Visio.Master
Dim StnObj As Visio.Document
Dim appVisio As Visio.Application
Dim shpsObj As Visio.Shapes, shpObj As Visio.Shape
Dim PathFileName As String, PathName As String, CurrFileName As String
Dim curPageIndx As Integer, curShapeIndx As Integer ' Loop variable
Dim lRet As Long
On Error GoTo ErrBlock
' Set the default pathname
PathName = txtBrowse.Text & "\" '"C:\VisioTemp\"
PathFileName = PathName & "*.vsd"
' Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
' Find the first file from the directory (not necessarily the first alphabetically)
CurrFileName = Dir(PathFileName)
'Set appVisio = CreateObject("visio.application")
Set appVisio = New Visio.Application
Do While CurrFileName <> ""
' Open the file
PathFileName = PathName & CurrFileName
Set StnObj = appVisio.Documents.Open(PathFileName)
For curShapeIndx = 1 To StnObj.Masters.Count
Set mstObj = StnObj.Masters(curShapeIndx)
Set mstObjCopy = mstObj.Open
Set shpsObj = mstObjCopy.Shapes
Set shpObj = shpsObj(1)
If InStr(mstObj.Name, "Joint") = 0 Then
' Find the top shape
ShapesCnt = shpsObj.Count
Dim vsdShape As Visio.Shape
Dim i1, j As Integer
For i1 = 1 To ShapesCnt
Set vsdShape = shpsObj.Item(i1)
If vsdShape.Shapes.Count > 0 Then
' Loop through all the shapes on the page to find their locations
For j = 1 To vsdShape.Shapes.Count
vsdShape.Shapes(j).Cells("FillPattern") = 0
Next j
Else
vsdShape.Cells("FillPattern") = 0
End If
Next i1
End If
mstObjCopy.Close
Next curShapeIndx
StnObj.Application.AlertResponse = 6
StnObj.Save
StnObj.Close
Set StnObj = Nothing
CurrFileName = Dir
Loop
appVisio.Quit
ErrBlock:
MsgBox Err.Description
MsgBox "The following error occured: " & vbNewLine & "Error # " & Err.Number & vbNewLine & Err.Description, vbCritical, "Open Error"
End Sub