> KyCOK
Не помню где это скачал, пробуй
Option Explicit
Public Sub TableStyleCreate(styleName As String, txtStyleName As String, _
txtHeight As Double)
'' author unknown
Dim oDict As AcadDictionary
Dim oStyle As AcadTableStyle
Set oDict = ThisDrawing.Dictionaries("Acad_TableStyle")
On Error Resume Next
Set oStyle = oDict(styleName)
If Err.Number <> 0 Then
Set oStyle = oDict.AddObject(styleName, "AcDbTableStyle")
Err.Clear
End If
On Error GoTo Handler
If Not oStyle Is Nothing Then
Dim col As New AcadAcCmColor
col.SetRGB 240, 100, 40
With oStyle
.Description = "New Table"
.FlowDirection = acTableTopToBottom
.BitFlags = 0
.VertCellMargin = txtHeight / 4
.HorzCellMargin = txtHeight / 4
.SetTextStyle acTitleRow, txtStyleName
.SetTextStyle acHeaderRow, txtStyleName
.SetTextStyle acDataRow, txtStyleName
.SetTextHeight acTitleRow, txtHeight * 1.5
.SetTextHeight acHeaderRow, txtHeight * 1.25
.SetTextHeight acDataRow, txtHeight
.SetAlignment acTitleRow, acBottomCenter
.SetAlignment acHeaderRow, acBottomCenter
.SetAlignment acDataRow, acBottomLeft
.SetGridColor 1, acTitleRow, col
col.SetRGB 225, 100, 50
.SetGridColor 1, acHeaderRow, col
col.SetRGB 10, 100, 25
.SetGridColor 7, acDataRow, col
.SetDataType acTitleRow, acString, acUnitless
.SetDataType acHeaderRow, acString, acUnitless
.SetDataType acDataRow, acString, acUnitless
ThisDrawing.SetVariable "CTABLESTYLE", .Name
End With
End If
Exit Sub
Handler:
If Err.Number <> 0 Then
MsgBox Err.Number & " " & Err.Description
Err.Clear
End If
Resume Next
End Sub
Sub test()
TableStyleCreate "New Table Style", "Standard", 250#
End Sub
~'J'~