Re: insert actocad drawings according to cordinates

[shamsam1]

hi

by mistake i closed the thread.

there is error message still in this line

iDWG.ModelSpace.InsertBlock pts, iBlock, 1#, 1#, 1#, 0#

i have create 3 layer in auto cad and named part1,part2,part3,then in this layer i have create 3 drawings, from vb i am calling the excel..i have attached the excel below

please guide me regarding this..


[VBA]
Dim AcadApp As AcadApplication, WrkBk As Workbook, WrkSh As Worksheet
Dim ExcelApp As Excel.Application, Dwg As AcadDocument, mI As Long
Dim Blk As String, X As Double, Y As Double
GetAcad AcadApp
OpenDWG AcadApp, "C:\Testing\Drawing1.dwg", Dwg
GetExcel ExcelApp
OpenXls ExcelApp, "C:\Testing\block.xls", WrkBk
ActivateSh1 WrkBk, WrkSh
mI = 5
While CStr(WrkSh.Cells(mI, 2).Value) <> "-"
Blk = CStr(WrkSh.Cells(mI, 2).Value)
X = CDbl(WrkSh.Cells(mI, 3).Value)
Y = CDbl(WrkSh.Cells(mI, 4).Value)
InsBlk Dwg, Blk, X, Y
mI = mI + 1
AcadApp.ZoomExtents
Wend
AcadApp.ZoomAll
End Sub
Sub InsBlk(iDWG As AcadDocument, iBlock As String, iX As Double, iy As Double)
Dim pts(0 To 2) As Double
pts(0) = iX: pts(1) = iy: pts(2) = 0
'iDWG.ModelSpace.InsertBlock pts, "C:\Testing\" & iBlock & ".dwg", 1#, 1#, 1#, 0#
iDWG.ModelSpace.InsertBlock pts, iBlock, 1#, 1#, 1#, 0#
End Sub
Sub OpenDWG(iAcadApp As AcadApplication, iDwgNm As String, ioDWG As AcadDocument)
Dim mI As Long, IsThere As Boolean
For mI = 0 To iAcadApp.Documents.Count - 1
If iAcadApp.Documents(mI).Name = Right(iDwgNm, Len(iDwgNm) - InStrRev(iDwgNm, "\")) Then
IsThere = True
Set ioDWG = iAcadApp.Documents(mI)
End If
Next
If Not IsThere Then
Set ioDWG = iAcadApp.Documents.Open(iDwgNm)
ioDWG.Activate
End If
End Sub
Sub ActivateSh1(ioWrkBk As Workbook, iActSht As Worksheet)
ioWrkBk.Worksheets("Sheet1").Activate
Set iActSht = ioWrkBk.Worksheets("Sheet1")
End Sub
Sub OpenXls(iXlApp As Excel.Application, iWrkBkNm As String, ioWrkBk As Workbook)
Dim mI As Long, IsThere As Boolean
For mI = 1 To iXlApp.Workbooks.Count
If iXlApp.Workbooks(mI).Name = Right(iWrkBkNm, InStrRev(iWrkBkNm, "\")) Then
IsThere = True
Set ioWrkBk = iXlApp.Workbooks(mI)
End If
Next
If Not IsThere Then
Set ioWrkBk = iXlApp.Workbooks.Open(iWrkBkNm)
End If
End Sub
Sub GetAcad(iAcadApp As AcadApplication)
On Error Resume Next
Set iAcadApp = GetObject(, "AutoCAD.Application")
If Err.Number > 0 Then
Err.Clear
Set iAcadApp = CreateObject("AutoCAD.Application")
End If
iAcadApp.Visible = True
On Error Goto 0
End Sub
Sub GetExcel(iExcelApp As Excel.Application)
On Error Resume Next
Set iExcelApp = GetObject(, "Excel.Application")
If Err.Number > 0 Then
Err.Clear
Set iExcelApp = CreateObject("Excel.Application")
End If
iExcelApp.Visible = True
On Error Goto 0

[/VBA]

[Tommy]

Hi Sam,

I reran this just to test it. With the code you posted. I placed all of the files in a directory called C:\testing (block.xls,drawing1.dwg,part1.dwg,part2.dwg and part3.dwg). Everything worked when I checked the references for excel and acad.

btw you can continue to post in the other thread. just because you marked it solved doesn't mean you can't post.

there is a zip file that I uploaded on the other thread for you to test with. remember that I have everything in the c:\testing folder