Anonymous
389 Vistas, 1 Respuesta
05-11-2017
12:17 PM
- Marcar como nuevo
- Favorito
- Suscribir
- Silenciar
- Suscribirse a un feed RSS
- Resaltar
- Imprimir
- Denunciar
05-11-2017
12:17 PM
In the Sub Procedure Inserting Drawings in Open AutoCAD File
Sub Form_13()
On Error GoTo Hata
Dim xkoordinat As Double
Dim ykoordinat As Double
Dim sonsatir As Long
Dim Answer As Integer
Dim i As Long
Dim satirno As String
Dim sksadedi As String
Dim trfsksadedi As String
Dim prfadedi As String
Dim trfadedi As String
Dim og_sg1_adedi As String
Dim og_sg2_adedi As String
Dim sks1karakteristik As String
Dim trfskskarakteristik As String
Dim sts As Long
Dim txt As String
Dim txt2 As String
Dim txt3 As String
Dim konum As String
Dim topraklamafilizsayisi As Double
Dim direktopraklamahattiuzunlugu As Double
Dim topraklamaaskiuzunlugu As Double
Dim cizimalanix As Double
Dim cizimalaniy As Double
Dim demirdireksembolugenisligi As Double
Dim demirdireksemboluuzunlugu As Double
Dim tepeyeuzaklik As Double
'***********AUTOCAD AÇILIŞ*********************
Dim Cad As AutoCAD.AcadApplication
Set Cad = New AutoCAD.AcadApplication
Cad.Visible = True
Cad.Application.WindowState = acMax
Cad.ActiveDocument.SendCommand "lwdisplay on " ' & (Chr(27) & Chr(27)) 'Çizgi Kalınlıklarını göster
yol = "d:/form13.dwg"
Cad.ActiveDocument.SendCommand "HPNAME " & "SOLID" & vbCr 'Hatch için hazırlık, SOLID stilini seçer.
'sks1 = ""
'sks2 = ""
sts = 0
satirno = 0
sksadedi = 0
trfsksadedi = 0
prfadedi = 0
trfadedi = 0
og_sg1_adedi = 0
og_sg2_adedi = 0
brs_sks_yeni = 0
hatsonu_sks = 0
hatbasi_sks = 0
trafo_diregi = ""
hatbasi_sks_diregi = ""
sks1karakteristik = ""
trfskskarakteristik = ""
brs_trf_diregi_mi = 0
kagitbaskipayi = 10.1
cizimalanix = 199.9 '210 - kagitbaskipayi
cizimalaniy = 286.9 '297 - kagitbaskipayi
demirdireksemboluuzunlugu = 5
demirdireksembolugenisligi = 5
tepeyeuzaklik = 40
br_hat_uzunlugu = 25.5
direktopraklamahattiuzunlugu = 5
topraklamaaskiuzunlugu = 5
topraklamafilizuzunlugu = 2.5
topraklamafilizsayisi = 5
Cad.ActiveDocument.SendCommand "Rectang 0,0 " & Replace(cizimalanix, ",", ".") & "," & Replace(cizimalaniy, ",", ".") & " " 'Dış Çerçeve, Yazdırma Bölgesi Alanı
Cad.ActiveDocument.SendCommand "Zoom Extents" & vbCr & vbCr
x = Replace((cizimalanix / 2), ",", ".") '99.95
x1 = Replace((cizimalanix / 2) - (demirdireksembolugenisligi / 2), ",", ".") 'x-2.5=97.45
x2 = Replace((cizimalanix / 2) + (demirdireksembolugenisligi / 2), ",", ".") 'x+2.5=102.45
y = Replace(cizimalaniy - tepeyeuzaklik, ",", ".") '246.9
y1 = Replace(cizimalaniy - tepeyeuzaklik - (demirdireksemboluuzunlugu / 2), ",", ".") 'y-2.5=244.4
y2 = Replace(cizimalaniy - tepeyeuzaklik + (demirdireksemboluuzunlugu / 2), ",", ".") 'y+2.5=249.4
br1_x1 = Replace((cizimalanix / 2) - (demirdireksembolugenisligi / 2) - br_hat_uzunlugu, ",", ".") 'x1-25.5=71.95
br1_x2 = Replace((cizimalanix / 2) - (demirdireksembolugenisligi / 4), ",", ".") 'x-1.25=98.7
br2_x2 = Replace((cizimalanix / 2) + (demirdireksembolugenisligi / 2) + br_hat_uzunlugu, ",", ".") 'x2+25.5=127.95
br2_x1 = Replace((cizimalanix / 2) + (demirdireksembolugenisligi / 4), ",", ".") 'x+1.25=101.2
Cad.ActiveDocument.SendCommand "Line " & br1_x1 & "," & y & ",0 " & x1 & "," & y & ",0 " & " " 'Branşman Hattı-Sol
Cad.ActiveDocument.SendCommand "Line " & x2 & "," & y & ",0 " & br2_x2 & "," & y & ",0 " & " " 'Branşman Hattı-Sağ
Cad.ActiveDocument.SendCommand "Rectang " & x1 & "," & y1 & " " & x2 & "," & y2 & " " 'Branşman Direği Sembolü Karesi (5x5)
'*****BRANŞMAN DİREĞİ SEMBOLÜ ÇAPRAZLARI*****
Cad.ActiveDocument.SendCommand "Line " & x1 & "," & y2 & ",0 " & x2 & "," & y1 & ",0 " & " "
Cad.ActiveDocument.SendCommand "Line " & x1 & "," & y1 & ",0 " & x2 & "," & y2 & ",0 " & " "
'********************************************
Cad.ActiveDocument.SendCommand ("-mtext" + vbCr & "54" & "," & "266.9" & vbCr + "j" + vbCr + "bl" + vbCr + "h" + vbCr + "5" + vbCr + "w" + vbCr + "91.9" + vbCr + "PRİMER MALZEME LİSTESİ" + vbCr + vbCr) 'Ana Başlık
Cad.ActiveDocument.SendCommand ("-mtext" + vbCr & "97" & "," & "251" & vbCr + "j" + vbCr + "br" + vbCr + "h" + vbCr + "2.5" + vbCr + "w" + vbCr + "20" + vbCr + "BR. " & "N-12" + vbCr + vbCr) 'Branşman Direği Tipi
''*****BRANŞMAN DİREĞİ TOPRAKLAMASI*****
xkoordinat = 10245 / 100 'x2
ykoordinat = 24940 / 100 'y2
direktopraklamahattiuzunlugux = Replace((direktopraklamahattiuzunlugu / 2) * Sqr(2), ",", ".") '3.54
direktopraklamahattiuzunluguy = Replace((direktopraklamahattiuzunlugu / 2) * Sqr(2), ",", ".") '3.54
brsdirektopr_trfdiregipayix = Replace(demirdireksembolugenisligi / 3, ",", ".") '~1.67
brsdirektopr_trfdiregipayiy = Replace(demirdireksemboluuzunlugu / 3, ",", ".") '~1.67
xt1 = Replace((cizimalanix / 2) + (demirdireksembolugenisligi / 2) - (demirdireksembolugenisligi / 3), ",", ".") 'xt1 = x2-1.67=100.78
yt1 = Replace(cizimalaniy - tepeyeuzaklik + (demirdireksemboluuzunlugu / 2) - (demirdireksemboluuzunlugu / 3), ",", ".") 'yt1 = y2-1.67=247.73
xt2 = Replace((cizimalanix / 2) + (demirdireksembolugenisligi / 2) + (direktopraklamahattiuzunlugu / 2) * Sqr(2), ",", ".") 'xt1 = x2+3.54=105.99
yt2 = Replace(cizimalaniy - tepeyeuzaklik + (demirdireksemboluuzunlugu / 2) + (direktopraklamahattiuzunlugu / 2) * Sqr(2), ",", ".") 'yt1 = y2+3.54=252.94
Cad.ActiveDocument.SendCommand "Line " & xt1 & "," & yt1 & ",0 " & xt2 & "," & yt2 & ",0 " & " "
xt1 = Replace((((direktopraklamahattiuzunlugu - (((topraklamafilizsayisi - 1) / 2) * (topraklamaaskiuzunlugu / (topraklamafilizsayisi - 1)))) / 2)) * Sqr(2) + ((cizimalanix / 2) + (demirdireksembolugenisligi / 2)), ",", ".")
yt1 = Replace((((direktopraklamahattiuzunlugu - (((1 - topraklamafilizsayisi) / 2) * (topraklamaaskiuzunlugu / (topraklamafilizsayisi - 1)))) / 2)) * Sqr(2) + (cizimalaniy - tepeyeuzaklik + (demirdireksemboluuzunlugu / 2)), ",", ".")
xt2 = Replace((((direktopraklamahattiuzunlugu - (((1 - topraklamafilizsayisi) / 2) * (topraklamaaskiuzunlugu / (topraklamafilizsayisi - 1)))) / 2)) * Sqr(2) + ((cizimalanix / 2) + (demirdireksembolugenisligi / 2)), ",", ".")
yt2 = Replace((((direktopraklamahattiuzunlugu - (((topraklamafilizsayisi - 1) / 2) * (topraklamaaskiuzunlugu / (topraklamafilizsayisi - 1)))) / 2)) * Sqr(2) + (cizimalaniy - tepeyeuzaklik + (demirdireksemboluuzunlugu / 2)), ",", ".")
Cad.ActiveDocument.SendCommand "Line " & xt1 & "," & yt1 & ",0 " & xt2 & "," & yt2 & ",0 " & " "
'********************* bu kısım iyi düşünülmeli **************************
'********************* SEKSİYONER BRANŞMAN DİREĞİNDEYSE ******************
Cad.ActiveDocument.SendCommand "Line 102.45,244.4,0 104.5713,242.2787,0 " & " "
Cad.ActiveDocument.SendCommand "Arc 104.57132,238.743146 104.57132,242.27868 108.106854,242.27868 " & " " 'Hat Başı Seksiyoner Yay Simgesi
Cad.ActiveDocument.SendCommand "Line 111.2888,235.5612,0 104.5289,237.3714,0 " & " "
Cad.ActiveDocument.SendCommand "Line 106.8623,238.432,0 107.8382,234.8116,0 " & " "
Cad.ActiveDocument.SendCommand "Line 107.421,238.2835,0 108.3897,234.6561,0 " & " "
Cad.ActiveDocument.SendCommand "Line 107.9796,238.1209,0 108.9554,234.5005,0 " & " "
Cad.ActiveDocument.SendCommand "Line 114.8244,232.0256,0 111.2888,235.5612,0 " & " "
Cad.ActiveDocument.SendCommand "Line 115.7083,232.9095,0 113.9405,231.1417,0 " & " "
Cad.ActiveDocument.SendCommand "Rectang 114.647592,230.434641 121.647592,232.934641 "
Cad.ActiveDocument.SendCommand "Select Last" & " " & " "
Cad.ActiveDocument.SendCommand "Rotate 114.647592,230.434641 315" & " " & " "
Cad.ActiveDocument.SendCommand "Line 118.1831,231.1417,0 115.7083,228.6669,0 " & " "
Cad.ActiveDocument.SendCommand "Line 119.2438,230.0811,0 116.7689,227.6062,0 " & " "
Cad.ActiveDocument.SendCommand "Line 120.3044,229.0204,0 117.8296,226.5456,0 " & " "
Cad.ActiveDocument.SendCommand "Line 122.0722,226.5456,0 120.3044,224.7778,0 " & " "
'*************************************************************************
'*************************************************************************
Cad.ActiveDocument.SendCommand "Zoom Extents" & vbCr & vbCr
Cad.Application.ActiveDocument.SaveAs "d:/form13.dwg"
Set Cad = Nothing
Call direktopraklama_ciz(topraklamafilizsayisi, direktopraklamahattiuzunlugu, topraklamaaskiuzunlugu, demirdireksembolugenisligi, demirdireksemboluuzunlugu, tepeyeuzaklik)
Hata:
Exit Sub
End Sub
Sub direktopraklama_ciz(topraklamafilizsayisi1 As Double, direktopraklamahattiuzunlugu1 As Double, topraklamaaskiuzunlugu1 As Double, demirdireksembolugenisligi1 As Double, demirdireksemboluuzunlugu1 As Double, tepeyeuzaklik1 As Double)
Dim acadApp As AcadApplication
Dim ThisDrawing As AcadDocument
Dim i As Long
Dim j As Long
Dim topraklamafilizuzunlugu1 As Double: topraklamafilizuzunlugu1 = 2.5
Dim cizimalanix1 As Double: cizimalanix1 = 199.9
Dim cizimalaniy1 As Double: cizimalaniy1 = 286.9
Dim xt11 As String
Dim yt11 As String
Dim xt22 As String
Dim yt22 As String
On Error Resume Next
Set acadApp = GetObject(, "AutoCAD.Application")
On Error GoTo 0
If acadApp Is Nothing Then
Set acadApp = New AcadApplication
acadApp.Visible = True
End If
Set ThisDrawing = acadApp.ActiveDocument
Set acadApp = GetObject(, "AutoCAD.Application")
acadApp.Documents.Open "d:/form13.dwg", , True
acadApp.Visible = True
i = (topraklamafilizsayisi1 - 1)
Do While i >= ((1 - topraklamafilizsayisi1))
j = -1 * i
xt11 = Replace((((direktopraklamahattiuzunlugu1 - ((i / 2) * (topraklamaaskiuzunlugu1 / (topraklamafilizsayisi1 - 1)))) / 2)) * Sqr(2) + ((cizimalanix1 / 2) + (demirdireksembolugenisligi1 / 2)), ",", ".")
yt11 = Replace((((direktopraklamahattiuzunlugu1 - ((j / 2) * (topraklamaaskiuzunlugu1 / (topraklamafilizsayisi1 - 1)))) / 2)) * Sqr(2) + (cizimalaniy1 - tepeyeuzaklik1 + (demirdireksemboluuzunlugu1 / 2)), ",", ".")
xt22 = Replace((((topraklamafilizuzunlugu1 + direktopraklamahattiuzunlugu1 - ((i / 2) * (topraklamaaskiuzunlugu1 / (topraklamafilizsayisi1 - 1)))) / 2)) * Sqr(2) + ((cizimalanix1 / 2) + (demirdireksembolugenisligi1 / 2)), ",", ".")
yt22 = Replace((((topraklamafilizuzunlugu1 + direktopraklamahattiuzunlugu1 - ((j / 2) * (topraklamaaskiuzunlugu1 / (topraklamafilizsayisi1 - 1)))) / 2)) * Sqr(2) + (cizimalaniy1 - tepeyeuzaklik1 + (demirdireksemboluuzunlugu1 / 2)), ",", ".")
acadApp.ActiveDocument.SendCommand "Line " & xt11 & "," & yt11 & ",0 " & xt22 & "," & yt22 & ",0 " & " "
i = i - 2
Loop
acadApp.ZoomExtents
Set acadDoc = Nothing
Set acadApp = Nothing
End SubHello to everyone,
I have been doing programs with Excel, VBA, AutoCAD triple for a long time. Lazy codes were too long, and the projects were very complex, and it was inevitable to get a "Procedure too Large" error. I also had to divide the current drawing programs. Now I have a new problem.
When I run the above code in Excel, the macro named myProtection_Ciz works; A new drawing is added to the already open drawing file. But it does not open the file for the second time. When I try to open the file in the first mode and open it in the second mode, I can not save the file because it is read-only.
I need your ideas and suggestions that are very valuable to me. What should be done to work with the above codes? Please help me..