程式來自《AutoCAD資料庫連接》一書

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

 

 

 

 

 

創作者介紹
創作者 shadow 的頭像
shadow

資訊園

shadow 發表在 痞客邦 留言(0) 人氣()