AutoCAD library

[cocoa35]

Sn cicosz Ek'li dosyayı denedim , bu dosyada #27 no'lu mesajdaki durumlar yok. en son çalışmış olduğumuz dosya. lütfen bir'de siz denermisiniz acaba bilgisayardamı sorun var?

 

[cicosz]

Autocad 2019 ve 2020'de ilgili .dll dosyalarını attığı yeri bulup onları system32 klasörüne çekip kayıt etmek gerekli diye düşünüyorum. Ya da shell ile çalıştırmak sorunu çözebilir. Konunun o kısmıyla ilgili ne yazıkki bir bilgim yok. Farklı forum siteleri üzerinden araştırma yapılabilir.

 

[cocoa35]

Tamam sn cicosz göstermiş olduğunuz ilgi için teşekkür ederim , ben araştırmaya devam edeyim mutlakaki bir çözümü vardır.

 

[cocoa35]

Sn Cicosz merhaba; benim programda 2. excel'den autocad'e çizim makrosu var, aşağıda kod'ları ekledim ben düzenlemeye çalıştım ama beceremedim, sizden rica etsem bu kod'larıda diğerleri gibi autocad library belirlemeden çizilecek şekilde düzenleme imkanınız varmı? teşekkürler.

Sub Excelden_Acade()
Dim Cad As Object
Dim a(2) As Double
Dim B(2) As Double
Dim line1 As AcadLine
Dim acadApp As Object
Dim acadDoc As Object
Dim acadCircle As Object
Dim LastRow As Long
Dim i As Long
Dim CircleCenter(0 To 2) As Double
Dim CircleRadius As Double
Set s1 = Sheets("SONÇÖK1")

On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
Set Cad = CreateObject("AutoCad.Application")
End If
For i = 2 To 82
a(0) = s1.Cells(i, 1) ' Ax
a(1) = s1.Cells(i, 2) ' Ay
B(0) = s1.Cells(i + 1, 1) ' Bx
B(1) = s1.Cells(i + 1, 2) ' By

Set MSpace = ACAD.ActiveDocument.ModelSpace
Set line1 = MSpace.AddLine(a, B)
Next i
ACAD.ActiveDocument.SendCommand "Zoom" & Chr(13) & "e" & Chr(13)
'Koordinat sayfasını etkinleştir ve son satırı bul.
With Sheets("SONÇÖK3")
.Activate
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'En az bir daire için koordinat olup olmadığını kontrol edin.
If LastRow < 2 Then
MsgBox "There are no coordinates to draw a circle!", vbCritical, "Circle Center Error"
Exit Sub
End If

'AutoCAD uygulamasının açık olup olmadığını kontrol edin.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")

'AutoCAD açılmazsa yeni bir örnek oluşturun ve görünür hale getirin.
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If

'AutoCAD nesnesi varsa (tekrar) kontrol edin
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0

'Aktif çizim yoksa yeni bir tane oluşturun.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
End If
On Error GoTo 0

'Aktif alanın kağıt alanı olup olmadığını kontrol edin ve model alanına değiştirin.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If

'Loop through all the coordinates/radius and draw the corresponding circle(s).
With Sheets("SONÇÖK3")
For i = 2 To LastRow
'Set the circle radius.
CircleRadius = .Range("D" & i).Value
'If the circle radius is greater than 0, get the circle center and draw the circle.
If CircleRadius > 0 Then
'Set the circle centert.
CircleCenter(0) = .Range("A" & i).Value
CircleCenter(1) = .Range("B" & i).Value
CircleCenter(2) = .Range("C" & i).Value
'Draw the circle.
Set acadCircle = acadDoc.ModelSpace.AddCircle(CircleCenter, CircleRadius)
End If
Next i
End With

'Zoom in to the drawing area.
acadApp.ZoomExtents

'Release the objects.
Set acadCircle = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
Sheets("SONÇÖK1").Select
'Inform the user about the process.
MsgBox "The circle(s) was/were successfully drawn in AutoCAD!", vbInformation, "Finished"

End Sub

 

[cocoa35]

Sn Cicosz merhaba; Yukarıda verdiğim kod'ları bizim örnek dosyadaki kod ile değiştireek sorunu çözüyorum, ancak sizden bir şey daha öğrenmek istiyorum. Ölçümlendirme yapılırken " Hızlı ölçü" yaptırmak istiyorum " Qdim" lütfen bana onun aşağıdaki " dimlinear" örneği gibi kodlarını yazabilirmisiniz. böyle tek tek ölçümlendirme almak çok uzun ve çirkin oluyor.
Örnek;
Cad.ActiveDocument.SendCommand "dimlinear" & vbCr & "linear" & vbCr & cizgi26 & vbCr & cizgi27 & vbCr & cizgi28 & vbCr

