今天為了想要分離哪些圖層及圖塊是外部參考帶進來的,搞了好幾個小時就是找不到有外部參考這個物件,想想要是有個外部參考物件那麼不是很簡單嗎?但是翻遍說明與 google 就是沒有,其實也不敢說是 google 找不到,就是英文能力太差了,大多時候都是有看沒有懂。
於是後來的解決辦法就是先找出所有外部參考的名稱在去一一跟圖層與圖塊做比較。
Dim xblk As AcadBlock
For Each xblk In ThisDrawing.Blocks
If xblk.IsXRef Then Debug.Print xblk.Name
Next
AutoCad VBA
本網誌將提供一些 AutoCad 的物件、屬性、方法、事件的說明,並會提供一些範例,所有的文章來源將會參考到 AutoCad 說明或網路上的文章,如有侵權事宜請寄 E-Mail 告知或留言在文章的意見內告知,本人知悉後將會立刻刪除該篇文章。
2013年1月29日 星期二
2009年1月22日 星期四
圖塊的數量檢視與修改名稱
'自訂表單 Userform 最少需要 Listbox1、TextBox1、TextBox2、CommandButton1、CommandButton2、Label3 等控制項 Option Explicit Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Private BlksName() As String Private cadobj As AcadEntity '修改圖塊名稱,並重讀圖面內的所有圖塊名稱 Private Sub CommandButton1_Click() On Error GoTo 1 ThisDrawing.Blocks(TextBox1.Text).Name = TextBox2.Text On Error GoTo 0 ListBox1.Clear GetAllBlocks TextBox1.Text = "" TextBox2.Text = "" Exit Sub 1: MsgBox Err.Description Err.Clear End Sub '結束表單 Private Sub CommandButton2_Click() If Not cadobj Is Nothing Then cadobj.Highlight False Unload Me End Sub '檢視與計算選擇的圖塊 Private Sub ListBox1_Click() TextBox1.Text = ListBox1.Text ZoomAll ''''''建立選擇集並選擇圖面上的所有元件'''''''''' Dim FilterSet As AcadSelectionSet On Error Resume Next ThisDrawing.SelectionSets("xxx").Delete On Error GoTo 0 Set FilterSet = ThisDrawing.SelectionSets.Add("xxx") '設定選擇集的過濾條件 Dim FilterType(0) As Integer Dim FilterData(0) As Variant FilterType(0) = 2 FilterData(0) = ListBox1.Text '選擇圖面上的所有元件 FilterSet.Select acSelectionSetAll, , , FilterType, FilterData Label3.Caption = "名稱:" & ListBox1.Text & Chr(13) & _ "總數:" & FilterSet.Count & " 個" '沒有任何元件時直接離開巨集 If FilterSet.Count = 0 Then Set FilterSet = Nothing Exit Sub End If If Not cadobj Is Nothing Then cadobj.Highlight False Set cadobj = FilterSet.Item(0) cadobj.Highlight True Dim minExt As Variant Dim maxExt As Variant On Error GoTo 1 cadobj.GetBoundingBox minExt, maxExt ZoomWindow minExt, maxExt Dim i As Integer For i = 10 To 5 Step -1 ZoomScaled scale:=i * 0.1, scaletype:=acZoomScaledRelative Sleep 50 Next i 1: End Sub Private Sub UserForm_Initialize() Me.Caption = "圖塊名稱修改 --- WenHe" Label3.Caption = "請選擇圖塊名稱。" GetAllBlocks End Sub '讀取圖面內所有的圖塊名稱 Private Sub GetAllBlocks() Dim blk As AcadBlock Dim k As Integer ReDim BlksName(0) As String k = 0 For Each blk In ThisDrawing.Blocks If Left(blk.Name, 1) <> "*" Then ReDim Preserve BlksName(0 To k) As String BlksName(k) = blk.Name k = k + 1 End If Next SortStringArray BlksName ListBox1.List() = BlksName End Sub ''''''''''排序字串陣列,限一維陣列、限陣列內資料不重複 Private Sub SortStringArray(ByRef strarray() As String) Dim strarray2() As String Dim i As Integer, j As Integer Dim k As Integer strarray2 = strarray For i = 0 To UBound(strarray2) k = 0 For j = 0 To UBound(strarray2) If i <> j Then k = k + IIf(StrComp(strarray2(i), strarray2(j)) > 0, 1, 0) End If Next j strarray(k) = strarray2(i) Next i End Sub |
2008年12月9日 星期二
將標註的測量值傳送到 Excel 活頁簿內
'執行下列的巨集會要求選取圖面上的物件,選完後會將「線性標註」及「對齊式標註」的測量值傳到一個新的 Excel 活頁簿內。 Sub SendDIM2Excel() Dim ssel As AcadSelectionSet Dim ett As AcadEntity Dim FilterType(0) As Integer Dim FilterData(0) As Variant FilterType(0) = 0 FilterData(0) = "DIMENSION" On Error Resume Next ThisDrawing.SelectionSets("Test").Delete On Error GoTo 0 Set ssel = ThisDrawing.SelectionSets.Add("Test") ssel.SelectOnScreen FilterType, FilterData If ssel.Count > 0 Then Dim xlapp As Object Dim xlbook As Object Dim rng As Object Set xlapp = CreateObject("Excel.Application") Set xlbook = xlapp.Workbooks.Add xlapp.Visible = True For Each ett In ssel If ett.ObjectName = "AcDbAlignedDimension" Or ett.ObjectName = "AcDbRotatedDimension" Then Set rng = xlbook.Sheets(1).Range("A65536").End(-4162).Offset(1, 0) rng = ett.ObjectName rng.Offset(0, 1) = ett.Measurement End If Next Set xlapp = Nothing Set xlbook = Nothing Set rng = Nothing End If ssel.Delete Set ssel = Nothing Set ett = Nothing End Sub |
2008年11月22日 星期六
方法 AddItems 範例
本範例會建立一個名稱為 TEST_SELECTIONSET 的選集,並在模型空間內劃上幾個元件,然後將模型空間內的所有元件都加入到選集內。 選集的名稱不可以重複,它在關閉檔案後就會自動消失,下次再開啟檔案時也不會存在。 Sub Example_AddItems() ' 建立一個名稱為 TEST_SELECTIONSET 的選集 Dim ssetObj As AcadSelectionSet Set ssetObj = ThisDrawing.SelectionSets.Add("TEST_SELECTIONSET") ' 模型空間內畫一個射線元件 Dim rayObj As AcadRay Dim basePoint(0 To 2) As Double Dim SecondPoint(0 To 2) As Double basePoint(0) = 3#: basePoint(1) = 3#: basePoint(2) = 0# SecondPoint(0) = 1#: SecondPoint(1) = 3#: SecondPoint(2) = 0# Set rayObj = ThisDrawing.ModelSpace.AddRay(basePoint, SecondPoint) ' 模型空間內畫一個聚合線元件 Dim plineObj As AcadLWPolyline Dim points(0 To 5) As Double points(0) = 3: points(1) = 7 points(2) = 9: points(3) = 2 points(4) = 3: points(5) = 5 Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points) plineObj.Closed = True ' 模型空間內畫一線元件 Dim lineObj As AcadLine Dim startPoint(0 To 2) As Double Dim endPoint(0 To 2) As Double startPoint(0) = 0: startPoint(1) = 0: startPoint(2) = 0 endPoint(0) = 2: endPoint(1) = 2: endPoint(2) = 0 Set lineObj = ThisDrawing.ModelSpace.AddLine(startPoint, endPoint) ' 模型空間內畫一個圓元件 Dim circObj As AcadCircle Dim centerPt(0 To 2) As Double Dim radius As Double centerPt(0) = 20: centerPt(1) = 30: centerPt(2) = 0 radius = 3 Set circObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius) ' 模型空間內畫一個橢圓元件 Dim ellObj As AcadEllipse Dim majAxis(0 To 2) As Double Dim center(0 To 2) As Double Dim radRatio As Double center(0) = 5#: center(1) = 5#: center(2) = 0# majAxis(0) = 10: majAxis(1) = 20#: majAxis(2) = 0# radRatio = 0.3 Set ellObj = ThisDrawing.ModelSpace.AddEllipse(center, majAxis, radRatio) '縮放全部 ZoomAll ' 模型空間內的所有元件全部收集到陣列內。 ReDim ssobjs(0 To ThisDrawing.ModelSpace.Count - 1) As AcadEntity Dim I As Integer For I = 0 To ThisDrawing.ModelSpace.Count - 1 Set ssobjs(I) = ThisDrawing.ModelSpace.Item(I) Next ' 將陣列內的所有元件加入到選集內。 ssetObj.AddItems ssobjs ' 重生目前視埠。 ThisDrawing.Regen acActiveViewport End Sub |
2008年11月21日 星期五
方法 IntersectWith 範例
Sub Example_IntersectWith() ' 本範例會先在圖面上畫一條線及一個圓,然後顯示出兩個元件的交叉點 '宣告線所需的變數 Dim lineObj As AcadLine Dim startPt(0 To 2) As Double Dim endPt(0 To 2) As Double '指定線的起始點 startPt(0) = 1: startPt(1) = 1: startPt(2) = 0 '指定線的結束點 endPt(0) = 10: endPt(1) = 10: endPt(2) = 0 '在圖面上畫線 Set lineObj = ThisDrawing.ModelSpace.AddLine(startPt, endPt) '宣告圓所需的變數 Dim circleObj As AcadCircle Dim centerPt(0 To 2) As Double Dim radius As Double '指定圓的中心點 centerPt(0) = 5: centerPt(1) = 5: centerPt(2) = 0 '指定圓的半徑 radius = 1 '在圖面上畫圓 Set circleObj = ThisDrawing.ModelSpace.AddCircle(centerPt, radius) '縮放實際範圍 ZoomExtents Dim intPoints As Variant '找出線與圓的交叉點 'acExtendNone 意思為是不延伸元件 intPoints = lineObj.IntersectWith(circleObj, acExtendNone) Dim I As Integer, j As Integer, k As Integer Dim str As String '如果兩個元件沒有交叉則變數 intPoints 將會未被初始化 If VarType(intPoints) <> vbEmpty Then For I = LBound(intPoints) To UBound(intPoints) str = "Intersection Point[" & k & "] is: " & intPoints(j) & "," _ & intPoints(j + 1) & "," & intPoints(j + 2) MsgBox str, , "IntersectWith Example" str = "" I = I + 2 j = j + 3 k = k + 1 Next End If End Sub |
訂閱:
文章 (Atom)