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

42272846 发表于 2006-3-15 14:04:00

刚学CAD编程,希望实现以下功能:
构造选择集,从屏幕选择区域种筛选出块来放入选择集,遍历选择集,对选择集里面的块根据块名进行缩放,(每一个块名缩放比例固定),
希望达人们指点一下,谢谢了.

xinghesnak 发表于 2006-3-16 08:15:00

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 发表于 2006-3-16 21:45:00

谢谢了,通过你帮助,我写了如下过程,
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

页: [1]

明经CAD社区's Archiver

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