Text dotazu:
Poskládal jsem makro na generování kusovníku z různých fór. Výsledek snažení je v příloze.
To co jsem zatím nebyl schopen dodělat ani nikde najít je jak obarvit a změnit tlouštku ohraničení tabulky. Prosím pokud někdo ví ať napoví. Díky

makro:

Private Sub CommandButton1_Click()

  On Error Resume Next



'Declare Variables

    Dim oDocument As Document

    Dim oDrawingDoc As DrawingDocument

    Dim oDrawingSheets As DrawingSheets

    Dim oDrawingSheet As DrawingSheet

    Dim oDrawingViews As DrawingViews

    Dim oDrawingView As DrawingView

    Dim oDrawingTables As DrawingTables

    Dim oDrawingTable As DrawingTable

    Dim oBackgroundView As DrawingView

    Dim oProductDoc As ProductDocument

    Dim oProducts As Products

    Dim oProduct As Product

    Dim TempProduct As Product

    Dim QtyDict As Variant

    Dim Width As Integer

    Dim height As Integer

    Dim xOffSet As Integer

    Dim yOffSet As Integer

    Dim XOrig As Integer

    Dim YOrig As Integer

   



 

   

'Check that the ActiveDocument is a CATDrawing.

'If not, inform the user and terminate execution.



    Set oDocument = CATIA.ActiveDocument

   

    If Right(oDocument.FullName, 10) <> "CATDrawing" Then

        MsgBox "This utility must be executed from a within a CATDrawing."

        Exit Sub

    End If

   

'Populate the Variables

   

    

    

    'On Error GoTo SubError



    Set oDrawingDoc = CATIA.ActiveDocument

    Set oDrawingSheets = oDrawingDoc.Sheets

    Set oDrawingSheet = oDrawingSheets.ActiveSheet

    Set oDrawingViews = oDrawingSheet.Views

    Set oDrawingView = oDrawingViews.Item(3)

    Set oBackgroundView = oDrawingViews.Item("Background View")

    Set oDrawingTables = oBackgroundView.Tables

    Set oDrawingView = oDrawingViews.Item(3)

   

    Err.Clear

   

 'Check that the linked document is a product and not a part

   

    Set oProductDoc = oDrawingView.GenerativeLinks.FirstLink.Parent

    

   

    If Err.Number <> 0 Then

        MsgBox "The linked model is not a product!", vbExclamation

        Exit Sub

    End If

   

   

    Set oProducts = oProductDoc.Product.Products

    Set QtyDict = CreateObject("Scripting.Dictionary")

       

       

       

       

'get the sheet dimensions so that we can place the bom in the right

'place relative to the drawing border



    xOffSet = -12.7

    yOffSet = 319.7

    Width = oDrawingSheet.GetPaperWidth

    height = oDrawingSheet.GetPaperHeight

   

    XOrig = Width + xOffset

    YOrig = yOffset

   

   

'Scan through the Product Structure of the assembly noteing the quantity of

'Each component.  Add one of Each component to a list of the products for

'future use.

    Dim n As Integer

    Dim SourceText As String

    Dim ProductList(50) As Product

    Dim Index As Integer

    Index = 1

   

   For n = 1 To oProducts.Count

        Set TempProduct = oProducts.Item(n)

       

       

      

        If QtyDict.exists(TempProduct.PartNumber) = True Then

            QtyDict.Item(TempProduct.PartNumber) = QtyDict.Item(TempProduct.PartNumber) + 1

        Else

            QtyDict.Add TempProduct.PartNumber, 1

            Set ProductList(Index) = TempProduct

            Index = Index + 1

        End If

    Next n







'Check to see If a BOM hAs already been created on the Drawing.

'This code will be utilized when updates to the BOM are needed.

'If the BOM table already exists, skip to the code which will

'populate the BOM.

    For n = 1 To oDrawingTables.Count

        Set oDrawingTable = oDrawingTables.Item(n)

        If oDrawingTable.Name = "DrawingBOM" Then

            GoTo POPULATEBOM

        End If

    Next n



'If the table does not exist, create one and label it the same as

'the table name being searched for.



    Set oDrawingTable = oDrawingTables.Add(XOrig, YOrig, QtyDict.Count + 1, 5, 3, 5)

    oDrawingTable.Name = "DrawingBOM"

    oDrawingTable.AnchorPoint = CatTableBottomRight

    

    





'Populate the cells of the BOM Table

