Public V_Version As String Public V_Datum As String Public V_Copyright As String V_Version = "4.0" V_Datum = "2004.02.19" V_Copyright = "Erstellt von Christoph Rafetzeder" 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 selection1 As Selection Public Selection As Selection Public GeomElems As GeometricElements Public Hoehe As Double 'Blatt Höhe Public Breite As Double 'Blattbreite 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 OV2 As Double Public OT As Double 'Absolutabstand des Schriftkopfes in x-Richtung Public B As Double 'Schriftkopfbreite Public ZH As Double 'Zeilebhöhe Public SpA(7) As Double Public SpB(5) As Double Public Benennung As String Public ZN As String Public IX As String Public Falt As Double Public Schnitt As Double Public Lochlinie As Double 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 Zaehler As Double 'Allgemeiner Zähler public StartTime, EndTime Public auswahl As VisProperties Const mm = 1 Const Inch = 254 Const RulerLength = 200 Const NbOfRevision = 1 Const MacroID = "Rahmen mit Schriftkopf ISO 7200" Const RevRowHeight = 10 Falt=3*mm Schnitt=5*mm Lochlinie=10*mm SpA(1) = + 12*mm SpA(2) = + 55.3*mm SpA(3) = + 7.3*mm SpA(4) = + 27.8*mm SpA(5) = + 7.6*mm SpA(6) = + 24*mm SpA(7) = + 21.7*mm SpB(1) = + 30*mm SpB(2) = + 20*mm SpB(3) = + 40*mm SpB(4) = + 20*mm SpB(5) = + 48*mm ZH = + 7*mm 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_Erstellen Else Input = InputBox("Gewünschte Funktion:" & vbcr & " 1 ... Rahmengröße einem neuen" & vbcr & " Blattformat anpassen" & vbcr & " 2 ... Schriftkopf mit Rahmen löschen" & vbcr & " 3 ... Schnitt- & Faltlinien erstellen" & vbcr & " 4 ... Schnitt- & Faltlinien löschen","Schriftkopf bereits vorhanden", "1") Zaehler=Input Select Case Zaehler Case 1 CATDrw_Resizing MsgBox "Der Rahmen und der Schriftkopf wurden" & vbcr & "dem neuen Blattformat angepasst!", VbInformation or VbOkOnly, "Hinweis" Case 2 CATDrw_Loeschen MsgBox "Der Rahmen mit Schriftkopf wurde gelöscht!", VbInformation or VbOkOnly, "Hinweis" Case 3 CATDrw_Hilfslinien_zum_Falten_erstellen Case 4 CATDrw_Hilfslinien_zum_Falten_entfernen End Select End If End Sub Sub CATDrw_Erstellen() '------------------------------------------------------------------------------- '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 CATReferenztext 'Referenztext erstellen CATRahmen_erzeugen 'Erzeugt den Rahmen CATSchriftkopf 'Erzeugt den Schriftkopf CATLocherlinie_erstellen 'MsgBox "Schritt 1/3 :" & vbcr & "Rahmen und Schriftkopf nach ISO 7200 wurde erstellt!", VbInformation or VbOkOnly, "Schriftkopf & Rahmen" 'If MsgBox("Schritt 2/3 :" & vbcr & "Möchten sie eine Teileliste erzeugen?", VbQuestion or VbYesNo, "Teileliste") = vbYes then CATTeileliste 'Erstellt eine Teileliste 'End If 'If MsgBox("Schritt 3/3 :" & vbcr & "Möchten sie Schnitt- und/oder Faltlinien erzeugen?", VbQuestion or VbYesNo, "Schnitt & Faltlinien") = vbYes then CATDrw_Hilfslinien_zum_Falten_erstellen 'Erstellt Faltlinien 'End If CATLinientypundstaerke 'Ändert den Linientyp und die Linienstärke um MsgBox "Version: "& V_Version & vbcr &"Datum: "& V_Datum & vbcr & V_Copyright & " ", VbInformation or VbOkOnly, "Fertig!" End Sub Sub CATDrw_Loeschen() '------------------------------------------------------------------------------- ' Löscht den Schriftkopf mit Rahmen '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATRemoveAll End Sub Sub CATDrw_Resizing() '------------------------------------------------------------------------------- ' Aktualisiert die Formatgröße des Rahmens '------------------------------------------------------------------------------- CATInit If CATCheckRef(0) Then Exit Sub CATStandard CATMoveReference If TranslationX <> 0 Or TranslationY <> 0 Then CATRemoveFrame CATSchnittlinien_erstellen CATFaltliniengeometrie_erstellen Selection.Search "Name:*Schnittlinie*" Selection.Delete Set Line = Fact.CreateLine( -1*mm, 148.5*mm , Lochlinie, 148.5*mm) Line.Name = "Locherlinie_99" Set Line = Fact.CreateLine( -1*mm, 148.5*mm , Lochlinie, 148.5*mm) Line.Name = "Faltlinie_99" Selection.Search "Name:*Locherlinie*" Selection.Delete Selection.Search "Name:*Faltlinie*" Selection.Delete If sheetFormat <> CatPaperA4 Or DrwSheet.Orientation <> 1 Then CATLocherlinie_erstellen End If If (sheetFormat <> CatPaperA4 ) Then CATSchnittlinien_erstellen CATFaltliniengeometrie_erstellen End If CATMoveTitleBlock CATRahmen_erzeugen ' CATSchriftkopf_Rahmen ' CATDrw_Hilfslinien_zum_Falten End If CATLinientypundstaerke End Sub Sub CATDrw_Hilfslinien_zum_Falten_erstellen() '------------------------------------------------------------------------------- ' Erstellt Hilfslinien zum Falten '------------------------------------------------------------------------------- CATInit CATStandard ' Input = InputBox("Was soll erstellt werden:" & vbcr & " 1 ... Schnittlinien" & vbcr & " 2 ... Faltlinien" & vbcr & " 3 ... Schnitt- & Faltlinien erstellen","Schnitt- und/oder Faltlinien erstellen", "3") ' Zaehler=Input ' Select Case Zaehler ' Case 1 ' CATSchnittlinien_erstellen ' MsgBox "Schnittlinien wurden erstellt!", VbInformation or VbOkOnly, "Hinweis" ' Case 2 ' CATFaltlinien_erstellen ' MsgBox "Faltlinien wurden erstellt!", VbInformation or VbOkOnly, "Hinweis" ' Case 3 CATSchnittlinien_erstellen CATFaltlinien_erstellen ' MsgBox "Schnitt- und Faltlinien wurden erstellt!" , VbInformation or VbOkOnly, "Hinweis" ' End Select End Sub Sub CATDrw_Hilfslinien_zum_Falten_entfernen() '------------------------------------------------------------------------------- 'Entfernen der Falthilfslinien '------------------------------------------------------------------------------- CATInit CATStandard CATEntf_Faltlinien 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 selection1 = 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() '------------------------------------------------------------------------------- ' Ermitteln der Grundgrößen '------------------------------------------------------------------------------- Hoehe = DrwSheet.GetPaperHeight Breite = DrwSheet.GetPaperWidth sheetFormat = DrwSheet.PaperSize Offset = 8.*mm 'Offset default value = 8. Offset_2=20.*mm OH = Breite - Offset OV = Offset OV2=Offset_2 B = 210*mm-OV-Ov2 OT = OH - B documentStd = DrwDocument.Standard If (documentStd = catISO or documentStd = catISO) Then displayFormat = "A" + CStr(sheetFormat - 2) 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 CATReferenztext() '------------------------------------------------------------------------------- ' Erzeugen eines Referenztextes '------------------------------------------------------------------------------- Set Text = DrwTexts.Add("", Breite - 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 "Es ist bereits ein anderer,fremder Schriftkopf vorhanden:" + 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 CATSchriftkopf() '------------------------------------------------------------------------------- 'How to create the TitleBlock '------------------------------------------------------------------------------- CATSchriftkopf_Gitter 'To draw the geometry CATSchriftkopf_Text 'To fill in the title block End Sub Sub CATTeileliste() '------------------------------------------------------------------------------- 'Erzeugt eine Teileliste '------------------------------------------------------------------------------- Zaehler=1 'Do CATTeileliste_Zeile Zaehler=Zaehler+1 'Loop While (MsgBox("Weitere Zeile erstellen?", VbQuestion or VbYesNo, "Weitere Zeile") = vbYes) Dim auswahl As VisProperties Set auswahl = selection1.VisProperties selection1.Search "Name:*BOM_Linie_*" auswahl.SetRealWidth 1,1 selection1.Clear End Sub Sub CATTeileliste_Zeile() '------------------------------------------------------------------------------- 'Erzeugt eine Teilelistezeile '------------------------------------------------------------------------------- Text_01 = "1" Text_02 = "Mittelteil" Text_03 = "01" Text_04 = "F133-01" Text_05 = "01" Text_06 = "9 SMn 36" Text_07 = "%d60x15x48" Text_08 = "999" ' Input = InputBox("Position:","Teileliste", Zaehler) ' Text_01=Input ' Input = InputBox("Bezeichnung:","Teileliste", "Mittelteil") ' Text_02=Input ' ' Input = InputBox("Anzahl:","Teileliste", "01") ' Text_03=Input ' ' Input = InputBox("Referenz:","Teileliste", "F133-01") ' Text_04=Input ' ' Input = InputBox("Index:","Teileliste", "01") ' Text_05=Input ' ' Input = InputBox("Werkstoff:","Teileliste", "9 SMn 36") ' Text_06=Input ' ' Input = InputBox("Rohmaß:","Teileliste", "?60x15x48") ' Text_07=Input ' ' Input = InputBox("Gewicht [kg]:","Teileliste", "999") ' Text_08=Input Set Line = Fact.CreateLine(OT,OV+5*ZH+Zaehler*7*mm,OT,OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_0_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1),OV+5*ZH+Zaehler*7*mm,OT+SpA(1),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_1_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_2_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2)+SpA(3),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_3_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_4_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_5_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_6_"&Zaehler Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6)+SpA(7),OV+5*ZH+Zaehler*7*mm,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6)+SpA(7),OV+4*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_7_"&Zaehler Set Line = Fact.CreateLine(OT,OV+5*ZH+Zaehler*7*mm,OH,OV+5*ZH+Zaehler*7*mm) Line.Name = "BOM_Linie_Quer_"&Zaehler Set Text = DrwTexts.Add(Text_01,OT + SpA(1) /2 , OV + 4.5*ZH+Zaehler*7*mm) CATFormatTBText "TitleBlock_Text_Position" , catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_02,OT + SpA(1) + 3*mm , OV + 4.5*ZH +Zaehler*7*mm) CATFormatTBText "TitleBlock_Text_Benennung", catMiddleLeft, 2 Set Text = DrwTexts.Add(Text_03,OT + SpA(1) + SpA(2) + SpA(3) /2 , OV + 4.5*ZH+Zaehler*7*mm) CATFormatTBText "TitleBlock_Text_Stk", catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_04,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) /2 , OV + 4.5*ZH +Zaehler*7*mm ) CATFormatTBText "TitleBlock_Text_Norm", catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_05,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) /2 , OV + 4.5*ZH +Zaehler*7*mm) CATFormatTBText "TitleBlock_Text_Index", catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_06,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) /2 , OV + 4.5*ZH+Zaehler*7*mm ) CATFormatTBText "TitleBlock_Text_Werkstoff", catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_07,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) + SpA(7) /2 ,OV + 4.5*ZH+Zaehler*7*mm ) CATFormatTBText "TitleBlock_Text_Rohmass", catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_08,OH - (B-(SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) + SpA(7)))/2 ,OV + 4.5*ZH+Zaehler*7*mm ) CATFormatTBText "TitleBlock_Text_Gewicht", catMiddleCenter, 2 End Sub Sub CATSchriftkopf_Gitter() '------------------------------------------------------------------------------- 'How to draw the title block geometry '------------------------------------------------------------------------------- On Error Resume Next Set Line = Fact.CreateLine(OT, OV, OH , OV ) Line.Name = "Schriftkopf_Linie_Rahmen_Unten" Set Line = Fact.CreateLine(OT, OV,OT,OV + 5*ZH) Line.Name = "Schriftkopf_Linie_Rahmen_Links" Set Line = Fact.CreateLine(OT,OV + 5*ZH, OH,OV + 5*ZH) Line.Name = "Schriftkopf_Linie_Rahmen_Oben" Set Line = Fact.CreateLine(OH, OV,OH,OV + 5*ZH) Line.Name = "Schriftkopf_Linie_Rahmen_Rechts" Set Line = Fact.CreateLine(OT,OV+4*ZH,OH,OV+4*ZH) Line.Name = "Schriftkopf_Linie_Horizontal_1" Set Line = Fact.CreateLine(OT+SpB(1),OV+3*ZH,OH,OV+3*ZH) Line.Name = "Schriftkopf_Linie_Horizontal_2" Set Line = Fact.CreateLine(OT,OV+2*ZH,OT+SpB(1)+SpB(2)+SpB(3)+SpB(4),OV+2*ZH) Line.Name = "Schriftkopf_Linie_Horizontal_3" Set Line = Fact.CreateLine(OT+SpB(1),OV+ZH,OH,OV+ZH) Line.Name = "Schriftkopf_Linie_Horizontal_4" Set Line = Fact.CreateLine(OT+SpA(1),OV+5*ZH,OT+SpA(1),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_1" Set Line = Fact.CreateLine(OT+SpB(1)/2,OV,OT+SpB(1)/2,OV+2*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_2" Set Line = Fact.CreateLine(OT+SpB(1),OV,OT+SpB(1),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_3" Set Line = Fact.CreateLine(OT+SpB(1)+SpB(2),OV,OT+SpB(1)+SpB(2),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_4" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2),OV+5*ZH,OT+SpA(1)+SpA(2),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_5" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3),OV+5*ZH,OT+SpA(1)+SpA(2)+SpA(3),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_6" Set Line = Fact.CreateLine(OT+SpB(1)+SpB(2)+SpB(3),OV+2*ZH,OT+SpB(1)+SpB(2)+SpB(3),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_7" Set Line = Fact.CreateLine(OT+SpB(1)+SpB(2)+SpB(3)+SpB(4),OV,OT+SpB(1)+SpB(2)+SpB(3)+SpB(4),OV+5*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_8" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5),OV+5*ZH,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_9" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6),OV+5*ZH,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_10" Set Line = Fact.CreateLine(OT+SpB(1)+SpB(2)+SpB(3)+SpB(4)+SpB(5),OV,OT+SpB(1)+SpB(2)+SpB(3)+SpB(4)+SpB(5),OV+ZH) Line.Name = "Schriftkopf_Linie_Vertikal_11" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4),OV+5*ZH,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_12" Set Line = Fact.CreateLine(OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6)+SpA(7),OV+5*ZH,OT+SpA(1)+SpA(2)+SpA(3)+SpA(4)+SpA(5)+SpA(6)+SpA(7),OV+4*ZH) Line.Name = "Schriftkopf_Linie_Vertikal_13" Set Line = Fact.CreateLine(OT+1*mm,OV+5*mm,OT+SpB(1)/2-0.5*mm,OV+5*mm) Line.Name = "TitleBlock_Standard_Linie_Achse_H" Set Line = Fact.CreateLine(OT+SpB(1)/2-1*mm-3*mm,OV+5*mm+3.5*mm,OT+SpB(1)/2-1*mm-3*mm,OV+5*mm-3.5*mm) Line.Name = "TitleBlock_Standard_Linie_Achse_V" Set Line = Fact.CreateLine(OT+1.5*mm, OV+6.5*mm,OT+1.5*mm, OV+3.5*mm) Line.Name = "TitleBlock_Standard_Linie_1" Set Line = Fact.CreateLine(OT+6.5*mm, OV+8*mm,OT+6.5*mm, OV+2*mm) Line.Name = "TitleBlock_Standard_Linie_2" Set Line = Fact.CreateLine(OT+1.5*mm, OV+5*mm+1.5*mm,OT+6*mm+0.5*mm, OV+5*mm+3*mm) Line.Name = "TitleBlock_Standard_Linie_3" Set Line = Fact.CreateLine(OT+1*mm+0.5*mm, OV+5*mm-1.5*mm,OT+6*mm+0.5*mm, OV+5*mm-3*mm) Line.Name = "TitleBlock_Standard_Linie_4" Set Circle = Fact.CreateClosedCircle(OT+SpB(1)/2-4*mm,OV+5*mm, 3*mm) Circle.Name = "TitleBlock_Kreis_1" Set Circle = Fact.CreateClosedCircle(OT+SpB(1)/2-4*mm,OV+5*mm, 1.5*mm) Circle.Name = "TitleBlock_Kreis_2" If Err.Number <> 0 Then Err.Clear End If On Error Goto 0 End Sub Sub CATSchriftkopf_Text() '------------------------------------------------------------------------------- 'How to fill in the title block '------------------------------------------------------------------------------- Text_01 = "5CHMIA" Text_02 = "Projektion" Text_03 = "Maßstab" Text_04 = "1:1" Text_05 = "Allgemeintoleranz" Text_06 = "ÖNORM EN 22768" Text_07 = "gezeichnet" Text_08 = "2D-Dateiname" Text_09 = "3D-Dateiname" Text_10 = "Name" Text_11 = "Datum" Text_12 = "HTL St. Pölten" Text_13 = "Maschineningenieurwesen - Automatisierungstechnik" Text_14 = "Projekt/Programm:" Text_15 = "Zeichnungs-Nr.:" Text_16 = "Index:" Text_17 = "Position" Text_18 = "Benennung" Text_19 = "Stk." Text_20 = "Zeichnungsnr., Norm" Text_21 = "Index" Text_22 = "Werkstoff" Text_23 = "Rohmass" Text_24 = "Gewicht [kg]" Text_25 = "Musterschüler" Text_26 = "f/m/g" Text_27 = "?.CATDrawing" Text_28 = "?.CATPart" ZN = "F082-01" IX = "01" Benennung = "1.Projekt" Set Text = DrwTexts.Add(Text_02, OT +SpB(1)/4, OV +2*ZH-2.5*mm ) CATFormatTBText "TitleBlock_Text_Projektion" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_03, OT +SpB(1)*3/4, OV +2*ZH-2.5*mm ) CATFormatTBText "TitleBlock_Text_Maßstab" , catMiddleCenter , 1.5 Set Text = DrwTexts.Add(Text_04, OT+SpB(1)*3/4, OV +2*ZH-2.5*mm-0.75*ZH ) CATFormatTBText "TitleBlock_Text_Massstab" , catMiddleCenter, 2.5 Set Text = DrwTexts.Add(Text_05, OT +SpB(1)/2, OV +3.5*ZH ) CATFormatTBText "TitleBlock_Text_Allgemeintoleranz" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_06, OT +SpB(1)/2, OV +3*ZH+1*mm ) CATFormatTBText "TitleBlock_Text_OENORM EN 22768" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_07, OT +SpB(1)+3*mm, OV +2.5*ZH) CATFormatTBText "TitleBlock_Text_gezeichnet" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_08, OT +SpB(1)+3*mm, OV +1.5*ZH) CATFormatTBText "TitleBlock_Text_2D_Name" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_09, OT +SpB(1)+3*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_3D_Name" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_10, OT +SpB(1)+SpB(2)+SpB(3)/2, OV +3.5*ZH ) CATFormatTBText "TitleBlock_Text_Name" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_11, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)/2, OV +3.5*ZH ) CATFormatTBText "TitleBlock_Text_Datum" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_12, (OH+Ot+SpB(1)+SpB(2)+SpB(3)+SpB(4))/2, OV +3.5*ZH+1.5*mm ) CATFormatTBText "TitleBlock_Text_HTL_STPOELTEN" , catMiddleCenter, 2.5 Set Text = DrwTexts.Add(Text_13,(OH+Ot+SpB(1)+SpB(2)+SpB(3)+SpB(4))/2, OV +3.5*ZH-1.5*mm ) CATFormatTBText "TitleBlock_Text_Abteilung" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_14, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+1.5*mm, OV +2.5*ZH+1.5*mm) CATFormatTBText "TitleBlock_Text_Projekt" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_15, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+1.5*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_Zeichnungsnummer_1" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_16, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+SpB(5)+1.5*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_Index_K" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_17,OT + SpA(1) /2 , OV + 4.5*ZH) CATFormatTBText "TitleBlock_Text_Position_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_18,OT + SpA(1) + SpA(2) /2 , OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Benennung_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_19,OT + SpA(1) + SpA(2) + SpA(3) /2 , OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Stk_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_20,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) /2 , OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Norm_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_21,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) /2 , OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Index_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_22,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) /2 , OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Werkstoff_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_23,OT + SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) + SpA(7)/2, OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Rohmass_1" , catMiddleCenter, 1.5 Set Text = DrwTexts.Add(Text_24,OH - (B-(SpA(1) + SpA(2) + SpA(3) + SpA(4) + SpA(5) + SpA(6) + SpA(7)))/2, OV + 4.5*ZH ) CATFormatTBText "TitleBlock_Text_Gewicht_1" , catMiddleCenter, 1.5 ' Input = InputBox("Gezeichnet von:","Gezeichnet von...", "Musterschüler") ' Text_25=Input Set Text = DrwTexts.Add(Text_25, OT +SpB(1)+SpB(2)+3*mm, OV +2.5*ZH) CATFormatTBText "TitleBlock_Text_gezeichnet_Name" , catMiddleLeft, 2 Set Text = DrwTexts.Add(Text_26, OT +SpB(1)/2, OV +2.5*ZH) CATFormatTBText "TitleBlock_Text_Toleranz" , catMiddleCenter, 2 Set Text = DrwTexts.Add(Text_27, OT +SpB(1)+SpB(2)+3*mm, OV +1.5*ZH) CATFormatTBText "TitleBlock_Text_2DDatei" , catMiddleLeft, 1.5 Set Text = DrwTexts.Add(Text_28, OT +SpB(1)+SpB(2)+3*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_3DDatei" , catMiddleLeft, 1.5 'Input = InputBox("Klasse:","Klasse", "5CHMIA") ' Text_01=Input Set Text = DrwTexts.Add(Text_01,OT +SpB(1)+SpB(2)/2 , OV +3.5*ZH ) CATFormatTBText "TitleBlock_Text_Klasse" , catMiddleCenter, 2 Set Text = DrwTexts.Add(Date, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)/2, OV +2.5*ZH) CATFormatTBText "TitleBlock_Text_gezeichnet_Datum" , catMiddleCenter, 2 ' Input = InputBox("Benennung der 2D - Zeichnung:","Benennung", "1.Programm") ' Benennung=Input Set Text = DrwTexts.Add(Benennung, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+3*mm, OV +2*ZH) CATFormatTBText "TitleBlock_Text_Programm" , catMiddleLeft, 3 ' Input = InputBox("Zeichnungsnummer eingeben:","Zeichnungsnummer", "F082-01") ' ZN=Input Set Text = DrwTexts.Add(ZN, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+23*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_Zeichnungsnummer" , catMiddleLeft, 3 ' Input = InputBox("Änderungsindex eingeben:","Index", "01") ' IX=Input Set Text = DrwTexts.Add(IX, OT +SpB(1)+SpB(2)+SpB(3)+SpB(4)+SpB(5)+11*mm, OV +0.5*ZH) CATFormatTBText "TitleBlock_Text_Index1" , catMiddleLeft, 3 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 = Breite - 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 CATLocherlinie_erstellen() '------------------------------------------------------------------------------- ' Erstellen der Locherlinie '------------------------------------------------------------------------------- If sheetFormat <> CatPaperA4 Or DrwSheet.Orientation <> 1 Then Set Line = Fact.CreateLine( -1*mm, 148.5*mm , Lochlinie, 148.5*mm) Line.Name = "Locherlinie_1" Set auswahl = selection1.VisProperties selection1.Search "Name:*Locherlinie*" auswahl.SetRealWidth 1,1 selection1.Clear End If End Sub Sub CATSchnittlinien_erstellen() '------------------------------------------------------------------------------- ' Erstellen der Schnittlinien '------------------------------------------------------------------------------- Set Line = Fact.CreateLine( - Schnitt/2 , 0*mm , + Schnitt/2 , 0*mm ) Line.Name = "Schnittlinie_1" Set Line = Fact.CreateLine( 0*mm , - Schnitt/2 , 0*mm , + Schnitt/2 ) Line.Name = "Schnittlinie_2" Set Line = Fact.CreateLine( Breite - Schnitt/2 , 0*mm , Breite + Schnitt/2 , 0*mm ) Line.Name = "Schnittlinie_3" Set Line = Fact.CreateLine( Breite , - Schnitt/2 , Breite , + Schnitt/2 ) Line.Name = "Schnittlinie_4" Set Line = Fact.CreateLine( - Schnitt/2 , Hoehe, + Schnitt/2 , Hoehe ) Line.Name = "Schnittlinie_5" Set Line = Fact.CreateLine( 0*mm , Hoehe - Schnitt/2 , 0*mm , Hoehe + Schnitt/2 ) Line.Name = "Schnittlinie_6" Set Line = Fact.CreateLine( Breite - Schnitt/2 , Hoehe , Breite + Schnitt/2 , Hoehe ) Line.Name = "Schnittlinie_7" Set Line = Fact.CreateLine( Breite , Hoehe - Schnitt/2 , Breite , Hoehe + Schnitt/2 ) Line.Name = "Schnittlinie_8" Set auswahl = selection1.VisProperties selection1.Search "Name:*Schnittlinie*" auswahl.SetRealWidth 3,1 selection1.Clear End Sub Sub CATFaltliniengeometrie_erstellen() If (sheetFormat = CatPaperA3 ) Then If(DrwSheet.Orientation =0) Then Set Line = Fact.CreateLine( 63.5*mm, -1*mm , 63.5*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 107*mm, -1*mm , 107*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 63.5*mm, Hoehe+1*mm, 63.5*mm, Hoehe-Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 107*mm, Hoehe+1*mm, 107*mm, Hoehe-Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_6" Else Set Line = Fact.CreateLine( 125*mm, -1*mm , 125*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 230*mm, -1*mm , 230*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 125*mm, Hoehe+1*mm, 125*mm, Hoehe-Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 230*mm, Hoehe+1*mm , 230*mm, Hoehe-Falt) Line.Name = "Faltlinie_4" End If End If If (sheetFormat = CatPaperA2 ) Then If(DrwSheet.Orientation =0) Then Set Line = Fact.CreateLine( 125*mm, -1*mm , 125*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 230*mm, -1*mm , 230*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 125*mm, Hoehe+1*mm, 125*mm, Hoehe-Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 230*mm, Hoehe+1*mm , 230*mm, Hoehe-Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_6" Else Set Line = Fact.CreateLine( 210*mm, -1*mm , 210*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 402*mm, -1*mm , 402*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 210*mm, Hoehe+1*mm, 210*mm, Hoehe-Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 402*mm, Hoehe+1*mm , 402*mm, Hoehe-Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_6" End If End If If (sheetFormat = CatPaperA1 ) Then If(DrwSheet.Orientation =0) Then Set Line = Fact.CreateLine( 210*mm, -1*mm , 210*mm, Falt) '||||| Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 402*mm, -1*mm , 402*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 210*mm, Hoehe+1*mm, 210*mm, Hoehe-Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 402*mm, Hoehe+1*mm , 402*mm, Hoehe-Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) '------- Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_6" Set Line = Fact.CreateLine( -1*mm, 594*mm , Falt, 594*mm) Line.Name = "Faltlinie_7" Set Line = Fact.CreateLine( Breite+1*mm, 594*mm , Breite-Falt, 594*mm) Line.Name = "Faltlinie_8" Else Set Line = Fact.CreateLine( 210*mm, -1*mm , 210*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 400*mm, -1*mm , 400*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 525.5*mm, -1*mm , 525.5*mm, Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 651*mm, -1*mm , 651*mm, Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( 210*mm, Hoehe+1*mm, 210*mm, Hoehe-Falt) Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( 400*mm, Hoehe+1*mm , 400*mm, Hoehe-Falt) Line.Name = "Faltlinie_6" Set Line = Fact.CreateLine( 525.5*mm, Hoehe+1*mm, 525.5*mm, Hoehe-Falt) Line.Name = "Faltlinie_7" Set Line = Fact.CreateLine( 651*mm, Hoehe+1*mm , 651*mm, Hoehe-Falt) Line.Name = "Faltlinie_8" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) Line.Name = "Faltlinie_9" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_10" End If End If If (sheetFormat = CatPaperA0 ) Then If(DrwSheet.Orientation =0) Then Set Line = Fact.CreateLine( 210*mm, -1*mm , 210*mm, Falt) '||||| Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 400*mm, -1*mm , 400*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 590*mm, -1*mm , 590*mm, Falt) '||||| Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 620.5*mm, -1*mm , 620.5*mm, Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( 651*mm, -1*mm , 651*mm, Falt) '||||| Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( 210*mm, Hoehe+1*mm, 210*mm, Hoehe-Falt) Line.Name = "Faltlinie_6" Set Line = Fact.CreateLine( 400*mm, Hoehe+1*mm , 400*mm, Hoehe-Falt) Line.Name = "Faltlinie_7" Set Line = Fact.CreateLine( 590*mm, Hoehe+1*mm, 590*mm, Hoehe-Falt) Line.Name = "Faltlinie_8" Set Line = Fact.CreateLine( 620.5*mm, Hoehe+1*mm , 620.5*mm, Hoehe-Falt) Line.Name = "Faltlinie_9" Set Line = Fact.CreateLine( 651*mm, Hoehe+1*mm , 651*mm, Hoehe-Falt) Line.Name = "Faltlinie_10" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) '------- Line.Name = "Faltlinie_11" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_12" Set Line = Fact.CreateLine( -1*mm, 594*mm , Falt, 594*mm) Line.Name = "Faltlinie_13" Set Line = Fact.CreateLine( Breite+1*mm, 594*mm , Breite-Falt, 594*mm) Line.Name = "Faltlinie_14" Set Line = Fact.CreateLine( -1*mm, 891*mm , Falt, 891*mm) Line.Name = "Faltlinie_15" Set Line = Fact.CreateLine( Breite+1*mm, 891*mm , Breite-Falt, 891*mm) Line.Name = "Faltlinie_16" Else Set Line = Fact.CreateLine( 210*mm, -1*mm , 210*mm, Falt) Line.Name = "Faltlinie_1" Set Line = Fact.CreateLine( 400*mm, -1*mm , 400*mm, Falt) Line.Name = "Faltlinie_2" Set Line = Fact.CreateLine( 590*mm, -1*mm , 590*mm, Falt) Line.Name = "Faltlinie_3" Set Line = Fact.CreateLine( 780*mm, -1*mm , 780*mm, Falt) Line.Name = "Faltlinie_4" Set Line = Fact.CreateLine( 889.5*mm, -1*mm , 889.5*mm, Falt) Line.Name = "Faltlinie_5" Set Line = Fact.CreateLine( 999*mm, -1*mm , 999*mm, Falt) Line.Name = "Faltlinie_6" Set Line = Fact.CreateLine( 210*mm, Hoehe+1*mm, 210*mm, Hoehe-Falt) Line.Name = "Faltlinie_7" Set Line = Fact.CreateLine( 400*mm, Hoehe+1*mm , 400*mm, Hoehe-Falt) Line.Name = "Faltlinie_8" Set Line = Fact.CreateLine( 590*mm, Hoehe+1*mm, 590*mm, Hoehe-Falt) Line.Name = "Faltlinie_9" Set Line = Fact.CreateLine( 780*mm, Hoehe+1*mm , 780*mm, Hoehe-Falt) Line.Name = "Faltlinie_10" Set Line = Fact.CreateLine( 889.5*mm, Hoehe+1*mm, 889.5*mm, Hoehe-Falt) Line.Name = "Faltlinie_11" Set Line = Fact.CreateLine( 999*mm, Hoehe+1*mm , 999*mm, Hoehe-Falt) Line.Name = "Faltlinie_12" Set Line = Fact.CreateLine( -1*mm, 297*mm , Falt, 297*mm) Line.Name = "Faltlinie_13" Set Line = Fact.CreateLine( Breite+1*mm, 297*mm , Breite-Falt, 297*mm) Line.Name = "Faltlinie_14" Set Line = Fact.CreateLine( -1*mm, 594*mm , Falt, 594*mm) Line.Name = "Faltlinie_15" Set Line = Fact.CreateLine( Breite+1*mm, 594*mm , Breite-Falt, 594*mm) Line.Name = "Faltlinie_16" End If End If If (sheetFormat <> CatPaperA4 ) Then Set auswahl = selection1.VisProperties selection1.Search "Name:*Faltlinie*" auswahl.SetRealWidth 1,1 selection1.Clear End If End Sub Sub CATFaltlinien_erstellen() '------------------------------------------------------------------------------- ' Erstellen der Falthilfslinien '------------------------------------------------------------------------------- ' If (sheetFormat = CatPaperA4 ) Then ' MsgBox "Es wurden keine Faltlinien erzeugt, da das Blattformat A4 ist!", VbExclamation or VbOkOnly, "Hinweis" ' Else CATFaltliniengeometrie_erstellen 'End If End Sub Sub CATEntf_Faltlinien() '------------------------------------------------------------------------------- 'Entfernen der Falthilfslinien '------------------------------------------------------------------------------- ' Input = InputBox("Was soll gelöscht werden:" & vbcr & " 1 ... Schnittlinien" & vbcr & " 2 ... Faltlinien" & vbcr & " 3 ... Schnitt- & Faltlinien","Schriftkopf bereits vorhanden", "1") ' Zaehler=Input ' Select Case Zaehler ' Case 1 ' CATSchnittlinien_erstellen ' Selection.Search "Name:*Schnittlinie*" ' Selection.Delete ' MsgBox "Schnittlinien wurden gelöscht!", VbInformation or VbOkOnly, "Hinweis" ' ' Case 2 ' CATFaltlinien_erstellen ' Selection.Search "Name:*Faltlinie*" ' Selection.Delete ' MsgBox "Faltlinien wurden gelöscht!", VbInformation or VbOkOnly, "Hinweis" ' ' Case 3 On Error Resume Next CATSchnittlinien_erstellen CATFaltlinien_erstellen Selection.Search "Name:*Faltlinie*" Selection.Delete Selection.Search "Name:*Schnittlinie*" Selection.Delete ' MsgBox "Schnitt- und Faltlinien wurden gelöscht!", VbInformation or VbOkOnly, "Hinweis" ' End Select 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 = "BOM_Linie_" 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 = "Schriftkopf_Linie_" 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_" 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_Kreis" 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 CATLinientypundstaerke() '------------------------------------------------------------------------------- ' Änder der Linientypen und Stärken '------------------------------------------------------------------------------- CATInit CATStandard Dim auswahl As VisProperties Set auswahl = selection1.VisProperties selection1.Search "Name:*TitleBlock_*" auswahl.SetRealWidth 1,1 selection1.Clear selection1.Search "Name:*Achse*" auswahl.SetRealLineType 4,1 selection1.Clear selection1.Search "Name:*Schriftkopf_*" auswahl.SetRealWidth 1,1 selection1.Clear selection1.Search "Name:*Rahmen*" auswahl.SetRealWidth 2,1 selection1.Clear selection1.Search "Name:*Frame_Border_*" auswahl.SetRealWidth 3,1 selection1.Clear End Sub