Catia 标题块宏
Catia title block macro
我试图通过从 .xls table 中读取数据并使用它来填充标题栏（零件号，material 代码，描述、修订、日期、作者等）。我想在我将设计的标题栏中执行此操作（不是已在 Catia 中实现的样式）。
我很想自己做，但我不知道从哪里开始。有没有人有任何指示或有任何教程可以帮助我入门？
在创建新标题栏时先尝试录制宏，这会让您了解线条和文本是如何创建的。之后，您可以开始将 Excel 单元格值与 CATIA 中的文本值连接起来。
好的，同意，编码时起草不是最用户友好的:-)。不过，如果我没记错的话（因为现在我没有 CATIA），有些东西还是被记录下来了...
' ======================================================
' Purpose: Macro will activate the backgroud view in an active CATIA drawing (A4 sheet) and will draw a title block
' Usage: 1 - A CATDrawing must be active
' 2 - Run macro
' Author: ferdo (Disclaimer: You use this code at your own risk)
' ======================================================
Language="VBSCRIPT"
' made as example by ferdo for auxcad.com
Sub CATMain()
Dim CATIA As Object
Set CATIA = GetObject(, "CATIA.Application")
Dim MyDrawingDoc As DrawingDocument
Set MyDrawingDoc = CATIA.ActiveDocument
Dim MyDrawingSheets As DrawingSheets
Set MyDrawingSheets = MyDrawingDoc.Sheets
Dim MyDrawingSheet As DrawingSheet
Set MyDrawingSheet = MyDrawingSheets.ActiveSheet
Dim MyDrawingViews As DrawingViews
Set MyDrawingViews = MyDrawingSheet.Views
Dim drwviews As DrawingViews 'make background view active
Set drwviews = MyDrawingSheet.Views
drwviews.Item("Background View").Activate
'Set myText.... As DrawingText - adding texts
Set myText = MyDrawingViews.ActiveView.Texts.Add ("Dibujado", 22, 38) 'coordinates x=22, y=38 of left bottom corner of the text location
Set myText1 = MyDrawingViews.ActiveView.Texts.Add ("Corregido", 22, 31)
Set myText2 = MyDrawingViews.ActiveView.Texts.Add ("Fecha", 57, 46)
Set myText3 = MyDrawingViews.ActiveView.Texts.Add ("DD-mm-08", 57, 38)
Set myText4 = MyDrawingViews.ActiveView.Texts.Add ("DD-mm-08", 57, 31)
Set myText5 = MyDrawingViews.ActiveView.Texts.Add ("Nombre", 87, 46)
Set myText6 = MyDrawingViews.ActiveView.Texts.Add ("Jefatura", 87, 38)
Set myText7 = MyDrawingViews.ActiveView.Texts.Add ("Delineante", 87, 31)
Set myText8 = MyDrawingViews.ActiveView.Texts.Add ("Empresa S.A.", 159, 40)
Set myText9 = MyDrawingViews.ActiveView.Texts.Add ("C/laredo 8, 2B", 159, 32)
Set myText13 = MyDrawingViews.ActiveView.Texts.Add ("Escalas:", 22, 23)
Set myText14 = MyDrawingViews.ActiveView.Texts.Add ("1/X", 22, 17)
Set myText15 = MyDrawingViews.ActiveView.Texts.Add ("1/X", 22, 11)
Set myText16 = MyDrawingViews.ActiveView.Texts.Add ("Firma", 128, 38)
Dim iFortSize1 As Double 'font text size
iFontSize1 = 3.500
myText1.SetFontSize 0, 0, 3.500 'iFontSize
'next lines with a different size for fonts - 2.5
Set myText10 = MyDrawingViews.ActiveView.Texts.Add ("Sustituye a: xxx-08", 155, 22)
Set myText11 = MyDrawingViews.ActiveView.Texts.Add ("Sustituido por: xxx-08", 155, 12)
Dim iFortSize10 As Double
iFontSize10 = 2.500
myText10.SetFontSize 0, 0, 2.500 'iFontSize
Dim iFortSize11 As Double
iFontSize11 = 2.500
myText11.SetFontSize 0, 0, 2.500 'iFontSize
'next lines with a different size for fonts - 5
Set myText12 = MyDrawingViews.ActiveView.Texts.Add ("plano No xxx-08", 70, 18)
Dim iFortSize12 As Double
iFontSize12 = 5.00
myText12.SetFontSize 0, 0, 5.00 'iFontSize
'Declarations
Dim DrwDocument As DrawingDocument
Dim DrwSheets As DrawingSheets
Dim DrwSheet As DrawingSheet
Dim DrwView As DrawingView
Dim DrwTexts As DrawingTexts
Dim Text As DrawingText
Dim Fact As Factory2D
Dim Point As Point2D
Dim Line As Line2D
Dim Cicle As Circle2D
Dim Selection As Selection
Dim GeomElems As GeometricElements
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
'draw frame bottom line
Set Line1 = Fact.CreateLine(20, 5, 205, 5) 'these are the coordinates of the starting point x=20, y=5 of the line and end point of the line x=205, y=5
Line1.Name = "Line1"
CATIA.ActiveDocument.Selection.VisProperties.SetRealWidth 3,1
CATIA.ActiveDocument.Selection.Clear
'draw frame upper line
Set Line2 = Fact.CreateLine(20, 292, 205, 292)
Line2.Name = "Line2"
CATIA.ActiveDocument.Selection.VisProperties.SetRealWidth 3,1
CATIA.ActiveDocument.Selection.Clear
'draw a thin line
Set Line3 = Fact.CreateLine(20, 40, 120, 40)
Line3.Name = "Line3"
CATIA.ActiveDocument.Selection.Add Line3
Set visProperties1 = CATIA.ActiveDocument.Selection.VisProperties
visProperties1.SetRealLineType 1,0.2
Set visProperties1 = CATIA.ActiveDocument.Selection.VisProperties
visProperties1.SetRealWidth 1,0.2
CATIA.ActiveDocument.Selection.Clear
' You can continue to draw the rest of the lines and try other settings...
End Sub
Ferdo，我修改了您的代码，因此它现在可以从 .xlsx 文件中读取数据并使用它来填充绘图上的文本框。现在我遇到了一些问题：
1. 我不得不停用绘制线条的代码，因为在 CATIA 对象的当前范围内出现重复声明错误。删除代码后，一切正常。你也许知道原因是什么？
2. 我无法使用正常的 VBA 方法更改字体。当我添加在下面的代码中注释的行时，我得到一个错误：方法'打开？对象 'WorkBooks' 失败。
3. 即使关闭 Catia，我也无法打开 xlsx 文件。我认为这是因为宏打开文件但没有关闭它，我尝试在最后添加 close 方法，但我也不断出错。
代码：
Sub CATMain()
'Define the variables
Dim GetData As Range 'range for finding cells in workbook
Dim PartNum As String 'variable for search key
Dim MyPath As String 'variable for workbook file path
Dim MyWB As String 'variable for workbook file name
Dim Datum As Date
Dim FontSize1 As Double 'font text size
Dim FontSize2 As Double
Dim FontSize3 As Double
Dim FontName1 As Double
'The text for which to search
PartNum = InputBox(prompt:="Enter Filter Part Number", Title:="Filter Part Number")
'The path to the workbook
MyPath = "C:\New folder\"
'The name of the workbook in which to search.
MyWB = "Podatki.xlsx"
'Turn off screen updating, and then open the target workbook.
Application.ScreenUpdating = False
Workbooks.Open Filename:=MyPath & MyWB
'Search for specified text
Set GetData = ActiveSheet.Cells.Find(PartNum)
Dim CATIA As Object
Set CATIA = GetObject(, "CATIA.Application")
Dim MyDrawingDoc As DrawingDocument
Set MyDrawingDoc = CATIA.ActiveDocument
Dim MyDrawingSheets As DrawingSheets
Set MyDrawingSheets = MyDrawingDoc.Sheets
Dim MyDrawingSheet As DrawingSheet
Set MyDrawingSheet = MyDrawingSheets.ActiveSheet
Dim MyDrawingViews As DrawingViews
Set MyDrawingViews = MyDrawingSheet.Views
Dim drwviews As DrawingViews 'make background view active
Set drwviews = MyDrawingSheet.Views
drwviews.Item("Background View").Activate
'Set myText.... As DrawingText - adding texts
Set myText1 = MyDrawingViews.ActiveView.Texts.Add(GetData.Value, 376, 19)
Set myText2 = MyDrawingViews.ActiveView.Texts.Add(GetData.Offset(0, -1), 374, 24)
Set myText3 = MyDrawingViews.ActiveView.Texts.Add(GetData.Offset(0, 1), 376, 14)
Set myText4 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 34)
Set myText5 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 39)
Set myText6 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 44)
Set myText7 = MyDrawingViews.ActiveView.Texts.Add("Surname Name", 374, 44)
FontSize1 = 2.5
FontSize2 = 2
FONTNAME = "Arial (TrueType)" ''if I remember correctly, here is only Arial without TrueType
myText1.SetFontSize 0, 0, FontSize1
myText2.SetFontSize 0, 0, FontSize1
myText3.SetFontSize 0, 0, FontSize1
myText4.SetFontSize 0, 0, FontSize2
myText5.SetFontSize 0, 0, FontSize2
myText6.SetFontSize 0, 0, FontSize2
myText7.SetFontSize 0, 0, FontSize2
'myText1.SetFontName 0, 0, FontName1
'Workbooks(MyPath & MyWB).Close SaveChanges:=False
'Workbooks.Close Filename:=MyPath & MyWB
End Sub
同一件事不能声明两次，否则会出错。另一方面，你在哪里声明了Excel？像下面这样的东西？别忘了关闭 Excel 并检查你的代码，我对字体类型做了一些小的修改
' Open an Excel File from CATIA
Dim OutPath
Dim OutIndex
Dim wbk As Excel.Workbook
Dim xlApp As Excel.Application
OutPath = "C:\temp\"
OutIndex = "YourFile.xls"
我试图通过从 .xls table 中读取数据并使用它来填充标题栏（零件号，material 代码，描述、修订、日期、作者等）。我想在我将设计的标题栏中执行此操作（不是已在 Catia 中实现的样式）。
我很想自己做，但我不知道从哪里开始。有没有人有任何指示或有任何教程可以帮助我入门？
在创建新标题栏时先尝试录制宏，这会让您了解线条和文本是如何创建的。之后，您可以开始将 Excel 单元格值与 CATIA 中的文本值连接起来。
好的，同意，编码时起草不是最用户友好的:-)。不过，如果我没记错的话（因为现在我没有 CATIA），有些东西还是被记录下来了...
' ======================================================
' Purpose: Macro will activate the backgroud view in an active CATIA drawing (A4 sheet) and will draw a title block
' Usage: 1 - A CATDrawing must be active
' 2 - Run macro
' Author: ferdo (Disclaimer: You use this code at your own risk)
' ======================================================
Language="VBSCRIPT"
' made as example by ferdo for auxcad.com
Sub CATMain()
Dim CATIA As Object
Set CATIA = GetObject(, "CATIA.Application")
Dim MyDrawingDoc As DrawingDocument
Set MyDrawingDoc = CATIA.ActiveDocument
Dim MyDrawingSheets As DrawingSheets
Set MyDrawingSheets = MyDrawingDoc.Sheets
Dim MyDrawingSheet As DrawingSheet
Set MyDrawingSheet = MyDrawingSheets.ActiveSheet
Dim MyDrawingViews As DrawingViews
Set MyDrawingViews = MyDrawingSheet.Views
Dim drwviews As DrawingViews 'make background view active
Set drwviews = MyDrawingSheet.Views
drwviews.Item("Background View").Activate
'Set myText.... As DrawingText - adding texts
Set myText = MyDrawingViews.ActiveView.Texts.Add ("Dibujado", 22, 38) 'coordinates x=22, y=38 of left bottom corner of the text location
Set myText1 = MyDrawingViews.ActiveView.Texts.Add ("Corregido", 22, 31)
Set myText2 = MyDrawingViews.ActiveView.Texts.Add ("Fecha", 57, 46)
Set myText3 = MyDrawingViews.ActiveView.Texts.Add ("DD-mm-08", 57, 38)
Set myText4 = MyDrawingViews.ActiveView.Texts.Add ("DD-mm-08", 57, 31)
Set myText5 = MyDrawingViews.ActiveView.Texts.Add ("Nombre", 87, 46)
Set myText6 = MyDrawingViews.ActiveView.Texts.Add ("Jefatura", 87, 38)
Set myText7 = MyDrawingViews.ActiveView.Texts.Add ("Delineante", 87, 31)
Set myText8 = MyDrawingViews.ActiveView.Texts.Add ("Empresa S.A.", 159, 40)
Set myText9 = MyDrawingViews.ActiveView.Texts.Add ("C/laredo 8, 2B", 159, 32)
Set myText13 = MyDrawingViews.ActiveView.Texts.Add ("Escalas:", 22, 23)
Set myText14 = MyDrawingViews.ActiveView.Texts.Add ("1/X", 22, 17)
Set myText15 = MyDrawingViews.ActiveView.Texts.Add ("1/X", 22, 11)
Set myText16 = MyDrawingViews.ActiveView.Texts.Add ("Firma", 128, 38)
Dim iFortSize1 As Double 'font text size
iFontSize1 = 3.500
myText1.SetFontSize 0, 0, 3.500 'iFontSize
'next lines with a different size for fonts - 2.5
Set myText10 = MyDrawingViews.ActiveView.Texts.Add ("Sustituye a: xxx-08", 155, 22)
Set myText11 = MyDrawingViews.ActiveView.Texts.Add ("Sustituido por: xxx-08", 155, 12)
Dim iFortSize10 As Double
iFontSize10 = 2.500
myText10.SetFontSize 0, 0, 2.500 'iFontSize
Dim iFortSize11 As Double
iFontSize11 = 2.500
myText11.SetFontSize 0, 0, 2.500 'iFontSize
'next lines with a different size for fonts - 5
Set myText12 = MyDrawingViews.ActiveView.Texts.Add ("plano No xxx-08", 70, 18)
Dim iFortSize12 As Double
iFontSize12 = 5.00
myText12.SetFontSize 0, 0, 5.00 'iFontSize
'Declarations
Dim DrwDocument As DrawingDocument
Dim DrwSheets As DrawingSheets
Dim DrwSheet As DrawingSheet
Dim DrwView As DrawingView
Dim DrwTexts As DrawingTexts
Dim Text As DrawingText
Dim Fact As Factory2D
Dim Point As Point2D
Dim Line As Line2D
Dim Cicle As Circle2D
Dim Selection As Selection
Dim GeomElems As GeometricElements
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
'draw frame bottom line
Set Line1 = Fact.CreateLine(20, 5, 205, 5) 'these are the coordinates of the starting point x=20, y=5 of the line and end point of the line x=205, y=5
Line1.Name = "Line1"
CATIA.ActiveDocument.Selection.VisProperties.SetRealWidth 3,1
CATIA.ActiveDocument.Selection.Clear
'draw frame upper line
Set Line2 = Fact.CreateLine(20, 292, 205, 292)
Line2.Name = "Line2"
CATIA.ActiveDocument.Selection.VisProperties.SetRealWidth 3,1
CATIA.ActiveDocument.Selection.Clear
'draw a thin line
Set Line3 = Fact.CreateLine(20, 40, 120, 40)
Line3.Name = "Line3"
CATIA.ActiveDocument.Selection.Add Line3
Set visProperties1 = CATIA.ActiveDocument.Selection.VisProperties
visProperties1.SetRealLineType 1,0.2
Set visProperties1 = CATIA.ActiveDocument.Selection.VisProperties
visProperties1.SetRealWidth 1,0.2
CATIA.ActiveDocument.Selection.Clear
' You can continue to draw the rest of the lines and try other settings...
End Sub
Ferdo，我修改了您的代码，因此它现在可以从 .xlsx 文件中读取数据并使用它来填充绘图上的文本框。现在我遇到了一些问题： 1. 我不得不停用绘制线条的代码，因为在 CATIA 对象的当前范围内出现重复声明错误。删除代码后，一切正常。你也许知道原因是什么？ 2. 我无法使用正常的 VBA 方法更改字体。当我添加在下面的代码中注释的行时，我得到一个错误：方法'打开？对象 'WorkBooks' 失败。 3. 即使关闭 Catia，我也无法打开 xlsx 文件。我认为这是因为宏打开文件但没有关闭它，我尝试在最后添加 close 方法，但我也不断出错。
代码：
Sub CATMain()
'Define the variables
Dim GetData As Range 'range for finding cells in workbook
Dim PartNum As String 'variable for search key
Dim MyPath As String 'variable for workbook file path
Dim MyWB As String 'variable for workbook file name
Dim Datum As Date
Dim FontSize1 As Double 'font text size
Dim FontSize2 As Double
Dim FontSize3 As Double
Dim FontName1 As Double
'The text for which to search
PartNum = InputBox(prompt:="Enter Filter Part Number", Title:="Filter Part Number")
'The path to the workbook
MyPath = "C:\New folder\"
'The name of the workbook in which to search.
MyWB = "Podatki.xlsx"
'Turn off screen updating, and then open the target workbook.
Application.ScreenUpdating = False
Workbooks.Open Filename:=MyPath & MyWB
'Search for specified text
Set GetData = ActiveSheet.Cells.Find(PartNum)
Dim CATIA As Object
Set CATIA = GetObject(, "CATIA.Application")
Dim MyDrawingDoc As DrawingDocument
Set MyDrawingDoc = CATIA.ActiveDocument
Dim MyDrawingSheets As DrawingSheets
Set MyDrawingSheets = MyDrawingDoc.Sheets
Dim MyDrawingSheet As DrawingSheet
Set MyDrawingSheet = MyDrawingSheets.ActiveSheet
Dim MyDrawingViews As DrawingViews
Set MyDrawingViews = MyDrawingSheet.Views
Dim drwviews As DrawingViews 'make background view active
Set drwviews = MyDrawingSheet.Views
drwviews.Item("Background View").Activate
'Set myText.... As DrawingText - adding texts
Set myText1 = MyDrawingViews.ActiveView.Texts.Add(GetData.Value, 376, 19)
Set myText2 = MyDrawingViews.ActiveView.Texts.Add(GetData.Offset(0, -1), 374, 24)
Set myText3 = MyDrawingViews.ActiveView.Texts.Add(GetData.Offset(0, 1), 376, 14)
Set myText4 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 34)
Set myText5 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 39)
Set myText6 = MyDrawingViews.ActiveView.Texts.Add(Date, 357, 44)
Set myText7 = MyDrawingViews.ActiveView.Texts.Add("Surname Name", 374, 44)
FontSize1 = 2.5
FontSize2 = 2
FONTNAME = "Arial (TrueType)" ''if I remember correctly, here is only Arial without TrueType
myText1.SetFontSize 0, 0, FontSize1
myText2.SetFontSize 0, 0, FontSize1
myText3.SetFontSize 0, 0, FontSize1
myText4.SetFontSize 0, 0, FontSize2
myText5.SetFontSize 0, 0, FontSize2
myText6.SetFontSize 0, 0, FontSize2
myText7.SetFontSize 0, 0, FontSize2
'myText1.SetFontName 0, 0, FontName1
'Workbooks(MyPath & MyWB).Close SaveChanges:=False
'Workbooks.Close Filename:=MyPath & MyWB
End Sub
同一件事不能声明两次，否则会出错。另一方面，你在哪里声明了Excel？像下面这样的东西？别忘了关闭 Excel 并检查你的代码，我对字体类型做了一些小的修改
' Open an Excel File from CATIA
Dim OutPath
Dim OutIndex
Dim wbk As Excel.Workbook
Dim xlApp As Excel.Application
OutPath = "C:\temp\"
OutIndex = "YourFile.xls"