またまたChatGPTがやってくれた！すげーよ！マジ神！
指定した場所に半径300の球を一瞬で描いた。
最初は失敗したかな？と思ったが３D表示に変えると、金属光沢のある球ができていた。
Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry
Imports Autodesk.AutoCAD.Runtime
Public Class Class1
<CommandMethod("SPHERE")>
Public Sub DrawSphere()
' ダイアログを表示して中心点を取得
Dim dialogResult As PromptPointResult = GetPoint("Specify center point: ")
If dialogResult.Status <> PromptStatus.OK Then
Exit Sub
End If
Dim centerPoint As Point3d = dialogResult.Value
' 半径300の球を描画
DrawSphere(centerPoint, 300)
End Sub
Private Function GetPoint(message As String) As PromptPointResult
Dim editor As Editor = Application.DocumentManager.MdiActiveDocument.Editor
Dim promptOptions As PromptPointOptions = New PromptPointOptions(message)
Dim pointResult As PromptPointResult = editor.GetPoint(promptOptions)
Return pointResult
End Function
Private Sub DrawSphere(centerPoint As Point3d, radius As Double)
Dim doc As Document = Application.DocumentManager.MdiActiveDocument
Dim db As Database = doc.Database
Using trans As Transaction = db.TransactionManager.StartTransaction()
Try
' ブロックテーブルとブロックテーブルレコードを開く
Dim bt As BlockTable = trans.GetObject(db.BlockTableId, OpenMode.ForRead)
Dim btr As BlockTableRecord = CType(trans.GetObject(bt(BlockTableRecord.ModelSpace), OpenMode.ForWrite), BlockTableRecord)
' 半径300の球を作成
Dim sphere As Solid3d = New Solid3d()
sphere.CreateSphere(radius)
sphere.TransformBy(Matrix3d.Displacement(centerPoint.GetAsVector()))
btr.AppendEntity(sphere)
trans.AddNewlyCreatedDBObject(sphere, True)
trans.Commit()
Catch ex As Exception
Application.ShowAlertDialog("Error: " & ex.Message)
trans.Abort()
End Try
End Using
End Sub
End Class
