Option Explicit
' COPYRIGHT DASSAULT SYSTEMES 2004
' ***********************************************************************
' Purpose: Changes hole description
' Assumptions: Looks for CAAPriChangeHole.CATPart in the DocView
' Author:
' Languages: VBScript
' Locales: English
' CATIA Level: V5R13
' ***********************************************************************
Sub CATMain()
Dim oPartDocument As PartDocument
Dim oCATIAFileSys
Dim oFile As File
Dim oTextSteam As TextStream
Dim oUnit As String
Dim oLine As String
Dim oRow As Long
Dim iArray(4, 12) As String
Dim oReturn As String
Dim iMessage As String
Dim iRow As Long
Dim oHole As Hole
Dim iDelimiter As String
Dim iHoleInSelection As Boolean
Dim oParameters As Parameters
Dim i as Long
' -----------------------------------------------------------
' Optional: allows to find the sample wherever it's installed
dim sDocPath As String
sDocPath=CATIA.SystemService.Environ("CATDocView")
If (Not CATIA.FileSystem.FolderExists(sDocPath)) Then
Err.Raise 9999,,"No Doc Path Defined"
End If
' -----------------------------------------------------------
' ------------
' The string as delimiter between input in the text file
' ------------
iDelimiter = "\\"
' ------------
' Get the CATIA file system
' ------------
Set oCATIAFileSys = CATIA.FileSystem
' ------------
' Get the file containing the hole parameters
' ------------
Set oFile = oCATIAFileSys.GetFile(sDocPath & "\online\CAAScdPriUseCases\macros\CAAPriChangeHole.txt")
' ------------
' Get the text stream
' ------------
Set oTextSteam = oFile.OpenAsTextStream("ForReading")
' ------------
' Get the part document
' ------------
Set oPartDocument = CATIA.ActiveDocument
' ------------
' Test the selection content
' ------------
If oPartDocument.Selection.Count = 0 Then
' ------------
' The selection content is empty, the macro ends
' ------------
MsgBox "Please select the holes you wish to transform before running the macro.", vbOKOnly, "Warning"
Else
' ------------
' The selection content is not empty
' Read the text file data unit
' ------------
oLine = oTextSteam.ReadLine
Select Case oLine
Case "Millimeter"
oUnit = 1
Case "Inch"
oUnit = 25.4
End Select
oRow = 0
' ------------
' Read the hole parameters
' ------------
Do While oTextSteam.AtEndOfStream = False
oLine = oTextSteam.ReadLine
For i = 0 To 12
If InStr(oLine, iDelimiter) > 0 Then
iArray(oRow, i) = Left(oLine, InStr(oLine, iDelimiter) - 1)
oLine = Mid(oLine, InStr(oLine, iDelimiter) + 2)
Else
iArray(oRow, i) = oLine
End If
Next
iMessage = iMessage & Chr(10) & iArray(oRow, 0) & " " & iArray(oRow, 1)
oRow = oRow + 1
Loop
oTextSteam.Close
' ------------
' Get the description you wish, by default pre-select the first description
' ------------
iMessage = "Please select the hole decription you wish to apply:" & iMessage
oReturn = InputBox(iMessage, "Hole Description", iArray(1, 0))
If oReturn = "" Then
' ------------
' No selection, the macro ends
' ------------
Exit Sub
Else
Select Case oReturn
Case "A"
iRow = 1
Case "B"
iRow = 2
Case "C"
iRow = 3
Case "D"
iRow = 4
' ------------
' Invalid selection, the macro ends
' ------------
Case Else
Exit Sub
End Select
' ------------
' Loop on the selection content, we expect to find a hole
' ------------
iHoleInSelection = True
Do While iHoleInSelection = True
iHoleInSelection = CatObjectExistsInSelection(oPartDocument.Selection, "CATIAHole", oHole)
If iHoleInSelection = True Then
' ------------
' There is a hole object in the selection
' ------------
' Get the hole limit
' ------------
Select Case iArray(iRow, 5)
Case "UpToNext"
oHole.BottomLimit.LimitMode = catUpThruNextLimit
' ------------
' Update the part when set the hole limit to "UpToNext"
' ------------
oPartDocument.Part.Update
Case Else
oHole.BottomLimit.LimitMode = catOffsetLimit
oHole.BottomLimit.Dimension.Value = CDbl(iArray(iRow, 5)) * oUnit
End Select
' ------------
' Get the hole diameter and its tolerances
' ------------
oHole.Diameter.Value = CDbl(iArray(iRow, 2))
oHole.Diameter.MaximumTolerance = (CDbl(iArray(iRow, 3)) - CDbl(iArray(iRow, 2))) * oUnit
oHole.Diameter.MinimumTolerance = (CDbl(iArray(iRow, 4)) - CDbl(iArray(iRow, 2))) * oUnit
Set oParameters = oPartDocument.Part.Parameters.SubList(oHole, True)
' ------------
' Set the hole description parameter
' ------------
If ParameterExists("Hole_Description", oParameters) = True Then
oParameters.Item("Hole_Description").ValuateFromString (iArray(iRow, 0))
Else
oParameters.CreateString "Hole_Description", iArray(iRow, 0)
End If
' ------------
' Get the hole type
' ------------
Select Case iArray(iRow, 1)
Case "Simple"
oHole.Type = catSimpleHole
Case "Counterbored"
oHole.Type = catCounterboredHole
oHole.HeadDiameter.Value = CDbl(iArray(iRow, 9)) * oUnit
oHole.HeadDepth.Value = CDbl(iArray(iRow, 12)) * oUnit
oHole.HeadDiameter.MaximumTolerance = (CDbl(iArray(iRow, 10)) - CDbl(iArray(iRow, 9))) * oUnit
oHole.HeadDiameter.MinimumTolerance = (CDbl(iArray(iRow, 11)) - CDbl(iArray(iRow, 9))) * oUnit
End Select
' ------------
' Get the hole thread definition
' ------------
Select Case iArray(iRow, 6)
Case "Yes"
If oHole.Diameter.Value < oHole.ThreadDiameter.Value And oHole.BottomLimit.Dimension.Value > oHole.ThreadDepth.Value Then
' ------------
' Update the part when hole diameter is smaller than tread diameter
' and hole limit is greater than thread depth, before apply new values
' ------------
oPartDocument.Part.Update
End If
oHole.ThreadingMode = catThreadedHoleThreading
oHole.ThreadDiameter.Value = CDbl(iArray(iRow, 7)) * oUnit
oHole.ThreadDepth.Value = CDbl(iArray(iRow, 8)) * oUnit
Case "No"
oHole.ThreadingMode = catSmoothHoleThreading
End Select
' ------------
' Update the part
' ------------
oPartDocument.Part.Update
End If
Loop
End If
End If
End Sub
Private Function CatObjectExistsInSelection(CatSelection As Selection, CatObjectName As String, CatObject As Object) As Boolean
' ------------
' Define wether an specific object exists in the selection or not
' ------------
On Error Resume Next
Set CatObject = CatSelection.FindObject(CatObjectName)
CatObjectExistsInSelection = (Err.Number = 0)
Err.Clear
End Function
Private Function ParameterExists(ItemIndex As String, ItemCollection As Object) As Boolean
' ------------
' Define wether an parameter exists in a collection or not
' ------------
Dim TmpItem As Variant
On Error Resume Next
Set TmpItem = ItemCollection.Item(ItemIndex)
ParameterExists = (Err.Number = 0)
Err.Clear
End Function