Qdim ?

 

[cocoa35]

Dim Cad As AutoCAD.AcadApplication
Set Cad = New AutoCAD.AcadApplication

yerine

Dim Cad  as object
set Cad = createobject("AutoCad.Application")

yazmanız gerekiyor.

Sınıf adının doğru olup olmadığını bilmediğimi yukarıda söylemiştim.

Merhaba; Aşağıdaki kod'larda nasıl bir düzenleme yapmamız gerekiyor?
Sub Excelden_Acade()
Dim ACAD As AcadApplication
Dim a(2) As Double
Dim B(2) As Double
Dim line1 As AcadLine
Dim acadApp As Object
Dim acadDoc As Object
Dim acadCircle As Object
Dim LastRow As Long
Dim i As Long
Dim CircleCenter(0 To 2) As Double
Dim CircleRadius As Double
Set s1 = Sheets("DIRECOK1")

On Error GoTo 0
If ACAD Is Nothing Then
Set ACAD = New AcadApplication
ACAD.Visible = True
Set ACAD = GetObject(, "AutoCAD.Application")
End If
For i = 2 To 82
a(0) = s1.Cells(i, 1) ' Ax
a(1) = s1.Cells(i, 2) ' Ay
B(0) = s1.Cells(i + 1, 1) ' Bx
B(1) = s1.Cells(i + 1, 2) ' By

Set MSpace = ACAD.ActiveDocument.ModelSpace
Set line1 = MSpace.AddLine(a, B)
Next i
ACAD.ActiveDocument.SendCommand "Zoom" & Chr(13) & "e" & Chr(13)
'Koordinat sayfasını etkinleştir ve son satırı bul.
With Sheets("DIRECOK3")
.Activate
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With

'En az bir daire için koordinat olup olmadığını kontrol edin.
If LastRow < 2 Then
MsgBox "There are no coordinates to draw a circle!", vbCritical, "Circle Center Error"
Exit Sub
End If

'AutoCAD uygulamasının açık olup olmadığını kontrol edin.
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")

'AutoCAD açılmazsa yeni bir örnek oluşturun ve görünür hale getirin.
If acadApp Is Nothing Then
Set acadApp = CreateObject("AutoCAD.Application")
acadApp.Visible = True
End If

'AutoCAD nesnesi varsa (tekrar) kontrol edin
If acadApp Is Nothing Then
MsgBox "Sorry, it was impossible to start AutoCAD!", vbCritical, "AutoCAD Error"
Exit Sub
End If
On Error GoTo 0

'Aktif çizim yoksa yeni bir tane oluşturun.
On Error Resume Next
Set acadDoc = acadApp.ActiveDocument
If acadDoc Is Nothing Then
Set acadDoc = acadApp.Documents.Add
End If
On Error GoTo 0

'Aktif alanın kağıt alanı olup olmadığını kontrol edin ve model alanına değiştirin.
If acadDoc.ActiveSpace = 0 Then '0 = acPaperSpace in early binding
acadDoc.ActiveSpace = 1 '1 = acModelSpace in early binding
End If

'Loop through all the coordinates/radius and draw the corresponding circle(s).
With Sheets("DIRECOK3")
For i = 2 To LastRow
'Set the circle radius.
CircleRadius = .Range("D" & i).Value
'If the circle radius is greater than 0, get the circle center and draw the circle.
If CircleRadius > 0 Then
'Set the circle centert.
CircleCenter(0) = .Range("A" & i).Value
CircleCenter(1) = .Range("B" & i).Value
CircleCenter(2) = .Range("C" & i).Value
'Draw the circle.
Set acadCircle = acadDoc.ModelSpace.AddCircle(CircleCenter, CircleRadius)
End If
Next i
End With

'Zoom in to the drawing area.
acadApp.ZoomExtents

'Release the objects.
Set acadCircle = Nothing
Set acadDoc = Nothing
Set acadApp = Nothing
Sheets("DIRECOK1").Select
'Inform the user about the process.
MsgBox "The circle(s) was/were successfully drawn in AutoCAD!", vbInformation, "Finished"

End Sub

Dim Cad As AutoCAD.AcadApplication
Set Cad = New AutoCAD.AcadApplication

yerine

Dim Cad  as object
set Cad = createobject("AutoCad.Application")

yazmanız gerekiyor.

Sınıf adının doğru olup olmadığını bilmediğimi yukarıda söylemiştim.