PDA

View Full Version : Re: insert actocad drawings according to cordinates



shamsam1
09-25-2008, 05:33 AM
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..



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

Tommy
09-25-2008, 05:56 AM
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