On Error Resume Next Set acadApp = Nothing Set acadApp = GetObject(, "AutoCAD.Application") acadApp.Visible = True If Err Then MsgBox "未检测到打开的CAD图形! ", 64, Space(22) & "提 醒": Exit Sub Set cadDoc = acadApp.ActiveDocument With cadDoc .Application.WindowState = 3: Set MoSpace = .ModelSpace: Set Auti = .Utility End With Set MYSpace = cadDoc.ModelSpace Set mytxt = cadDoc.TextStyles.Add("Standard") With mytxt: .SetFont "宋体", False, False, 0, 0: .width = 1: End With '文字宽高比 cadDoc.ActiveTextStyle = mytxt Dim Gnt(2) As Double, Hnt(13) As Double, HT As Object, ot(0) As Object Gnt(0) = 0: Gnt(1) = 0: Gnt(2) = 0 Set GCBZ = cadDoc.Blocks.Add(Gnt, "*U") '匿名块高程标志 Hnt(0) = 0: Hnt(1) = 桩位直径 / 2 Hnt(2) = 0.035: Hnt(3) = 桩位直径 / 2 - 0.25 Hnt(4) = 0.01: Hnt(5) = 桩位直径 / 2 - 0.25 Hnt(6) = 0.01: Hnt(7) = 0 Hnt(8) = -0.01: Hnt(9) = 0 Hnt(10) = -0.01: Hnt(11) = 桩位直径 / 2 - 0.25 Hnt(12) = -0.035: Hnt(13) = 桩位直径 / 2 - 0.25 Set obj = MoSpace.AddLightWeightPolyline(Hnt): obj.Closed = True '闭合块 Set HT = GCBZ.AddHatch(0, "SOLID", True) '向匿名图块添加图案,0-acHatchObject,SOLID-图案(颜色)名称 Set ot(0) = obj With HT: .AppendOuterLoop (ot): .Color = 256: End With '块颜色随层(☆此句不能少!) obj.Delete 转换为VB.NET

Dim acadApp As Object = Nothing
Dim cadDoc As Object = Nothing
Dim MoSpace As Object = Nothing
Dim Auti As Object = Nothing
Dim MYSpace As Object = Nothing
Dim mytxt As Object = Nothing
Dim GCBZ As Object = Nothing
Dim obj As Object = Nothing
Dim HT As Object = Nothing
Dim ot(0) As Object

On Error Resume Next

acadApp = GetObject(, "AutoCAD.Application")
acadApp.Visible = True

If Err.Number <> 0 Then
MsgBox("未检测到打开的CAD图形! ", 64, Space(22) & "提 醒")
Exit Sub
End If

cadDoc = acadApp.ActiveDocument

With cadDoc
.Application.WindowState = 3
MoSpace = .ModelSpace
Auti = .Utility
End With

MYSpace = cadDoc.ModelSpace
mytxt = cadDoc.TextStyles.Add("Standard")

With mytxt
.SetFont("宋体", False, False, 0, 0)
.width = 1
End With

cadDoc.ActiveTextStyle = mytxt

Dim Gnt(2) As Double
Dim Hnt(13) As Double

Gnt(0) = 0
Gnt(1) = 0
Gnt(2) = 0

GCBZ = cadDoc.Blocks.Add(Gnt, "*U")

Hnt(0) = 0
Hnt(1) = 桩位直径 / 2
Hnt(2) = 0.035
Hnt(3) = 桩位直径 / 2 - 0.25
Hnt(4) = 0.01
Hnt(5) = 桩位直径 / 2 - 0.25
Hnt(6) = 0.01
Hnt(7) = 0
Hnt(8) = -0.01
Hnt(9) = 0
Hnt(10) = -0.01
Hnt(11) = 桩位直径 / 2 - 0.25
Hnt(12) = -0.035
Hnt(13) = 桩位直径 / 2 - 0.25

obj = MoSpace.AddLightWeightPolyline(Hnt)
obj.Closed = True

HT = GCBZ.AddHatch(0, "SOLID", True)

ot(0) = obj

With HT
.AppendOuterLoop(ot)
.Color = 256
End With

obj.Delete