Excelden Autocad'e veri aktarma

Excelden autocada antet verileri aktarmak için aşağı da ki kodları kullanabilirsiniz.

Private Type ScaleFactor

X As Double

Y As Double

Z As Double

End Type

Public Sub Antet()

Dim acadApp As Object

Dim height As Double

Dim acadDoc As Object

Dim acadBlock As Object

Dim attributeObj As Object

Dim i As Long

Dim insertionPoint(0 To 2) As Double

Dim BlockName As String

Dim BlockScale As ScaleFactor

Dim RotationAngle As Double

Dim myxl

Dim InsPnt As Variant

Dim zoom1(0 To 2) As Double

Dim zoom2(0 To 2) As Double

Dim InsPnti(0 To 2) As Double

Dim InsPntj(0 To 2) As Double

Dim InsPnt0(0 To 2) As Double

Dim InsPnt1(0 To 2) As Double

YK = 2000

ThisDrawing.ActiveSpace = acModelSpace

Dimscale = ThisDrawing.GetVariable("DIMSCALE")

InsPnt = ThisDrawing.Utility.GetPoint(, "Select an insertion point")

Set myxl = GetObject("D:\wix-site\antetyazma.xlsx")

myxl.Application.Sheets("Proje").Select

myxl.Application.Sheets("Proje").Range("e1").Select

myxl.Application.Sheets("Proje").Activate

Set Lastrow = myxl.Application.Sheets("Proje").Cells(myxl.Application.Sheets("Proje").Rows.Count, "E").End(xlUp).Rows

'Activate the Proje sheet and find the last row.

' With Sheets("Proje")

' .Activate

' LastRow = .Cells(.Rows.Count, "E").End(xlUp).Rows

' End With

'Check if there are Proje for at least one circle.

If Lastrow < 1 Then

MsgBox "There are no Proje for the insertion point!", vbCritical, "Insertion Point Error"

Exit Sub

End If

'Check if AutoCAD application is open. If is not opened create a new instance and make it visible.

On Error Resume Next

Set acadApp = GetObject(, "AutoCAD.Application")

If acadApp Is Nothing Then

Set acadApp = CreateObject("AutoCAD.Application")

acadApp.Visible = True

End If

'Check (again) if there is an AutoCAD object.

If acadApp Is Nothing Then

MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"

Exit Sub

End If

On Error GoTo 0

'If there is no active drawing create a new one.

On Error Resume Next

Set acadDoc = acadApp.ActiveDocument

If acadDoc Is Nothing Then

Set acadDoc = acadApp.Documents.Add

End If

On Error GoTo 0

'Check if the active space is paper space and change it to model space.

If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding

acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding

End If

On Error Resume Next

'Loop through all the rows and add the corresponding blocks in AutoCAD.

With Sheets("Proje")

For i = 2 To Lastrow + 1

InsPnti(0) = InsPnt(0)

InsPnti(1) = InsPnt(1)

InsPnti(2) = 0

Blkname19 = "ANTET_2016"

Set Blkref = ThisDrawing.ModelSpace.InsertBlock(InsPnti, Blkname19, Dimscale, Dimscale, Dimscale, 0)

On Error Resume Next

'Set the block name.

BlockName = "ANTET_2016_YAZ_AKILLI"

'If the block name is not empty, insert the block.

If BlockName <> vbNullString Then

'Set the insertion point.

insertionPoint(0) = InsPnti(0)

insertionPoint(1) = InsPnti(1)

insertionPoint(2) = InsPnti(2)

'Initialize the optional parameters.

BlockScale.X = 1

BlockScale.Y = 1

BlockScale.Z = 1

RotationAngle = 0

'Add the block using the sheet data (insertion point, block name, scale factors and rotation angle).

'The 0.0174532925 is to convert degrees into radians.

Set acadBlock = acadDoc.ModelSpace.InsertBlock(insertionPoint, BlockName, _

BlockScale.X, BlockScale.Y, BlockScale.Z, RotationAngle * 0.0174532925)

' Get the attributes for the block reference

Dim varAttributes As Variant

varAttributes = acadBlock.GetAttributes

' Move the attribute tags and values into a string to be displayed in a Msgbox

Dim strAttributes As String

Dim k As Integer

For k = LBound(varAttributes) To UBound(varAttributes)

strAttributes = strAttributes & vbLf & " Tag: " & varAttributes(i).TagString & _

vbLf & " Value: " & varAttributes(i).TextString & vbLf & " "

Next

' Change the value of the attribute

' Note: There is no SetAttributes. Once you have the variant array, you have the objects.

' Changing them changes the objects in the drawing.

varAttributes(0).TextString = myxl.Application.Sheets("Proje").Cells(i, 19).Value

varAttributes(1).TextString = myxl.Application.Sheets("Proje").Cells(i, 18).Value

varAttributes(2).TextString = myxl.Application.Sheets("Proje").Cells(i, 17).Value

varAttributes(3).TextString = myxl.Application.Sheets("Proje").Cells(i, 16).Value

varAttributes(4).TextString = myxl.Application.Sheets("Proje").Cells(i, 15).Value

varAttributes(5).TextString = myxl.Application.Sheets("Proje").Cells(i, 14).Value

varAttributes(6).TextString = myxl.Application.Sheets("Proje").Cells(i, 13).Value

varAttributes(7).TextString = myxl.Application.Sheets("Proje").Cells(i, 12).Value

varAttributes(8).TextString = myxl.Application.Sheets("Proje").Cells(i, 11).Value

varAttributes(9).TextString = myxl.Application.Sheets("Proje").Cells(i, 10).Value

varAttributes(10).TextString = myxl.Application.Sheets("Proje").Cells(i, 9).Value

varAttributes(11).TextString = myxl.Application.Sheets("Proje").Cells(i, 8).Value

varAttributes(12).TextString = myxl.Application.Sheets("Proje").Cells(i, 7).Value

varAttributes(13).TextString = myxl.Application.Sheets("Proje").Cells(i, 6).Value

End If

InsPnt(1) = InsPnt(1) - 10000

Next i

End With

'Zoom in to the drawing area.

'ZOOM İÇİN GEREKLİ INSERTION POINT

InsPnti(0) = InsPnt(0)

InsPnti(1) = InsPnt(1)

InsPnti(2) = InsPnt(2)

zoom1(0) = InsPnti(0) + 4837.5 'SAĞ SOL

zoom1(1) = InsPnti(1) + (4605 / 2) + 100 'YUKARI AŞAĞI

zoom1(2) = 0

zoom2(0) = zoom1(0) - 6450

zoom2(1) = zoom1(1) + (10000 * Lastrow) + 2500

zoom2(2) = 0

ThisDrawing.Application.ZoomWindow zoom1, zoom2

'ZOOM2 GÖRÜNÜŞ ALANI BOYUTLARI

'ZOOM1 ÇİZİLEN ÜRÜNÜN YERİ

End Sub