自由手記

Sub CreatCircles()
    Dim newCircle As AutoCAD.AcadCircle
    Dim cen(0 To 2) As Double
    Dim rad As Double
    For i = 1 To 20
        cen(0) = Rnd * 100
        cen(1) = Rnd * 100
        cen(2) = 0#
        rad = Rnd * 20
        Set newCircle = ThisDrawing.ModelSpace.AddCircle(cen, rad)
        newCircle.color = Int(Rnd * 7) + 1
        Next
        ThisDrawing.Application.ZoomExtents
        
End Sub
Sub WriteCirclesToDatabase()

    On Error Resume Next
    Dim CircleSelection As AutoCAD.AcadSelectionSet
    Dim circleObject As AutoCAD.AcadCircle
    Dim groupCode(0) As Integer
    Dim dataValue(0) As Variant
    
    Dim wsPath As String, conString As String
    Dim db As New ADODB.Connection
    Dim circlesRS As New ADODB.Recordset
    
    
    wsPath = ThisDrawing.Application.Preferences.Files.WorkspacePath
    conString = "File Name=" & wsPath & "\circles.udl"
    db.Open conString
    If Err <> 0 Then
        MsgBox "Could not open circles.udl"
        MsgBox conString
        Exit Sub
    End If
    
    circlesRS.Open "CIRCLES", db, adOpenDynamic, adLockOptimistic
    
    If Err <> 0 Then
        MsgBox "Could not open circles recordset"
        Exit Sub
    End If
    
    If Not circlesRS.Supports(adAddNew) Then
        MsgBox "Cannot add records to recordst."
        Exit Sub
    End If
    
    Set CircleSelection = ThisDrawing.SelectionSets("Circles")
    If Err <> 0 Then
        Set CircleSelection = ThisDrawing.SelectionSets.Add("Circles")
        
    End If
    
    groupCode(0) = 0
    dataValue(0) = "Circle"
    CircleSelection.Clear
    CircleSelection.Select acSelectionSetAll, , , groupCode, dataValue
    
    For Each circleObject In CircleSelection
        circlesRS.AddNew
        circlesRS!Handle = circleObject.Handle
        circlesRS!Center_X = circleObject.Center(0)
        circlesRS!Center_Y = circleObject.Center(1)
        circlesRS!Radius = circleObject.Radius
        circlesRS!color = circleObject.color
        circlesRS.Update
        Next
    circlesRS.Close
    db.Close
    'CircleSelection.Clear
    'CircleSelection.Erase
    'CircleSelection.Delete
End Sub

Sub ModifyCirclesFromDatabase()
    On Error Resume Next
    Dim circleObject As AutoCAD.AcadCircle
    Dim cen(0 To 2) As Double
    Dim rad As Double
    
    Dim wsPath As String, conString As String
    Dim db As New ADODB.Connection
    Dim circlesRS As New ADODB.Recordset
    
    
    wsPath = ThisDrawing.Application.Preferences.Files.WorkspacePath
    conString = "File Name=" & wsPath & "\circles.udl"
    db.Open conString
    If Err <> 0 Then
        MsgBox "Could not open circles.udl."
        Exit Sub
    End If
    
    circlesRS.Open "CIRCLES", db, adOpenDynamic, adLockOptimistic
    If Err <> 0 Then
        MsgBox "Could not open circles recordset"
        Exit Sub
    End If
    
    While Not circlesRS.EOF
        cen(0) = circlesRS!Center_X
        cen(1) = circlesRS!Center_Y
        cen(2) = 0#
    Err.Clear
    Set circleObject = ThisDrawing.HandleToObject(circleRS!Handle)
    If Err = 0 Then
        circleObject.Center = cen
        circleObject.Radius = circlesRS!Radius
        circleObject.color = circlesRS!color
        circleObject.Update
    Else
        rad = circlesRS!Radius
        Set circleObject = ThisDrawing.ModelSpace.AddCircle(cen, rad)
        circleObject.color = circlesRS!color
        circlesRS!Handle = circleObject!Handle
        circlesRS.Update
    End If
    
    circlesRS.MoveNext
    
    Wend
    
    circlesRS.Close
    db.Close
     
    
End Sub

Sub ModifyDatabaseFromCircles()
    On Error Resume Next
    Dim CircleSelection As AutoCAD.AcadSelectionSet
    Dim circleObject As AutoCAD.AcadCircle
    Dim groupCode(0) As Integer
    Dim dataValue(0) As Variant
    Dim db As New ADODB.Connection
    Dim circlesRS As New ADODB.Recordset
    
     wsPath = ThisDrawing.Application.Preferences.Files.WorkspacePath
    conString = "File Name=" & wsPath & "\circles.udl"
    db.Open conString
    If Err <> 0 Then
        MsgBox "Could not open circles.udl."
        Exit Sub
    End If
    
    circlesRS.Open "CIRCLES", db, adOpenDynamic, adLockOptimistic
    If Err <> 0 Then
        MsgBox "Could not open circles recordset"
        Exit Sub
    End If
    
    If Not circlesRS.Supports(adUpdate) Then
        MsgBox "canot update the recordset"
        Exit Sub
    End If
    
    Set CircleSelection = ThisDrawing.SelectionSets("Circles")
    If Err <> 0 Then
    Set CircleSelection = ThisDrawing.SelectionSets.Add("Circles")
    End If
    
    groupCode(0) = 0
    dataValue(0) = "Circle"
    CircleSelection.Clear
    CircleSelection.Select acSelectionSetAll, , , groupCode, dataValue
    
    For Each circleObject In CircleSelection
        circlesRS.Find "HANDLE='" & circleObject.Handle & "'", , , adBookmarkFirst
        
        If circlesRS.EOF Then
            circlesRS.AddNew
        End If
        
        circlesRS!Handle = circleObject.Handle
        circlesRS!Center_X = circleObject.Center(0)
        circlesRS!Center_Y = circleObject.Center(1)
        circlesRS!Radius = circleObject.Radius
        circlesRS!color = circleObject.color
        
        circlesRS.Update
        
        Next
        
        circlesRS.Close
        db.Close
       
End Sub