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
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