关于VBA对块进行缩放的问题,请达人们指点一下

42272846

刚学CAD编程,希望实现以下功能:

构造选择集,从屏幕选择区域种筛选出块来放入选择集,遍历选择集,对选择集里面的块根据块名进行缩放,(每一个块名缩放比例固定),

希望达人们指点一下,谢谢了.

xinghesnak

Sub main()
Dim sel As AcadSelectionSet
On Error Resume Next
Set sel = ThisDrawing.SelectionSets.Item("Temp")
If Err Then
    On Error GoTo 0
    Set sel = ThisDrawing.SelectionSets.Add("Temp")
End If
Dim filterType(0) As Integer, filterData(0) As Variant
filterType(0) = 100: filterData(0) = "AcDbBlockReference"
sel.SelectOnScreen filterType, filterData

Dim BlockRef As AcadBlockReference
Dim BasePoint
Dim ScaleFactory As Double
ScaleFactory = 0.8
For i = 0 To sel.Count - 1
    Set BlockRef = sel.Item(i)
    If BlockRef.Name = "asdfa" Then
        BasePoint = BlockRef.InsertionPoint
        BlockRef.ScaleEntity BasePoint, ScaleFactory
    End If
Next
End Sub

42272846

谢谢了,通过你帮助,我写了如下过程,

Private Sub CommandButton1_Click()

On Error Resume Next
    Dim BlkRef As AcadBlockReference
    Dim BlkName As String
    ' 创建空白选择集
    Dim SS As AcadSelectionSet
    Set SS = CreatSSet
    Form_SuoFang.Hide
    ' 设置过滤条件，将所有同名的块过滤出来
    Dim FilterType As Variant
    Dim FilterData As Variant
    Dim FType(1) As Integer
    Dim FData(1) As Variant
    FType(0) = 0
    FData(0) = "insert" '图元名
    FType(1) = 66
    FData(1) = 0  '不带属性
    FilterType = FType
    FilterData = FData
    SS.SelectOnScreen FilterType, FilterData
   
    Dim i As Integer
    Dim j As Integer
    Dim Blk As AcadBlock
    If SS.Count = 0 Then
        MsgBox "该区域内该块总数为零,请重新选择区域", vbExclamation, "错误"
        Exit Sub
    End If
        ' 遍历选择集中的块
    For i = 0 To SS.Count - 1
        Set BlkRef = SS(i)
    BlkName = BlkRef.Name
    If CheckBox2.Value = True Then
        SQLSTR = "select * from 放大倍率表 where 块名='" & BlkName & "'"
        Set ADORSTemp = Nothing
        ADORSTemp.Open SQLSTR, ADOConnection, adOpenKeyset, adLockOptimistic
            If ADORSTemp.RecordCount > 0 Then
            BLX = ADORSTemp.Fields("倍率X").Value
            BLY = ADORSTemp.Fields("倍率Y").Value
            BLZ = ADORSTemp.Fields("倍率Z").Value
            Else
            BLX = 1
            BLY = 1
            BLZ = 1
            End If
        Else
        If BlkName = ComboBox1.Text Then
            BLX = TextBox1.Text
            BLY = TextBox2.Text
            BLZ = TextBox3.Text
        Else
            BLX = 1
            BLY = 1
            BLZ = 1
        End If
    End If
    BlkRef.XScaleFactor = BLX
    BlkRef.YScaleFactor = BLY
    BlkRef.ZScaleFactor = BLZ 

   Next
    MsgBox "放大成功!!!", vbExclamation, "提示"
End Sub