批量插入CAD塊及标注（帶程式運作計時功能）

'說明：

'1、autocad 2010版本以下自帶VBA編輯器，2010版本以上需要自行下載下傳

'2、按住ALT+F11，打開vba編輯器，工具-引用，勾選microsoft excel library

'3、批量插入塊時，需要提前插入塊然後再删除，目的是讓系統知道塊的名字

'4、文字樣式需提前設定，設定成什麼樣式，插入時就是什麼樣式

'

'

'===============

Sub ExcelRead()

On Error Resume Next

Set ExcelApp = GetObject(, "excel.Application")

If Err Then

    Err.Clear

Set ExcelApp = CreateObject("excel.application")

    If Err Then

        MsgBox ("不能運作excel,檢查是否安裝了excel")

    Exit Sub

    End If

End If

ExcelApp.Workbooks.Open "e:\CADTOOLS\CAD.xlsx", , ReadOnly

ExcelApp.visible = false

Dim tim As Date

tim = Now()

Dim currlayer As AcadLayer

Set currlayer = ThisDrawing.Layers.Add("計量間")

ThisDrawing.ActiveLayer = currlayer

Dim pt1(0 To 2) As Double, pt2(0 To 2) As Double

Dim blockRefObj As AcadBlockReference

Dim i As Integer

i = 2

With ExcelApp.ActiveWorkbook.Worksheets("sheet1")

Do

Select Case .Range("A" & i)

Case "直線":

pt1(0) = .Range("B" & i)

pt1(1) = .Range("C" & i)

pt1(2) = 0

pt2(0) = .Range("D" & i)

pt2(1) = .Range("E" & i)

pt2(2) = 0

ThisDrawing.ModelSpace.AddLine pt1, pt2

Case "圓":

pt1(0) = .Range("c" & i)

pt1(1) = .Range("d" & i)

pt1(2) = 0

Set blockRefObj = ThisDrawing.ModelSpace.InsertBlock(pt1, "E:\CADTOOLS\cad塊\cyjs.dwg", 1#, 1#, 1#, 0)

blockRefObj.layer = ThisDrawing.ActiveLayer

Case Else:

Exit Do

End Select

i = i + 1

Loop

End With

'Set currlayer = ThisDrawing.Layers.Add("計量間注記") --如果标注和圖素不在一層時，可以添加一層新圖層

'ThisDrawing.ActiveLayer = currlayer

Dim textObj As AcadText

Dim textString As String

Dim height As Double

i = 2

With ExcelApp.ActiveWorkbook.Worksheets("sheet1")

Do

Select Case .Range("A" & i)

Case "直線":

pt1(0) = .Range("B" & i)

pt1(1) = .Range("C" & i)

pt1(2) = 0

pt2(0) = .Range("D" & i)

pt2(1) = .Range("E" & i)

pt2(2) = 0

ThisDrawing.ModelSpace.AddLine pt1, pt2

Case "圓":

textString = .Range("b" & i)

pt1(0) = .Range("c" & i) + 30

pt1(1) = .Range("d" & i) + 30

pt1(2) = 0

height = 30

Set textObj = ThisDrawing.ModelSpace.AddText(textString, pt1, height)

textObj.color = acRed

Case Else:

Exit Do

End Select

i = i + 1

Loop

End With

ExcelApp.Workbooks.Close

ExcelApp.Quit

ThisDrawing.Application.Update

ZoomExtents

MsgBox "耗時：" & Format(Now() - tim, "hh:mm:ss")

End Sub