POPULATEBOM:

    

    Call oDrawingTable.SetCellString(oDrawingTable.NumberOfRows, 1, "ITEM")

                Call Dressup_Table_bot(oDrawingTable, oDrawingTable.NumberOfRows, 1, 1, 0)

                

    Call oDrawingTable.SetCellString(oDrawingTable.NumberOfRows, 2, "REQ")

                Call Dressup_Table_bot(oDrawingTable, oDrawingTable.NumberOfRows, 2, 1, 0)

    Call oDrawingTable.SetCellString(oDrawingTable.NumberOfRows, 3, "REV")

                Call Dressup_Table_bot(oDrawingTable, oDrawingTable.NumberOfRows, 3, 1, 0)

    Call oDrawingTable.SetCellString(oDrawingTable.NumberOfRows, 4, "PART NUMBER")

                Call Dressup_Table_bot(oDrawingTable, oDrawingTable.NumberOfRows, 4, 1, 0)

    Call oDrawingTable.SetCellString(oDrawingTable.NumberOfRows, 5, "DESCRIPTION")

                Call Dressup_Table_bot(oDrawingTable, oDrawingTable.NumberOfRows, 5, 1, 0)

   

   

    Call oDrawingTable.SetColumnSize(1, 12)

    Call oDrawingTable.SetColumnSize(2, 10)

    Call oDrawingTable.SetColumnSize(3, 10)

    Call oDrawingTable.SetColumnSize(4, 38)

    Call oDrawingTable.SetColumnSize(5, 57)

    Call oDrawingTable.SetRowSize(oDrawingTable.NumberOfRows, 10)

    





'Use the list created earlier in order to populate the information

'about Each part in the product structure.



    For n = 1 To (oDrawingTable.NumberOfRows - 1)

        

        Call oDrawingTable.SetCellString(n, 1, n + 0)

            Call Dressup_Table(oDrawingTable, n, 1, 1, 0)

        Call oDrawingTable.SetCellString(n, 2, QtyDict.Item(ProductList(n + 0).PartNumber))

            Call Dressup_Table(oDrawingTable, n, 2, 1, 0)

        Call oDrawingTable.SetCellString(n, 3, ProductList(n + 0).Revision)

            Call Dressup_Table(oDrawingTable, n, 3, 1, 0)

        Call oDrawingTable.SetCellString(n, 4, ProductList(n + 0).PartNumber)

            Call Dressup_Table(oDrawingTable, n, 4, 1, 0)

        Call oDrawingTable.SetCellString(n, 5, " " + ProductList(n + 0).Definition)

            Call Dressup_Table(oDrawingTable, n, 5, 2, 0)



       Next n

       

'SubError:

    'MsgBox "Failed ", vbCritical, "Stack-Up"

    

       

End Sub

   

Sub Dressup_Table(current_table As DrawingTable, ByVal line_number As Integer, ByVal column_number As Integer, ByVal type_justification As Integer, ByVal bold As Integer)





'-------------------------------

' sort out the justification

'-------------------------------

'

    If type_justification = 1 Then

        current_table.SetCellAlignment line_number, column_number, CatTableMiddleCenter

    ElseIf type_justification = 2 Then

        current_table.SetCellAlignment line_number, column_number, CatTableMiddleLeft

    End If

'

'--------------------------------------

' get the current text

'--------------------------------------

'

    Dim current_text As DrawingText

    Set current_text = current_table.GetCellObject(line_number, column_number)

    

'

'------------------------------------

' Set up the current text

'------------------------------------

'

    Dim oText As Integer

    oText = Len(current_text.Text)

'

' Font Arial

'

    current_text.SetFontName 1, oText, "Monospac821 BT"

'

' font height

'

    current_text.SetFontSize 1, oText, 3.5

    

'

' graphical attributes

'

 



    current_text.SetParameterOnSubString catBold, 1, oText, bold

    current_text.SetParameterOnSubString catUnderline, 1, oText, 0

    current_text.SetParameterOnSubString catItalic, 1, oText, 0

    current_text.SetParameterOnSubString catItalic, 1, oText, 0

    current_text.SetParameterOnSubString catOverline, 1, oText, 0

   

    

End Sub



'-----------------------------------------

' Table dress up For bottom of tabulation

'-----------------------------------------

Sub Dressup_Table_bot(current_table As DrawingTable, ByVal line_number As Integer, ByVal column_number As Integer, ByVal type_justification As Integer, ByVal bold As Integer)





'-------------------------------

' sort out the justification

'-------------------------------

'

    If type_justification = 1 Then

        current_table.SetCellAlignment line_number, column_number, CatTableMiddleCenter

    ElseIf type_justification = 2 Then

        current_table.SetCellAlignment line_number, column_number, CatTableMiddleLeft

    End If

'

'--------------------------------------

' get the current text

'--------------------------------------

'

    Dim current_text As DrawingText

    Set current_text = current_table.GetCellObject(line_number, column_number)

    

'

'------------------------------------

' Set up the current text

'------------------------------------

'

    Dim oText As Integer

    oText = Len(current_text.Text)

'

' Font Arial

'

    current_text.SetFontName 1, oText, "Monospac821 BT"

'

' font height

'

    current_text.SetFontSize 1, oText, 2.5

    

'

' graphical attributes

'



    Dim MyColor As Long

   

   'Encoded RGBA color within long integer (R=255 G=0   B=0   A=255)

    MyColor = -16000000

    current_text.SetParameterOnSubString catBold, 1, oText, bold

    current_text.SetParameterOnSubString catUnderline, 1, oText, 0

    current_text.SetParameterOnSubString catItalic, 1, oText, 0

    current_text.SetParameterOnSubString catItalic, 1, oText, 0

    current_text.SetParameterOnSubString catOverline, 1, oText, 0

    'current_text.SetParameterOnSubString catBold, 0, 0, 1

    current_text.SetParameterOnSubString catColor, 1, oText, MyColor

    

End Sub

Přiložené obrázky: