'COPYRIGHT DASSAULT SYSTEMES 2001 ' **************************************************************************** ' Purpose: Cadre & Cartouche adaptés aux besoins des projets de l'Ecole Centrale Paris ' ' Assumptions: Une mise en plan doit être active en session ' ' Author: GDG\DU + P. Morenton ' ' Revision: 1.0 du 21-12-2003 ' ' Languages: VBScript ' Version: V5R7 ' Reg. Settings: English (United States) ' **************************************************************************** Public DrwDocument As DrawingDocument Public DrwSheets As DrawingSheets Public DrwSheet As DrawingSheet Public DrwView As DrawingView Public DrwTexts As DrawingTexts Public Text As DrawingText Public Fact As Factory2D Public Point As Point2D Public Line As Line2D Public Cicle As Circle2D Public Selection As Selection Public GeomElems As GeometricElements Public Height As Double 'Sheet height Public Width As Double 'Sheet width Public Offset As Double 'Distance between the sheet edges and the frame borders Public OH As Double 'Horizontal origin for drawing the titleblock Public OV As Double 'Vertical origin for drawing the titleblock Public Col(6) As Double 'Columns coordinates Public Row(6) As Double 'Rows coordinates Public colRev(4) As double 'Columns coordinates of revision block Public TranslationX As Double 'Horizontal translation to operate when changing standard Public TranslationY As Double 'Vertical translation to operate when changing standard Public displayFormat As String 'Sheet format according to standard Public sheetFormat As catPaperSize 'Sheet format as integer value public StartTime, EndTime Const mm = 1 Const Inch = 254 Const RulerLength = 200 Const NbOfRevision = 9 Const MacroID = "Drawing_Titleblock_Sample1" Const RevRowHeight = 10 Sub CATMain() CATInit On Error Resume Next name = DrwTexts.GetItem("Reference_" + MacroID).Name If Err.Number <> 0 Then Err.Clear name = "none" End If On Error Goto 0 If (name = "none") Then CATDrw_Creation Else CATDrw_Resizing CATDrw_Update End If End Sub Sub CATDrw_Creation() '------------------------------------------------------------------------------- 'How to create the FTB '------------------------------------------------------------------------------- CATInit 'To init public variables & work in the background view If CATCheckRef(1) Then Exit Sub 'To check whether a FTB exists already in the sheet CATStandard 'To compute standard sizes CATReference 'To place on the drawing a reference point CATFrame 'To draw the frame CATTitleBlock 'To draw the TitleBlock and fill in it End Sub Sub CATDrw_Deletion() '------------------------------------------------------------------------------- 'How to delete the FTB '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATRemoveAll End Sub Sub CATDrw_Resizing() '------------------------------------------------------------------------------- 'How to resize the FTB '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATStandard CATMoveReference If TranslationX <> 0 Or TranslationY <> 0 Then CATRemoveFrame CATMoveTitleBlock CATFrame CATTitleBlockFrame CATTitleBlockStandard CATLinks End If End Sub Sub CATDrw_Update() '------------------------------------------------------------------------------- 'How to update the FTB '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATLinks End Sub Sub CATDrw_CheckedBy() '------------------------------------------------------------------------------- 'How to update a bit more the FTB '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATFillField "TitleBlock_Text_Controller_1", "TitleBlock_Text_CDate_1", "checked" End Sub Sub CATDrw_AddRevisionBlock() '------------------------------------------------------------------------------- 'How to create or modify a revison block '------------------------------------------------------------------------------- Dim X As double Dim Y As double CATInit If CATCheckRef(0) Then Exit Sub revision = CATCheckRev On Error Resume Next DrwTexts.GetItem("TitleBlock_Text_MDate_" + Chr(65 + revision)).Text = Date If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 CATRevPos revision, X, Y CATRevisionBlock revision, X, Y End Sub Sub CATInit() '------------------------------------------------------------------------------- 'How to init the dialog and create main objects '------------------------------------------------------------------------------- Set DrwDocument = CATIA.ActiveDocument Set DrwSheets = DrwDocument.Sheets Set Selection = DrwDocument.Selection Set DrwSheet = DrwSheets.ActiveSheet Set DrwView = DrwSheet.Views.ActiveView Set DrwTexts = DrwView.Texts Set Fact = DrwView.Factory2D Set GeomElems = DrwView.GeometricElements End Sub Sub CATStandard() '------------------------------------------------------------------------------- 'How to compute standard values '------------------------------------------------------------------------------- Height = DrwSheet.GetPaperHeight Width = DrwSheet.GetPaperWidth sheetFormat = DrwSheet.PaperSize Offset = 10.*mm 'Offset default value = 10. If (sheetFormat = CatPaperA0 Or sheetFormat = CatPaperA1 Or sheetFormat = CatPaperUser And _ (DrwSheet.GetPaperWidth > 594.*mm Or DrwSheet.GetPaperHeight > 594.*mm)) Then Offset = 20.*mm End If OH = Width - Offset OV = Offset documentStd = DrwDocument.Standard If (documentStd = catISO) Then If sheetFormat = 13 Then displayFormat = "USER" Else displayFormat = "A" + CStr(sheetFormat - 2) End IF Else Select Case sheetFormat Case 0 displayFormat = "Letter" Case 1 displayFormat = "Legal" Case 7 displayFormat = "A" Case 8 displayFormat = "B" Case 9 displayFormat = "C" Case 10 displayFormat = "D" Case 11 displayFormat = "E" Case 12 displayFormat = "F" Case 13 displayFormat = "J" End Select End If End Sub Sub CATReference() '------------------------------------------------------------------------------- 'How to create a reference text '------------------------------------------------------------------------------- Set Text = DrwTexts.Add("", Width - Offset, Offset) Text.Name = "Reference_" + MacroID End Sub Function CATCheckRef(Mode As Integer) As Integer '------------------------------------------------------------------------------- 'How to check that the called macro is the right one '------------------------------------------------------------------------------- nbTexts = DrwTexts.Count i = 0 notFound = 0 While (notFound = 0 And i refText) Then MsgBox "Frame and Titleblock created using another style:" + Chr(10) + " " + MacroID CATCheckRef = 1 Exit Function End If End If Wend CATCheckRef = 0 End Function Function CATCheckRev() As Integer '------------------------------------------------------------------------------- 'How to check that a revision block alredy exists '------------------------------------------------------------------------------- CATCheckRev = 0 nbTexts = DrwTexts.Count i = 0 While (i 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATFrameCentringMark(Nb_CM_H As Integer, Nb_CM_V As Integer, Ruler As Integer, Cst_1 As Double, Cst_2 As Double) '------------------------------------------------------------------------------- 'How to draw the centring marks '------------------------------------------------------------------------------- On Error Resume Next Set Line = Fact.CreateLine(.5 * Width , Height - Offset, .5 * Width, Height ) Line.Name = "Frame_CentringMark_Top" Set Line = Fact.CreateLine(.5 * Width , OV , .5 * Width, .0 ) Line.Name = "Frame_CentringMark_Bottom" Set Line = Fact.CreateLine(OV , .5 * Height , .0 , .5 * Height) Line.Name = "Frame_CentringMark_Left" Set Line = Fact.CreateLine(Width - Offset, .5 * Height , Width , .5 * Height) Line.Name = "Frame_CentringMark_Right" For i = Nb_CM_H To Ruler/2/Cst_1 Step -1 If (i * Cst_1 < .5 * Width - 1.) Then Set Line = Fact.CreateLine(.5 * Width + i * Cst_1, OV, .5 * Width + i * Cst_1, .25 * Offset) Line.Name = "Frame_CentringMark_Bottom" Set Line = Fact.CreateLine(.5 * Width - i * Cst_1, OV, .5 * Width - i * Cst_1, .25 * Offset) Line.Name = "Frame_CentringMark_Bottom" End If Next For i = 1 To Nb_CM_H If (i * Cst_1 < .5 * Width - 1.) Then Set Line = Fact.CreateLine(.5 * Width + i * Cst_1, Height - Offset, .5 * Width + i * Cst_1, Height - .25 * Offset) Line.Name = "Frame_CentringMark_Top" Set Line = Fact.CreateLine(.5 * Width - i * Cst_1, Height - Offset, .5 * Width - i * Cst_1, Height - .25 * Offset) Line.Name = "Frame_CentringMark_Top" End If Next For i = 1 To Nb_CM_V If (i * Cst_2 < .5 * Height - 1.) Then Set Line = Fact.CreateLine(OV, .5 * Height + i * Cst_2, .25 * Offset , .5 * Height + i * Cst_2) Line.Name = "Frame_CentringMark_Left" Set Line = Fact.CreateLine(OV, .5 * Height - i * Cst_2, .25 * Offset , .5 * Height - i * Cst_2) Line.Name = "Frame_CentringMark_Left" Set Line = Fact.CreateLine(OH, .5 * Height + i * Cst_2, Width - .25 * Offset, .5 * Height + i * Cst_2) Line.Name = "Frame_CentringMark_Right" Set Line = Fact.CreateLine(OH, .5 * Height - i * Cst_2, Width - .25 * Offset, .5 * Height - i * Cst_2) Line.Name = "Frame_CentringMark_Right" End If Next If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATFrameText(Nb_CM_H As Integer, Nb_CM_V As Integer, Ruler As Integer, Cst_1 As Double, Cst_2 As Double) '------------------------------------------------------------------------------- 'How to create coordinates '------------------------------------------------------------------------------- On Error Resume Next For i = Nb_CM_H To (Ruler/2/Cst_1 + 1) Step -1 Set Text = DrwTexts.Add(Chr(65 + Nb_CM_H - i) , .5 * Width + (i - .5) * Cst_1, .5 * Offset) CATFormatFText "Frame_Text_Bottom", 0 Set Text = DrwTexts.Add(Chr(64 + Nb_CM_H + i) , .5 * Width - (i - .5) * Cst_1, .5 * Offset) CATFormatFText "Frame_Text_Bottom", 0 Next For i = 1 To Nb_CM_H Set Text = DrwTexts.Add(Chr(65 + Nb_CM_H - i), .5 * Width + (i - .5) * Cst_1, Height - .5 * Offset) CATFormatFText "Frame_Text_Top", -90 Set Text = DrwTexts.Add(Chr(64 + Nb_CM_H + i), .5 * Width - (i - .5) * Cst_1, Height - .5 * Offset) CATFormatFText "Frame_Text_Top", -90 Next For i = 1 To Nb_CM_V Set Text = DrwTexts.Add(CStr(Nb_CM_V + i) , .5 * Offset , .5 * Height + (i - .5) * Cst_2) CATFormatFText "Frame_Text_Left", -90 Set Text = DrwTexts.Add(CStr(Nb_CM_V - i + 1) , .5 * Offset , .5 * Height - (i - .5) * Cst_2) CATFormatFText "Frame_Text_Left", -90 Set Text = DrwTexts.Add(CStr(Nb_CM_V + i) , Width - .5 * Offset, .5 * Height + (i - .5) * Cst_2) CATFormatFText "Frame_Text_Right", 0 Set Text = DrwTexts.Add(CStr(Nb_CM_V - i + 1), Width - .5 * Offset, .5 * Height - (i - .5) * Cst_2) CATFormatFText "Frame_Text_Right", 0 Next If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATFrameRuler(Ruler As Integer, Cst_1 As Single) '------------------------------------------------------------------------------- 'How to create a ruler '------------------------------------------------------------------------------- 'Frame_Ruler_Guide ----------------------------------------------- 'Frame_Ruler_1cm | | | | | | | | | | | | | | | | | | | | | | | | 'Frame_Ruler_5cm | | | | | On Error Resume Next Set Line = Fact.CreateLine(.5 * Width - Ruler/2 , .75 * Offset, .5 * Width + Ruler/2, .75 * Offset) Line.Name = "Frame_Ruler_Guide" For i = 1 To Ruler/100 Set Line = Fact.CreateLine(.5 * Width - 50 * i, OV, .5 * Width - 50 * i, .5 * Offset ) Line.Name = "Frame_Ruler_5cm" Set Line = Fact.CreateLine(.5 * Width + 50 * i, OV, .5 * Width + 50 * i, .5 * Offset ) Line.Name = "Frame_Ruler_5cm" For j = 1 To 4 Set Line = Fact.CreateLine(.5 * Width - 50 * i + 10 * j, OV, .5 * Width - 50 * i + 10 * j, .75 * Offset) Line.Name = "Frame_Ruler_1cm" Set Line = Fact.CreateLine(.5 * Width + 50 * i - 10 * j, OV, .5 * Width + 50 * i - 10 * j, .75 * Offset) Line.Name = "Frame_Ruler_1cm" Next Next If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATTitleBlock() '------------------------------------------------------------------------------- 'How to create the TitleBlock '------------------------------------------------------------------------------- CATTitleBlockFrame 'To draw the geometry 'CATTitleBlockStandard CATTitleBlockText 'To fill in the title block End Sub Sub CATTitleBlockFrame() '------------------------------------------------------------------------------- 'How to draw the title block geometry '------------------------------------------------------------------------------- Col(1) = -150*mm Col(2) = -100*mm Col(3) = -87.5*mm Col(4) = -65*mm Col(5) = -20*mm Row(1) = + 10*mm Row(2) = + 30*mm Row(3) = + 40*mm Row(4) = + 50*mm On Error Resume Next Set Line = Fact.CreateLine(OH + Col(1), OV , OH , OV ) Line.Name = "TitleBlock_Line_0" Set Line = Fact.CreateLine(OH + Col(1), OV+Row(1) , OH , OV+Row(1)) Line.Name = "TitleBlock_Line_1" Set Line = Fact.CreateLine(OH + Col(1), OV+Row(2) , OH , OV+Row(2)) Line.Name = "TitleBlock_Line_2" Set Line = Fact.CreateLine(OH + Col(1), OV+Row(3) , OH , OV+Row(3)) Line.Name = "TitleBlock_Line_3" Set Line = Fact.CreateLine(OH + Col(1), OV , OH + Col(1), OV+Row(4)) Line.Name = "TitleBlock_Line_4" Set Line = Fact.CreateLine(OH + Col(2), OV +Row(2), OH + Col(2), OV+Row(3)) Line.Name = "TitleBlock_Line_5" Set Line = Fact.CreateLine(OH + Col(3), OV +Row(2), OH + Col(3), OV+Row(3)) Line.Name = "TitleBlock_Line_6" Set Line = Fact.CreateLine(OH + Col(4), OV +Row(2), OH + Col(4), OV+Row(3)) Line.Name = "TitleBlock_Line_7" Set Line = Fact.CreateLine(OH + Col(5), OV +Row(2), OH + Col(5), OV+Row(3)) Line.Name = "TitleBlock_Line_8" Set Line = Fact.CreateLine(OH + Col(1), OV+Row(4) , OH , OV+Row(4)) Line.Name = "TitleBlock_Line_9" If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATTitleBlockStandard() '------------------------------------------------------------------------------- 'How to create the standard representation '------------------------------------------------------------------------------- Dim R1 As Double Dim R2 As Double Dim X(5) As Double Dim Y(7) As Double R1 = 2.*mm R2 = 4.*mm X(1) = OH + Col(2) + 2.*mm X(2) = X(1) + 1.5*mm X(3) = X(1) + 9.5*mm X(4) = X(1) + 15.5*mm X(5) = X(1) + 21.*mm Y(1) = OV + (Row(2)+Row(3))/2. Y(2) = Y(1) + R1 Y(3) = Y(1) + R2 Y(4) = Y(1) + 5.5*mm Y(5) = Y(1) - R1 Y(6) = Y(1) - R2 Y(7) = 2*Y(1) - Y(4) If DrwSheet.ProjectionMethod <> CatFirstAngle Then X(2) = X(1) + X(5) - X(2) X(3) = X(1) + X(5) - X(3) X(4) = X(1) + X(5) - X(4) End If On Error Resume Next Set Line = Fact.CreateLine(X(1), Y(1), X(5), Y(1)) Line.Name = "TitleBlock_Standard_Line_Axis_1" Set Line = Fact.CreateLine(X(4), Y(7), X(4), Y(4)) Line.Name = "TitleBlock_Standard_Line_Axis_2" Set Line = Fact.CreateLine(X(2), Y(5), X(2), Y(2)) Line.Name = "TitleBlock_Standard_Line_1" Set Line = Fact.CreateLine(X(2), Y(2), X(3), Y(3)) Line.Name = "TitleBlock_Standard_Line_2" Set Line = Fact.CreateLine(X(3), Y(3), X(3), Y(6)) Line.Name = "TitleBlock_Standard_Line_3" Set Line = Fact.CreateLine(X(3), Y(6), X(2), Y(5)) Line.Name = "TitleBlock_Standard_Line_4" Set Circle = Fact.CreateClosedCircle(X(4), Y(1), R1) Circle.Name = "TitleBlock_Standard_Circle_1" Set Circle = Fact.CreateClosedCircle(X(4), Y(1), R2) Circle.Name = "TitleBlock_Standard_Circle_2" If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATTitleBlockText() '------------------------------------------------------------------------------- 'How to fill in the title block '------------------------------------------------------------------------------- Text_11 = "Ecole Centrale Paris" Text_14 = "Dessiné par" Text_15 = "Inconnu" Text_08 = "Format" Text_10 = "XXX" ' Paper Format Text_02 = "Echelle" Text_03 = "" Text_13 = "Date" Text_MP_03="01/01/01" Text_MP_01="Revision" Text_MP_02="1.0" Text_MP_04="Titre" Text_MP_05="Projet" Text_MP_06="PROJET" ' Projet Set Text = DrwTexts.Add(Text_MP_05, OH + Col(1) + 1. , OV + Row(4) ) CATFormatTBText "TitleBlock_Text_Projet" , catTopLeft , 1.5 Set Text = DrwTexts.Add(Text_MP_06, OH + .5*(Col(1)), OV+Row(3)) CATFormatTBText "TitleBlock_Text_Projet_1" , catBottomCenter, 5 ' Etablissement Set Text = DrwTexts.Add(Text_11, OH + .5*(Col(1)), OV + .5*(Row(1))) CATFormatTBText "TitleBlock_Text_Company" , catMiddleCenter, 5 ' Dessine par Set Text = DrwTexts.Add(Text_14, OH + Col(1) + 1. , OV + Row(3) ) CATFormatTBText "TitleBlock_Text_Designer" , catTopLeft , 1.5 Set Text = DrwTexts.Add(Text_15, OH + .5*(Col(1)+Col(2)), OV + Row(2)) CATFormatTBText "TitleBlock_Text_Designer_1" , catBottomCenter, 5 ' Format Set Text = DrwTexts.Add(Text_08, OH + Col(2) + 1. , OV + Row(3) ) CATFormatTBText "TitleBlock_Text_Size" , catTopLeft , 1.5 If (sheetFormat = 13) Then Set Text = DrwTexts.Add(Text_09, OH + .5*(Col(2)+Col(3)), OV + Row(2)) Else Set Text = DrwTexts.Add(Text_10, OH + .5*(Col(2)+Col(3)), OV + Row(2)) End If CATFormatTBText "TitleBlock_Text_Size_1" , catBottomCenter, 5 ' Echelle Set Text = DrwTexts.Add(Text_02, OH + Col(3) + 1. , OV + Row(3) ) CATFormatTBText "TitleBlock_Text_Scale" , catTopLeft , 1.5 Set Text = DrwTexts.Add(Text_03, OH+.5*(Col(3)+Col(4)), OV + Row(2) ) Text.InsertVariable 0, 0, DrwDocument.Parameters.Item("Drawing\" + DrwSheet.Name + "\ViewMakeUp.1\Scale") CATFormatTBText "TitleBlock_Text_Scale_1" , catBottomCenter, 5 ' Date Set Text = DrwTexts.Add(Text_13, OH + Col(4) + 1. , OV + Row(3)) CATFormatTBText "TitleBlock_Text_CDate" , catTopLeft , 1.5 Set Text = DrwTexts.Add(Text_MP_03, OH + .5*(Col(4)+Col(5)) , OV + Row(2) ) CATFormatTBText "TitleBlock_Text_CDate_1" , catBottomCenter, 5 'Version Set Text = DrwTexts.Add(Text_MP_01, OH + Col(5) + 1. , OV + Row(3)) CATFormatTBText "TitleBlock_Text_revision" , catTopLeft , 1.5 Set Text = DrwTexts.Add(Text_MP_02, OH + .5*Col(5) , OV + Row(2) ) CATFormatTBText "TitleBlock_Text_revision_1" , catBottomCenter, 5 'Titre Set Text = DrwTexts.Add(Text_MP_04, OH + .5*(Col(1)), OV +.5*( Row(1)+Row(2)) ) CATFormatTBText "TitleBlock_Text_Title" , catMiddleCenter, 7 CATLinks End Sub Sub CATRevisionBlock(rev As Integer, X As double, Y As Double) '------------------------------------------------------------------------------- 'How to create the revision block '------------------------------------------------------------------------------- CATRevisionBlockFrame rev, X, Y 'To draw the geometry CATRevisionBlockText rev, X, Y 'To fill in the title block End Sub Sub CATRevisionBlockFrame(rev As Integer, X As double, Y As double) '------------------------------------------------------------------------------- 'How to draw the revision block geometry '------------------------------------------------------------------------------- colRev(1) = -190*mm colRev(2) = -175*mm colRev(3) = -140*mm colRev(4) = - 20*mm rev = rev + 1 On Error Resume Next Set Line = Fact.CreateLine(X + colRev(1), Y, X + colRev(1), Y - RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_1" Set Line = Fact.CreateLine(X + colRev(2), Y, X + colRev(2), Y - RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_2" Set Line = Fact.CreateLine(X + colRev(3), Y, X + colRev(3), Y - RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_3" Set Line = Fact.CreateLine(X + colRev(4), Y, X + colRev(4), Y - RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_4" Set Line = Fact.CreateLine(X + colRev(1), Y - RevRowHeight, X, Y - RevRowHeight) Line.Name = "RevisionBlock_Line_Row_" + Chr(rev) If (rev = 1) Then Set Line = Fact.CreateLine(X + colRev(1), Y - RevRowHeight, X + colRev(1), Y - 2.*RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_1" Set Line = Fact.CreateLine(X + colRev(2), Y - RevRowHeight, X + colRev(2), Y - 2.*RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_2" Set Line = Fact.CreateLine(X + colRev(3), Y - RevRowHeight, X + colRev(3), Y - 2.*RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_3" Set Line = Fact.CreateLine(X + colRev(4), Y - RevRowHeight, X + colRev(4), Y - 2.*RevRowHeight) Line.Name = "RevisionBlock_Line_Column_" + Chr(rev) + "_4" Set Line = Fact.CreateLine(X + colRev(1), Y - 2.*RevRowHeight, X, Y - 2.*RevRowHeight) Line.Name = "RevisionBlock_Line_Row_" + Chr(rev) End If If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATRevisionBlockText(rev As Integer, X As double, Y As double) '------------------------------------------------------------------------------- 'How to fill in the revision block '------------------------------------------------------------------------------- Init = InputBox("This review has been done by:", "Reviewer's name", "XXX") Description = InputBox("Comment to be inserted:", "Description", "None") If (rev = 1) Then Set Text = DrwTexts.Add("REV" , X + colRev(1) + 1., Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Rev" , catMiddleLeft Set Text = DrwTexts.Add("DATE" , X + colRev(2) + 1., Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Date" , catMiddleLeft Set Text = DrwTexts.Add("DESCRIPTION", X + colRev(3) + 1., Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Description" , catMiddleLeft Set Text = DrwTexts.Add("INIT" , X + colRev(4) + 1., Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Init" , catMiddleLeft Set Text = DrwTexts.Add(Chr(64+rev) , X + .5*(colRev(1)+colRev(2)), Y - 1.5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Rev_A" , catMiddleCenter Set Text = DrwTexts.Add(Date , X + .5*(colRev(2)+colRev(3)), Y - 1.5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Date_A" , catMiddleCenter Set Text = DrwTexts.Add(Description , X + colRev(3) + 1., Y - 1.5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Description_A", catMiddleLeft Text.SetFontSize 0, 0, 2.5 Set Text = DrwTexts.Add(Init , X + .5*colRev(4) , Y - 1.5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Init_A" , catMiddleCenter Else Set Text = DrwTexts.Add(Chr(64+rev) , X + .5*(colRev(1)+colRev(2)), Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Rev_" + Chr(64+rev) , catMiddleCenter Set Text = DrwTexts.Add(Date , X + .5*(colRev(2)+colRev(3)), Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Date_" + Chr(64+rev) , catMiddleCenter Set Text = DrwTexts.Add(Description , X + colRev(3) + 1., Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Description_" + Chr(64+rev), catMiddleLeft Text.SetFontSize 0, 0, 2.5 Set Text = DrwTexts.Add(Init , X + .5*colRev(4) , Y - .5*RevRowHeight) CATFormatRBText "RevisionBlock_Text_Init_" + Chr(64+rev) , catMiddleCenter End If End Sub Sub CATMoveReference() '------------------------------------------------------------------------------- 'How to get the reference text '------------------------------------------------------------------------------- On Error Resume Next Set Text = DrwTexts.GetItem("Reference_" + MacroID) If Err.Number <> 0 Then Err.Clear TranslationX = .0 TranslationY = .0 Exit Sub End If On Error Goto 0 TranslationX = Width - Offset - Text.x TranslationY = Offset - Text.y Text.x = Text.x + TranslationX Text.y = Text.y + TranslationY End Sub Sub CATRemoveAll() '------------------------------------------------------------------------------- 'How to remove all the dress-up elements of the active view '------------------------------------------------------------------------------- Dim NbTexts As Integer NbTexts = DrwTexts.Count For j = 1 To NbTexts DrwTexts.Remove(1) Next CATRemoveGeometry() End Sub Sub CATRemoveGeometry() '------------------------------------------------------------------------------- 'How to remove all geometric elements of the active view '------------------------------------------------------------------------------- On Error Resume Next selection.Add(DrwView) selection.Search "Drafting.Geometry,sel" If Err.Number <> 0 Then Err.Clear Selection.Clear iNbOfGeomElems = GeomElems.Count ii = 1 While (ii <= iNbOfGeomElems) Set GeomElem = GeomElems.Item(ii) Selection.Add(GeomElem) ii = ii + 1 Wend End If Selection.Delete On Error Goto 0 End Sub Sub CATRemoveFrame() '------------------------------------------------------------------------------- 'How to remove the whole frame '------------------------------------------------------------------------------- On Error Resume Next selection.Add(DrwView) Selection.Search("Drafting.Text.Name ='Frame_Text_'*, Drawing") If Err.Number = 0 Then Selection.Delete Else Err.Clear iNbOfTexts = DrwTexts.Count ii = iNbOfTexts While (ii > 0) Set Text = DrwTexts.Item(ii) if (Left(Text.Name, 11) = "Frame_Text_") Then DrwTexts.Remove(ii) End If ii = ii - 1 Wend End If Selection.Search("Drafting.Geometry.Name ='Frame_'*, Drawing") If Err.Number <> 0 Then Err.Clear Selection.Clear iNbOfGeomElems = GeomElems.Count ii = 1 While (ii <= iNbOfGeomElems) Set GeomElem = GeomElems.Item(ii) if (Left(GeomElem.Name, 6) = "Frame_") Then Selection.Add(GeomElem) End If ii = ii + 1 Wend End If Selection.Delete On Error Goto 0 End Sub Sub CATRemoveStandard() '------------------------------------------------------------------------------- 'How to remove the standard representation '------------------------------------------------------------------------------- On Error Resume Next selection.Add(DrwView) Selection.Search("Drafting.Geometry.Name ='TitleBlock_Standard'*, Drawing") Selection.Delete If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATMoveTitleBlock() '------------------------------------------------------------------------------- 'How to translate the whole title block after changing the page setup '------------------------------------------------------------------------------- Dim rootName As String Dim rootNameLength As Integer Dim NbLineToMove As Integer Dim NbCircleToMove As Integer Dim NbTextToMove As Integer Dim Origin(2) Dim Direction(2) Dim Radius As Double rootName = "TitleBlock_Line_" rootNameLength = Len(rootName) NbLineToMove = GeomElems.Count For i = 1 To NbLineToMove Set Line = GeomElems.Item(i) If (Left(Line.Name, rootNameLength) = rootName) Then Line.GetOrigin(Origin) Line.GetDirection(Direction) Line.SetData Origin(0)+TranslationX, Origin(1)+TranslationY, Direction(0), Direction(1) End If Next rootName = "TitleBlock_Standard_Line_" rootNameLength = Len(rootName) NbLineToMove = GeomElems.Count For i = 1 To NbLineToMove Set Line = GeomElems.Item(i) If (Left(Line.Name, rootNameLength) = rootName) Then Line.GetOrigin(Origin) Line.GetDirection(Direction) Line.SetData Origin(0)+TranslationX, Origin(1)+TranslationY, Direction(0), Direction(1) End If Next rootName = "TitleBlock_Standard_Circle" rootNameLength = Len(rootName) NbCircleToMove = GeomElems.Count For i = 1 To NbCircleToMove Set Circle = GeomElems.Item(i) If (Left(Circle.Name, rootNameLength) = rootName) Then Circle.GetCenter(Origin) Radius = Circle.Radius Circle.SetData Origin(0)+TranslationX, Origin(1)+TranslationY, Radius End If Next rootName = "TitleBlock_Text_" rootNameLength = Len(rootName) NbTextToMove = DrwTexts.Count For i = 1 To NbTextToMove Set Text = DrwTexts.Item(i) If (Left(Text.Name, rootNameLength) = rootName) Then Text.x = Text.x + TranslationX Text.y = Text.y + TranslationY End If Next End Sub Sub CATFormatFText(textName As String, angle As Double) '------------------------------------------------------------------------------- 'How to format the texts belonging to the frame '------------------------------------------------------------------------------- Text.Name = textName Text.AnchorPosition = CATMiddleCenter Text.Angle = angle End Sub Sub CATFormatTBText(textName As String, anchorPosition As String, fontSize) '------------------------------------------------------------------------------- 'How to format the texts belonging to the titleblock '------------------------------------------------------------------------------- Text.Name = textName Text.SetFontName 0, 0, "Courrier 10 BT" Text.AnchorPosition = anchorPosition Text.SetFontSize 0, 0, fontSize End Sub Sub CATFormatRBText(textName As String, anchorPosition As String) '------------------------------------------------------------------------------- 'How to format the texts belonging to the titleblock '------------------------------------------------------------------------------- Text.Name = textName Text.AnchorPosition = anchorPosition Text.SetFontSize 0, 0, 5 End Sub Sub CATLinks() '------------------------------------------------------------------------------- 'How to fill in texts with data of the part/product linked with current sheet '------------------------------------------------------------------------------- On Error Resume Next Dim ProductDrawn As ProductDocument Set ProductDrawn = DrwSheet.Views.Item("Front view").GenerativeBehavior.Document If Err.Number = 0 Then DrwTexts.GetItem("TitleBlock_Text_Number_1").Text = ProductDrawn.PartNumber DrwTexts.GetItem("TitleBlock_Text_Title").Text = ProductDrawn.Definition Dim ProductAnalysis As Analyze Set ProductAnalysis = ProductDrawn.Analyze DrwTexts.GetItem("TitleBlock_Text_Weight_1").Text = FormatNumber(ProductAnalysis.Mass,2) End If '------------------------------------------------------------------------------- 'Display sheet format '------------------------------------------------------------------------------- Dim textFormat As DrawingText Set textFormat = DrwTexts.GetItem("TitleBlock_Text_Size_1") textFormat.Text = displayFormat If (Len(displayFormat) > 4 ) Then textFormat.SetFontSize 0, 0, 3.5 Else textFormat.SetFontSize 0, 0, 5. End If '------------------------------------------------------------------------------- 'Display sheet numbering '------------------------------------------------------------------------------- Dim nbSheet As Integer Dim curSheet As Integer nbSheet = 0 curSheet = 0 If (not DrwSheet.IsDetail) Then For i = 1 To DrwSheets.Count If (not DrwSheets.Item(i).IsDetail) Then nbSheet = nbSheet + 1 End If Next For i = 1 To DrwSheets.Count If (not DrwSheets.Item(i).IsDetail) Then On Error Resume Next curSheet = curSheet + 1 DrwSheets.Item(i).Views.Item(2).Texts.GetItem("TitleBlock_Text_Sheet_1").Text = CStr(curSheet) & "/" & CStr(nbSheet) End If Next End If On Error Goto 0 End Sub Sub CATFillField(string1 As String, string2 As String, string3 As String) '------------------------------------------------------------------------------- 'How to call a dialog to fill in manually a given text '------------------------------------------------------------------------------- Dim TextToFill_1 As DrawingText Dim TextToFill_2 As DrawingText Dim Person As String Set TextToFill_1 = DrwTexts.GetItem(string1) Set TextToFill_2 = DrwTexts.GetItem(string2) Person = TextToFill_1.Text If (Person = "XXX") Then Person = "John Smith" End If Person = InputBox("This Document has been " + string3 + " by:", "Controller's name", Person) If (Person = "") Then Person = "XXX" End If TextToFill_1.Text = Person TextToFill_2.Text = Date End Sub Sub CATRevPos(rev As Integer, oX As Double, oY As Double) '------------------------------------------------------------------------------- 'How to local the the current revision '------------------------------------------------------------------------------- CATStandard oX = OH if (rev = 0) Then oY = Height - OV Else oY = DrwTexts.GetItem("RevisionBlock_Text_Rev_" + Chr(64+rev)).y - .5*RevRowHeight End If End Sub