BioCAD - AutoCAD VBA

BioCAD Tools V3

noreply@blogger.com (Biolight) — Tue, 23 Sep 2008 23:44:00 +0300

Merhaba

BioCAD bu yeni versiyonunda bir önce ki mesajımda açıkladığım
Block Yerleşimi deki kodları BioCAD e dahil ettim.

Kısaca belirlediğiniz bir alan içerisine,
yine kendimizin belirlediği bir block u
eşit oranlar da bu alana dizmeye yarayan ARM(armatur.bas)
AutoCAD VBA kodlarını BioCAD e modül olarak ekledim.

Ekler:
Dosya: BioCAD.zip
Dosya içeriği: BioCAD.dvb

Kolay gelsin.

Block Yerleşimi

noreply@blogger.com (Biolight) — Fri, 9 May 2008 13:10:00 +0300

Merhaba,
Bir Block u belirlediğimiz bir alan içerisin de eşit mesafeler de yerleştirmemize yarar.
Örnek : Bir Oda içerisine Armatür blocklarımızı düzgün bir şekilde yerleştirmek istediğimiz de oldukca kullanışlı olacaktır.

Ben bunu ilk olarak lisp le çözümünü gördüm ve bunu VBA ya dönüştürmek istedim.
Lispi www.autocadokulu.com un Forum sayfasın da @wolf nickini kullanan bir arkadaş yayınlamıştı.
Dilerseniz Lisp i deneyebilirsiniz. Lisp yükle(arm.fas)

İlk olarak Blockları yerleştirecegimiz alanın Sol Alt noktası,
ardın dan Sağ Üstnoktanın işaretlenmesi istenir,
Bu sayede alanın genişliği ve yüksekliği tespit edilir.

Yatay da ve Dikey de kaç edet Block yerleştirilmek istendiği sorulur.
boş geçilir ise varsıyan değer olarak 1(bir) belirledim.

Hemen ardından bu alanın içine yerleştirmek istediğimiz Block un ismi istenir.
eğer block ismi verilmez veya block bulunamaz sa varsayılan olarak uygun yerlere sadece Nokta(Point) yerleştirmesini sağladım.

Not: Yakın zaman da BioCAD e dahil edeceğim oldukca kullanışlı ;)

Sub armaturdiz()
ThisDrawing.SendCommand Chr(3) & Chr(3)

On Error Resume Next
Dim returnPnt1 As Variant
Dim returnPnt2 As Variant
Dim DikMiktar As Double
Dim YatayMiktar As Double
Dim BlockName As String

returnPnt1 = ThisDrawing.Utility.GetPoint(, "Sol alt noktasini isaretleyin: ")

If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

returnPnt2 = ThisDrawing.Utility.GetPoint(, "Sag ust noktasini isaretleyin: ")

If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

DikMiktar = ThisDrawing.Utility.GetReal("Yatay Block sayısı<1> |||: ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
DikMiktar = 1
Else
' esc tıklamıştır işlemi sonlandır
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If
End If

YatayMiktar = ThisDrawing.Utility.GetReal("Dikey Block sayısı<1> ---: ")
If Err Then
If StrComp(Err.Description, "User input is a keyword", 1) = 0 Then
Err.Clear
YatayMiktar = 1
Else
' esc tıklamıştır işlemi sonlandır
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If
End If

BlockName = ThisDrawing.Utility.GetString(False, "Yerleştirilecek Block un adını giriniz(Space, Enter veya Block yoksa<Nokta>): ")
If Err Then
ThisDrawing.Utility.Prompt "Program sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Err.Clear
Exit Sub
End If

On Error GoTo 0

Dim pointObj As AcadPoint
Dim BlockNameVar As Boolean
Dim blockRefObj As AcadBlock
Dim blockRefObj01 As AcadBlockReference
Dim insertionPnt(0 To 2) As Double
Dim blkColl As AcadBlocks
Set blkColl = ThisDrawing.Blocks

For Each blockRefObj In blkColl
If blockRefObj.Name = BlockName Then
BlockNameVar = True
End If
Next

' cizim içinde bir block değilse dwg uzantısı ekle
If BlockNameVar = False Then
BlockName = BlockName & ".dwg"
End If

For i = 1 To (YatayMiktar * 2) Step 2
For k = 1 To (DikMiktar * 2) Step 2

insertionPnt(0) = (returnPnt1(0) + ((returnPnt2(0) - returnPnt1(0)) / (DikMiktar * 2) * k))
insertionPnt(1) = (returnPnt1(1) + ((returnPnt2(1) - returnPnt1(1)) / (YatayMiktar * 2) * i))
insertionPnt(2) = 0

If BlockName <> "" Then

On Error Resume Next
Set blockRefObj01 = ThisDrawing.ModelSpace.InsertBlock(insertionPnt, BlockName, 1#, 1#, 1#, 0)
' Block bilgisayarda yoksa yerine nokta koy
If Err Then
Set pointObj = ThisDrawing.ModelSpace.AddPoint(insertionPnt)
Err.Clear
End If

On Error GoTo 0

Else
' Sadece işaretlemek isterse Nokta koy
Set pointObj = ThisDrawing.ModelSpace.AddPoint(insertionPnt)
End If

Next k
Next i

End Sub

Ekler:
Dosya: armatur.zip
Dosya içeriği: armatur.bas

Kolay gelsin

BioCAD Tools V2

noreply@blogger.com (Biolight) — Wed, 27 Feb 2008 01:55:00 +0200

Merhaba

BioCAD bu yeni versiyonunda Genelin de bir değişiklik oldu ama
kodlar şifreli olduğundan bunu gözlemliyemiyorsunuz
eğer gerçekten ilginiz varsa özel mesaj çekip ~~kodları görebilirsiniz~~
ilgilendiğiniz bölümün Kodlarını görebilirsiniz.

Bu yeni versiyonda en büyük degişiklik Block larla ilgili olan
MBS - Multiple Block Scale Change
kodlarında oldu MBS ile yapılabilecekler
*- Belirli bir bölge seçip o bölgede ki blokları listeleyebilir.
- Aktif AutoCAD dosyasın da kullanılan tüm Blockları Listeleyebilir.
- Listelenen Blocklardan şeçtiklerinizin hepsini birden Boyutlandırabilir(Scale).
- Listelenen Blocklardan şeçtiklerinizin hepsini birden Silebilirsiniz(Delete).
*- Listelenen Blocklardan şeçtiklerinizin hepsini birden Çevirebilir(Rotate).
*- Listelenen Blockları TEXT (*.txt) dosyası olarak Kaydedebilirsiniz.
*- Listelenen Blockları EXCEL (*.xls) dosyası olarak Kaydedebilirsiniz.

Not:
* Dynamic Bloklarınız da gösterilebilecektir artık
özellikle Visibility özelliği olanlar ayrı ayrı ;)
BioCAD le ilgili ana açıklamalayı BioCAD Tools sayfasında bulabilirsiniz.

* İşareti Yeni eklenen özellikleri temsil eder.

Ekler:
Dosya: BioCAD.zip
Dosya içeriği: BioCAD.dvb

Kolay gelsin.

ExcelToAutoCAD

noreply@blogger.com (Biolight) — Sat, 2 Feb 2008 13:56:00 +0200

Excel den AutoCAD e Koordinatların aktarılması
Excel2AutoCAD

Merhaba,

Excel dosyasın da bulunan Koordinatları
AutoCAD e otomatik olarak aktarmaya yarar.

Genelde Haritacı arkadaşların işine yaramaktadır
Kodlar Excel VBA da yazılmıştır ve
Excel Eklentisine (XLA) dönüştürülmüştür.
Not: VBA kodları açıktır inceleye bilirsiniz.

Bu Dosya sayesinde Excel in En üste ki Ana Menüsünün En sağına
AutoCad menusu ekleyecek Bunu tıklayınca Koordinatlar butonu çıkacak
Koordinatlar tıklayınca kodlar çalışacaktır.

Fare ile İLK X koordinatı seçebilir veya
direk İLK X koordinatının bulunduğu hücreyi yazabilirsiniz.
ÖRNEK: $A$2 veya A2

Y koordinatı belirlediğiniz hücrenin yanında ki sütun olacak.
Z koordinatı Y koordinatı yanında ki sütun olacak.
Not: Y ve Z hücreleri boşsa eğer 0(sıfır) kabul edilecektir.

Bundan sonrasını Program kendisi otomatik yapacaktır.

Boş bir AutoCAD dosyası açtıktan sonra
4(Dört) adet Layer oluşturacaktır.
1.Layer: SiraNo (Layer:Açık, Yazdırma:Kapalı)
2.Layer: XKoordinat (Layer:Kapalı)
3.Layer: YKoordinat (Layer:Kapalı)
4.Layer: ZKoordinat (Layer:Kapalı)

1. SiraNo Layeri :
- Açık konumdadır ve yazdırma işlemi sirasında yazdırılmaz olarak ayarlanmıştır.
- İlk belirlediğiniz koordinattan itibaren kendisi sıra numarası verecektir.
- Text Height değeri 50 dir.

2. XKoordinat Layeri :
- Kapalı konumdadır.
- X Koordinatın değerini yazmaktadır
- Text Height değeri 100 dür.

3. YKoordinat Layeri :
- Kapalı konumdadır.
- Y Koordinatın değerini yazmaktadır
- Text Height değeri 100 dür.

4. ZKoordinat Layeri :
- Kapalı konumdadır.
- Z Koordinatın değerini yazmaktadır
- Text Height değeri 100 dür.

Tüm işlemler bittikten sonra
AutoCAd dosyasını Excel dosyanızla
aynı isimde ve aynı yerde(klasörde) kaydedip size bildirir.

********************
Excel Eklenti(XLA)Ekleme
Boş bir Excel açınız Araçlar - Eklentiler Tıklayınız
Gözat butonu Tıklayınız Bilgisayarınız da dosyayı bulup onaylayınız
Eklentiler penceresinide onayladıktan sonra kapatınız.
Artık tüm excel dosyalarınızda kodları çalıştırabilirsiniz.
********************

Not : Kullandığınız AutoCAD versiyonuna uygun dosyayı yükleyiniz.

Ekler:
Dosya: Koordinatlar2000.zip
Dosya içeriği: Koordinatlar2000.xla
AutoCAD2000 kullanıyorsanız bu dosyayı kullanınız.

Dosya: Koordinatlar2004.zip
Dosya içeriği: Koordinatlar2004.xla
AutoCAD2004 kullanıyorsanız bu dosyayı kullanınız.

Dosya: Koordinatlar2007.zip
Dosya içeriği: Koordinatlar2007.xla
AutoCAD2007 kullanıyorsanız bu dosyayı kullanınız.

Kolay gelsin.

BioCAD Tools

noreply@blogger.com (Biolight) — Sat, 10 Nov 2007 22:13:00 +0200

Merhaba,

BioCAD Tools (BioCAD araçlar menüsü - VBA - DVB)
AutoCAD Express Tools tarzındadır.
AutoCAD ana menüsünün en sonuna
BioCAD isminde yeni menü eklenir.
Kodlar AutoCAD VBA kullanılıp DVB dosyasına dönüştürülmüştür.
AutoCAD 2006 ve 2007 de test edilmiştir.

DVB dosyasının AutoCAD e nasıl YÜKLEneceğini önceden anlatmıştım.
Eğer BioCAD işinize yaramaz veya kullanmak istemezseniz
DVB dosyası nasıl İPTAL edilir bölümünde anlatmıştım.

BioCAD Tools içeriği :
1. MBS - Multiple Block Scale Change
Çoklu Block Raporu ve Scale değişimin de kullanılır.
VBA da UserForm Kullanılarak hazırlanmıştır.
- Aktif AutoCAD dosyasında bulunan Block sayını gösterir.
- Block listesini yazdırabilir.
- Blockların hepsini birden boyutlandırabilir.
- Blockların hepsini birden silebilirsiniz.

2. LDO - Layer DrawOrder
Layerlarla ilgili işlemler yapılır.
VBA da UserForm Kullanılarak hazırlanmıştır.
- Layerları istediğiniz şekilde sıralayıp
bu sıraya göre Layerleri DrawOrder yapabilme.
- Layer rengini direk degiştirebilme.
- Listeden seçilen layerin direk Current olabilmesi.

3. AKS - AKS Çizimi
Mimari AKS çizimi.
VBA da Module-Bas Kullanılarak hazırlanmıştır.
- Çiziminizde kullanılacak olan ölçek istenir.
- Yatay ve Dikey AKS aralıkları uzunlukları istenir.
- Aks a ait yeni Layer, TextStyle ve DimStyle ler hazır konumdadır.

Yakında: Kolon Çizimi, Ölçülendirme, Koordinat Girişi, STrim, NewSTrim eklenecektir.
Esasında şuan hazırlar ama Test aşamasındalar ;)

BioCAD Tools da güncelleme olduğun da bu başlık altında gerekli açıklamayı yapacağım

26.11.2007 Pazartesi
BioCAD Güncellendi

4. STrim

5. NewSTrim

6. KOLON Kolon Çizimi
Mimari projede kolon çizimi
VBA da UserForm kullanılarak hazırlanmıştır.
- Kolonun köşe noktasının aksa uzaklıkları istenir
- Girilen değerler yer değiştirilebilir
- Kolon en/boy ölçüsü değiştirilebilir
- Kolon kendi layer ında ve taranmış olarak aks kesişim noktasından tutulu olarak gelir

7. OL Ölçülendirme
Yatay ya da düşey çizgilere sürekli ölçü verilir
VBA da hazırlanmıştır
- Ölçülendirelecek çizgilerden biri istenir
- Seçilen çizginin yatay/düşey konumuna, layer’ına ve seçilen noktasına bağlı olarak aynı layer’daki diğer çizgiler otomatik seçili hale getirilir
- Seçme işlemine eklenecek ya da çıkartılacak çizgiler single yöntemi ile belirlenir
- Ölçü objesinin boyutlarını belirleyen ölçek istenir
- Peş peşe devam eden ölçülerin toplamının orta noktasından tutulu olarak getirilir ve ölçünün hangi noktadan geçeceği istenir.

8. KRD Koordinat
x-y koordinat değerleri verilerek aplikasyon krokisi çizimi
VBA da UserForm kullanılarak hazırlanmıştır.
- Her köşe noktasının x ve y değerleri virgülden sonra iki basamak şeklinde ayrı ayrı istenir
- Forma göre en az 3 noktanın x ve y değerleri istenir fazlası için “Satır Ekle” butonu ile yeni nokta için satır eklenir
- Girilen değerlerin oluşturduğu kapalı alan önizleme penceresinde görülebilir
- x ve y değerlerinin yerleri otomatik olarak değiştirilebilir
- Daha önceden .txt dosya formatında kaydedilmiş koordinat değerleri de otomatik olarak yüklenebilir
- Koordinat değerlerinizi .txt dosya formatında kaydedebilirsiniz
- Köşe noktaları çember ile gösterilerek çizim hazırlanır

BioCAD in gelişmesi sürecinde,
Önerileri, kodlalama da izlenilecek mantık ve test aşamasın da
bana yardımıncı olup, destek veren Mimar Murat ÇAĞIL'a
Teşekkür ederim.

28.02.2008 Perşembe
BioCAD Güncellendi
Güncelleme ile ilgili detaylar için Tıklayınız.

Ekler:
Dosya: BioCAD.zip
Dosya içeriği: BioCAD.dvb

Kolay gelsin.

BlockSelect2Excel

noreply@blogger.com (Biolight) — Sat, 13 Oct 2007 22:19:00 +0300

Merhaba,
BlockSelect2Excel : Çiziminizde belirlediğiniz bir bölgedeki blockların isim ve miktarlarını excel dosyasına kaydetmeye yarar.

BlockSelect2Excel.bas dosyasını yükledikten sonra Macromuz Excel ile etkileşimli çalışacağı için VBE de Excele Referans göstermeniz gerekli.
Bu ayarlamayı da yaptıktan sonra BlockSelect2Excel Macrosu çalıştırdığınız da

Sizden bir bölge seçmeniz veya objeler seçmeniz istenecek
seçiminiz bittikten sonra da (enter veya fare sağ tık seçim biter)
Seçiminiz de blok mevcud sa bunları listeleyip Excel dosyasına aktarır
kodların çalışması bittiğin de Excel dosyasının bilgisayarınızda ki yeri ve ismini söyleyecektir.

Not: Excel dosyası açıkken kodları çalıştırmayınız uyarı verir.

Sub BlockSelect2Excel()

' info(at)mentes.com.tr
' ibrahim Yorulmaz - Antalya - 2007
' o 532 625 55 66

' Not: Excele referans göstermeyi unutmayınız
' Tools - References...
' Microsoft Excel 11.0 Object Library
' Kullandığınız Excel sürümüne göre 11.0 degişebilir.

Dim BlockSS As AcadSelectionSet
Dim secili As Integer

ThisDrawing.Utility.Prompt "Lütfen saymak istediğiniz Bloklara ait bölge Seçiniz" & vbCrLf

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear
On Error GoTo 0

BlockSS.SelectOnScreen

Dim KacBlock As Integer
KacBlock = 0

' Secimde block varsa KacBlock degerini 1 yap
For secili = 0 To BlockSS.Count - 1
If BlockSS.Item(secili).ObjectName = "AcDbBlockReference" Then
KacBlock = 1
End If
Next secili

' eğer secimde block yoksa uyar
If KacBlock = 0 Then
MsgBox "Seçiminiz de Block bulunamadı !", vbInformation, "Block yok."
Exit Sub
End If

On Error GoTo UPSSHATA

Dim Excel As Excel.Application
Dim ExcelSheet As Object
Dim ExcelWorkbook As Object

' Excel i aç
Set Excel = New Excel.Application

' excel e kitap ekle
Set ExcelWorkbook = Excel.Workbooks.Add
' aktip excel kitap sayfasını belirle
Set ExcelSheet = Excel.ActiveSheet

' Excel uyarılarını yoksay
' dosya önceden varsa üzerine kaydedeyim mi sorusu iptali
Excel.DisplayAlerts = False

' Sayfa ismini Blocklar yap
ExcelSheet.Name = "Blocklar"

' excel kitabında bulunan sayfa sayısı kadar döngü
For Each Worksheet In Excel.ActiveWorkbook.Worksheets
' sayfa ismi Blocklar değilse
If Worksheet.Name <> "Blocklar" Then
' gereksiz bos sayfaları yok et
' excel alert vermesini yukarıda iptal etmiştik
Excel.Sheets(Worksheet.Name).Delete
End If
Next

Dim Dosyaismi
' dosyaismi= dwg dosyamızla aynı klasörde ve aynı isimde sadece dosya uzantısı xls(excel) oldu
Dosyaismi = Left(ThisDrawing.FullName, InStr(ThisDrawing.FullName, ".") - 1) & ".xls"

' excel kitabını kaydet
ExcelWorkbook.SaveAs Dosyaismi

' önce yazılan Sutunları yok et
ExcelSheet.Range("A1").EntireColumn.Delete
ExcelSheet.Range("A1").EntireColumn.Delete

Dim Satir As Integer
Satir = 1

' Blok isimlerinin hepsini A sutununa yaz
For secili = 0 To BlockSS.Count - 1
If BlockSS.Item(secili).ObjectName = "AcDbBlockReference" Then
ExcelSheet.Cells(Satir, 1).Value = BlockSS.Item(secili).Name
Satir = Satir + 1
End If
Next secili

' SelectionSets i yok et
BlockSS.Delete

' A sutununu alfabetik olarak sırala
Excel.Selection.Sort Key1:=ExcelSheet.Range("A1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

' A sutununda kaç tane dolu hucre oldugunu bul
Dim SatirAll
SatirAll = Excel.WorksheetFunction.CountA(ExcelSheet.Range("A1:A65500"))

' B sutununa excel EGERSAY formulunu uygulayıp değerini yaz
Dim Miktar As Integer
For Miktar = 1 To SatirAll
ExcelSheet.Cells(Miktar, 2).Value = Excel.WorksheetFunction.CountIf(ExcelSheet.Range("A:A"), ExcelSheet.Range("A" & Miktar))
Next Miktar

' A2 hücresinden itibaren A sutununda ki benzer satırları yok et
For Miktar = 1 To SatirAll
' A2 hucresinden başla ve Sonsuz döngüye girmemek için boş hücreye dikkat et
If Miktar > 1 And ExcelSheet.Cells(Miktar, 1).Value <> "" Then
If ExcelSheet.Cells(Miktar, 1).Value = ExcelSheet.Cells((Miktar - 1), 1).Value Then
ExcelSheet.Cells(Miktar, 1).EntireRow.Delete
' satır silindi miktarı geri al
Miktar = Miktar - 1
End If
End If
Next Miktar

' A ve B sutunlarını en uygun genişlik yap
ExcelSheet.Columns("A:A").EntireColumn.AutoFit
ExcelSheet.Columns("B:B").EntireColumn.AutoFit

' Excel i kaydet
ExcelWorkbook.Save

' excel uyarıları çalışır duruma getir
Excel.DisplayAlerts = True

' Exceli kapat
Excel.Application.Quit

Set ExcelSheet = Nothing
Set ExcelWorkbook = Nothing
Set Excel = Nothing

' işlem bitti dosya adresini söyle
MsgBox "Seçimizde ki mevcud blocklar listesi bilgisayarınız da" & vbCrLf & _
Dosyaismi & vbCrLf & _
"Excel dosyası olarak kaydedildi !", vbInformation, "Block Listesi Kaydedildi !"

Exit Sub

UPSSHATA:

Excel.Application.Quit
Set ExcelSheet = Nothing
Set ExcelWorkbook = Nothing
Set Excel = Nothing
MsgBox "HATA yaptık." & vbCr & Err.Description, vbCritical, "Hata oluştu !"
Err.Clear
Exit Sub

End Sub

Ekler:
Dosya: BlockSelect2Excel.zip
Dosya içeriği: BlockSelect2Excel.bas

Kolay gelsin

NewSTrim

noreply@blogger.com (Biolight) — Fri, 5 Oct 2007 20:01:00 +0300

Merhaba,
İlk Eski STrim de sadece Line ların kesişmesi halinde
çoklu olarak trim yapılabiliyordu.

NStrim de ise Line, Arc, Polyline ve Spline keşişmesi
durumunda dahi çalışmaktadır.

Kodları yazarken kendimi biraz kaptırmışım
detaylı bir şey oldu mazur görün artık :)

New Süper Trim (NSTrim)
NSTrim.bas dosyası yükledikten sonra NSTrim Macrosu çalıştırdığınız da
Sizden Kesişen çizgilerin ORTASINDA bir NOKTA göstermeniz istenir
ve çoklu trim mi gerçekleştir.

Function HataPoly(Optional yoket As String = "sil", Optional silmiktar As Integer)
Dim fType(0) As Integer, fData(0)
Dim PolySS As AcadSelectionSet
Dim secili As Integer

On Error Resume Next
Set PolySS = ThisDrawing.SelectionSets("PolySS")
If Err Then Set PolySS = ThisDrawing.SelectionSets.Add("PolySS")
PolySS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "POLYLINE"

' Tüm PolyLine ları seç
PolySS.Select acSelectionSetAll, , , fType, fData

' gelen yoket değeri sil ise
If yoket = "sil" Then
' hatalı oluşturulan silmiktar kadar Polyline ları yok et
For i = 0 To silmiktar - 1
PolySS.Item(i).Delete
Next
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
HataPoly = PolySS.Count
End If

PolySS.Delete
End Function

Function SecimLWPoly(Optional kim As String = "yakala")
Dim fType(0) As Integer, fData(0)
Dim PolySS As AcadSelectionSet
Dim secili As Integer

On Error Resume Next
Set PolySS = ThisDrawing.SelectionSets("PolySS")
If Err Then Set PolySS = ThisDrawing.SelectionSets.Add("PolySS")
PolySS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "LWPOLYLINE,REGION"

' Tüm PolyLine ları seç
PolySS.Select acSelectionSetAll, , , fType, fData

' gelen kim değeri yakala ise
If kim = "yakala" Then
' yeni(not: ilginçtir ilk oluyor(0 değeri)) oluşturulan Polyline nın veya Region ObjectID ver
SecimLWPoly = PolySS.Item(0).ObjectID
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
SecimLWPoly = PolySS.Count
End If

PolySS.Delete
End Function

Public Sub BlockTrim(BlockToFind As String)
Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim BlockSS As AcadSelectionSet
Dim secili As Integer
Dim InsPoint As Variant
Dim Str As ACAD_POINT

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear

fType(0) = 0: fData(0) = "INSERT": fType(1) = 2: fData(1) = BlockToFind
BlockSS.Select acSelectionSetAll, , , fType, fData

For secili = 0 To BlockSS.Count - 1

InsPoint = BlockSS.Item(secili).InsertionPoint

' Block koordinatlarını Str olarak hafızaya al
Str = Str & Replace(InsPoint(0), ",", ".") & "," & Replace(InsPoint(1), ",", ".") & "," & Replace(InsPoint(2), ",", ".") & vbCr

' Blockları yok et
BlockSS.Item(secili).Delete

Next secili

' Trim uygula tüm objeleri sec sonra Str noktalarını tıkla
ThisDrawing.SendCommand Chr(3) & Chr(3) & "trim" & vbCr & vbCr & Str & vbCr
Str = ""

' SelectionSets i yok et
BlockSS.Delete
End Sub

Sub NSTrim()

' info(at)mentes.com.tr
' ibrahim Yorulmaz - Antalya - 2007
' o 532 625 55 66

Dim KacLWPoly As Integer
Dim KacLWPoly2 As Integer
Dim KacPoly As Integer
Dim KacPoly2 As Integer

Dim plineObj As AcadLWPolyline
Dim RegionObj As AcadRegion
Dim minPt As Variant
Dim maxPt As Variant
Dim returnPnt As Variant
Dim newBlock As AcadBlock
Dim BlockInsertionPoint(0 To 2) As Double
Dim explodedObjects As Variant
Dim i As Integer
Dim numDivs As Long
numDivs = 2

On Error Resume Next

Do

' Function SecimLWPoly le LWPolyLine ve Region ları say
KacLWPoly = SecimLWPoly("say")
' Function KacPoly le hata durumnda oluşacak PolyLine ları say
KacPoly = HataPoly("say")

returnPnt = ThisDrawing.Utility.GetPoint(, "Kesişen çizgilerin ORTASINDA bir NOKTA gösteriniz: ")

If Error = "User input is a keyword" Or Error = "Method 'GetPoint' of object 'IAcadUtility' failed" Then
ThisDrawing.Utility.prompt "STrim Sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Exit Sub
End If

' Bounary hatalı olmaması için ZoomAll uygula
ThisDrawing.Application.ZoomAll

ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary" & vbCr & Replace(returnPnt(0), ",", ".") & "," & Replace(returnPnt(1), ",", ".") & vbCr & vbCr & "YES" & vbCr & Chr(3)

' Function SecimLWPoly le LWPolyLine ve Region ları say
KacLWPoly2 = SecimLWPoly("say")
' Function KacPoly le hata durumnda oluşacak PolyLine ları say
KacPoly2 = HataPoly("say")

' eğer cizimde yeni PolyLine yoksa
If KacLWPoly = KacLWPoly2 Then

' hata oluşma ihtimaline karsılık
' polylineları karsılaştır
' fazla polyline ları sil
If KacPoly <> KacPoly2 Then
HataPoly "sil", (KacPoly2 - KacPoly)
ThisDrawing.Utility.prompt "Üzgünüz AutoCAD alanı kapalı olarak algılamıyor. :( !" & vbCrLf
End If

' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious

ThisDrawing.Utility.prompt "Lütfen Kapalı bir alan olduğunu kontrol ediniz. !" & vbCrLf
Else

' yeni block yap
BlockInsertionPoint(0) = 0: BlockInsertionPoint(1) = 0: BlockInsertionPoint(2) = 0
Set newBlock = ThisDrawing.Blocks.Add(BlockInsertionPoint, "STrimBlockGecici")

' yeni oluşturulan Polyline(boundary) ı yakala
' Function SecimLWPoly("yakala") la yeni oluşturulan Polyline nın ObjectID sini öğren
If ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala")).ObjectName = "AcDbPolyline" Then

Set plineObj = ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala"))

' Trim in hatalı olmaması için ZoomObject uygula
ThisDrawing.SendCommand "._zoom _o (handent """ & plineObj.handle & """) "
ThisDrawing.SendCommand Format$(Chr(10))

' Yakalanan PolyLine a Explode uygula (patlat linelar cıksın ortaya)
explodedObjects = plineObj.Explode

ElseIf ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala")).ObjectName = "AcDbRegion" Then

Set RegionObj = ThisDrawing.ObjectIdToObject(SecimLWPoly("yakala"))

' Trim in hatalı olmaması için ZoomObject uygula
ThisDrawing.SendCommand "._zoom _o (handent """ & RegionObj.handle & """) "
ThisDrawing.SendCommand Format$(Chr(10))

' Yakalanan Region a Explode uygula (patlat splinelar cıksın ortaya)
explodedObjects = RegionObj.Explode
Else
' düşünemediğin bir şey var pas geç çık
' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious
ThisDrawing.Utility.prompt "Üzgünüz hata oluştu !!!."
ThisDrawing.Utility.prompt "STrim Sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Exit Sub

End If

' explode sonucu ortaya cıkan objeleri yakala
For i = 0 To UBound(explodedObjects)
' Divide ile orta noktaktasına block(STrimBlockGecici) yapıştır
ThisDrawing.SendCommand "._divide (handent """ & explodedObjects(i).handle & """) "
ThisDrawing.SendCommand Format$("BLOCK") & " "
ThisDrawing.SendCommand Format$("STrimBlockGecici") & " "
ThisDrawing.SendCommand Format$(Chr(10))
ThisDrawing.SendCommand Format$("Y")
ThisDrawing.SendCommand Format$(Chr(10))
ThisDrawing.SendCommand Format$(numDivs) & " "
explodedObjects(i).Delete
Next

' Yakalanan PolyLine ı yok et
' Yakalanan Region u yok et
' not: neden patlatınca yok olmuyor anlamadım :s
plineObj.Delete
RegionObj.Delete

BlockTrim ("STrimBlockGecici")

' yeni blocku yok et
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-purge B STrimBlockGecici" & vbCr & "Y" & vbCr & "Y" & vbCr & Chr(3)
' Trim in hatalı olmaması için yapılan ZoomObject i geri al
ThisDrawing.Application.ZoomPrevious
' Boundary hatalı olmaması için yapılan ZoomAll geri al
ThisDrawing.Application.ZoomPrevious

End If

Loop

End Sub

Ekler:
Dosya: NSTrim.zip
Dosya içeriği: NSTrim.bas

Kolay gelsin.

STrim

noreply@blogger.com (Biolight) — Thu, 27 Sep 2007 16:24:00 +0300

Merhaba,
Süper Trim kısaca STrim ;)
STrim.bas dosyası yükledikten sonra STrim Macrosu çalıştırdığınız da
Sizden Kesişen çizgilerin ORTASINDA bir NOKTA göstermeniz istenir.

Örnek olarak resmi inceleyiniz

(STrim uygulamadan önceki durum)

STrim Makrosu çalıştırılıp kesişen çizgilerin ortasında ki
bir noktayı Tıkladığınızda (boş kapalı alan: Hatch alanı şeçermiş gibi)
sonucu aşağıda ki resimde inceleyebilirsiniz.

(STrim uygulandıktan sonra ki durum)

Komutan çıkmadan birden fazla kapalı alan seçebilirsiniz.
Esc, Space, Enter veya Fare Sağtıklandıgında STrim sonlandırılır.

Function SecimPoly(Optional kim As String = "yakala")
Dim fType(0) As Integer, fData(0)
Dim PolySS As AcadSelectionSet
Dim Secili As Integer

On Error Resume Next
Set PolySS = ThisDrawing.SelectionSets("PolySS")
If Err Then Set PolySS = ThisDrawing.SelectionSets.Add("PolySS")
PolySS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "LWPOLYLINE"

' Tüm PolyLine ları seç
PolySS.Select acSelectionSetAll, , , fType, fData

' gelen kim değeri yakala ise
If kim = "yakala" Then
' yeni(not: ilginçtir ilk oluyor(0 değeri)) oluşturulan Polyline nın ObjectID ver
SecimPoly = PolySS.Item(0).ObjectID
Else
' kim değeri yakala DEĞİLSE çizimde ki PolyLine miktarını ver
SecimPoly = PolySS.Count
End If

PolySS.Delete
End Function
Private Sub LineCenterTrim()
Dim fType(0) As Integer
Dim fData(0) As Variant
Dim LayerSS As AcadSelectionSet
Dim Secili As Integer
Dim ScaleLine As AcadLine
Dim Sp(0 To 2) As Double
Dim Ep(0 To 2) As Double
Dim Str As ACAD_POINT

On Error Resume Next
Set LayerSS = ThisDrawing.SelectionSets("LayerSS")
If Err Then Set LayerSS = ThisDrawing.SelectionSets.Add("LayerSS")
LayerSS.Clear

fType(0) = 8: fData(0) = "STrimgecici"

' STrimgecici Layerinde ki tüm objeleri seç
LayerSS.Select acSelectionSetAll, , , fType, fData

' Son objeji sil
LayerSS.Item(LayerSS.Count - 1).Delete

' Son obje silindiği için - 2 kadar döngü
For Secili = 0 To LayerSS.Count - 2

' Lineları tek tek yakala
Set ScaleLine = LayerSS.Item(Secili)

' Line ların başlangıç noktası koordinatını öğren
Sp(0) = ScaleLine.StartPoint(0): Sp(1) = ScaleLine.StartPoint(1): Sp(2) = ScaleLine.StartPoint(2)

' Line ları başlangıç noktasından tutarak 0.5 oranında Scale uygula
ScaleLine.ScaleEntity Sp, 0.5

' line ların son nokta koordinatlarını ögren
Ep(0) = ScaleLine.EndPoint(0): Ep(1) = ScaleLine.EndPoint(1): Ep(2) = ScaleLine.EndPoint(2)

' Str olarak hafızaya al
Str = Str & Replace(Ep(0), ",", ".") & "," & Replace(Ep(1), ",", ".") & "," & Replace(Ep(2), ",", ".") & vbCr

' Line ları yok et
LayerSS.Item(Secili).Delete
Next Secili

' Trim uygula tüm objeleri sec sonra Str noktalarını tıkla
ThisDrawing.SendCommand Chr(3) & Chr(3) & "trim" & vbCr & "ALL" & vbCr & vbCr & Str & vbCr
Str = ""

LayerSS.Delete
End Sub
Sub STrim()

' info(at)mentes.com.tr
' ibrahim Yorulmaz - Antalya
' o 532 625 55 66

Dim KacPoly As Integer
Dim KacPoly2 As Integer
Dim oPoly As AcadLWPolyline
Dim oCoords As Variant

On Error Resume Next

Do

' Function SecimPoly le PolyLineları say
KacPoly = SecimPoly("say")

Dim returnPnt As Variant
returnPnt = ThisDrawing.Utility.GetPoint(, "Kesişen çizgilerin ORTASINDA bir NOKTA gösteriniz: ")

If Error = "User input is a keyword" Or Error = "Method 'GetPoint' of object 'IAcadUtility' failed" Then
ThisDrawing.Utility.Prompt "STrim Sonlandırıldı."
ThisDrawing.SendCommand Chr(3) & Chr(3)
Exit Sub
End If

Pnt0 = Replace(returnPnt(0), ",", ".")
Pnt1 = Replace(returnPnt(1), ",", ".")
ThisDrawing.SendCommand Chr(3) & Chr(3) & "-boundary" & vbCr & Pnt0 & "," & Pnt1 & vbCr & vbCr

' Function SecimPoly le PolyLineları say
KacPoly2 = SecimPoly("say")

' eğer cizimde yeni PolyLine yoksa
If KacPoly = KacPoly2 Then
ThisDrawing.Utility.Prompt "Lütfen Kapalı bir alan olduğunu kontrol ediniz. !" & vbCrLf
Else
' yeni oluşturulan Polyline(boundary) ı yakala
' Function SecimPoly("yakala") la yeni oluşturulan Polyline nın ObjectID sini öğren
Set oPoly = ThisDrawing.ObjectIdToObject(SecimPoly("yakala"))

' STrimgecici ismin de yeni Layer oluştur
ThisDrawing.Layers.Add ("STrimgecici")

' Yakalanan PolyLine nın Layerini STrimgecici yap
oPoly.Layer = "STrimgecici"

' Yakalanan PolyLine a Explode uygula (patlat linelar cıksın ortaya)
oPoly.Explode

' Private Sub LineCenterTrim() uygula
' Lineları bul
' ilk noktasından tutarak 0.5 scala yap
' son noktaları bul
' lineları yok et
' Sonnoktalara göre çizime trim uygula
LineCenterTrim

' Oluşturdugumuz STrimgecici Layerini yok et
ThisDrawing.Layers("STrimgecici").Delete

End If

Loop

End Sub

Ekler:
Dosya: STrim.zip
Dosya içeriği: STrim.bas

Kolay gelsin

BlocksExplode

noreply@blogger.com (Biolight) — Wed, 12 Sep 2007 23:00:00 +0300

Merhaba,

BlocksExplode.bas dosyası yükledikten sonra
BlockPatlat Macrosu çalıştırdığınız da
Sizden çiziminiz de patlatmak istediğiniz blocklardan bir tanesini seçmenizi ister
block seçtiğiniz de aynı blokların hepsini patlatır yani Explode uygular
esc, space veya enter tıklanırsa macro sonlanır

Public Sub BlocksExplode(BlockToFind As String)

Dim fType(0 To 1) As Integer, fData(0 To 1)
Dim BlockSS As AcadSelectionSet
Dim secili As Integer

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear
On Error GoTo 0

fType(0) = 0: fData(0) = "INSERT": fType(1) = 2: fData(1) = BlockToFind
BlockSS.Select acSelectionSetAll, , , fType, fData

For secili = 0 To BlockSS.Count - 1
BlockSS.Item(secili).Explode
Next secili

BlockSS.Delete
End Sub
Sub BlockPatlat()
Dim objEnt As AcadObject

On Error Resume Next

Do
Do While Err = 0

ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Patlatmak istediğiniz Blocklara ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz !" & vbCrLf
Err.Clear
Exit Do
End If
End If

If objEnt.ObjectName = "AcDbBlockReference" Then
BlocksExplode (objEnt.Name)
Else
ThisDrawing.Utility.Prompt "Lütfen BLOCK Seçiniz !" & vbCrLf
Err.Clear
Exit Do
End If

Loop
Loop

End Sub

Ekler:
Dosya: BlocksExplode.zip
Dosya içeriği: BlocksExplode.bas

Kolay gelsin.

Dwg2Jpg

noreply@blogger.com (Biolight) — Mon, 3 Sep 2007 22:40:00 +0300

Merhaba,
DWG dosyasını JPG dosyasına dönüştüren Makro Function'u
yeni oluşturulacak olan jpg dosyası
dwg dosyanızla aynı klasöre kayıt edilecektir.

Function Dwg2Jpg(DwgFullName As String)
Dim NewDwg As AcadDocument
Set NewDwg = Documents.Open(DwgFullName)

Dim JpgName As String
JpgName = Left(DwgFullName, (InStr(DwgFullName, ".dwg")) - 1) & ".jpg"

Dim plotFileName As String
plotFileName = "PublishToWeb JPG.pc3"

Dim corner1(0 To 1) As Double
Dim corner2(0 To 1) As Double
corner1(0) = ThisDrawing.Limits(0): corner1(1) = ThisDrawing.Limits(1)
corner2(0) = ThisDrawing.Limits(2): corner2(1) = ThisDrawing.Limits(3)

ThisDrawing.ActiveLayout.CenterPlot = True
ThisDrawing.ActiveLayout.StandardScale = acScaleToFit
ThisDrawing.ActiveLayout.SetWindowToPlot corner1, corner2
ThisDrawing.ActiveLayout.GetWindowToPlot corner1, corner2
ThisDrawing.ActiveLayout.PlotType = acWindow

Dim result As Boolean
result = ThisDrawing.Plot.PlotToFile(JpgName, plotFileName)

NewDwg.Close

Set NewDwg = Nothing
End Function

Sub TestJpg()
Dwg2Jpg "C:\Documents and Settings\bla bla\My Documents\MyProgram\AutocadVBA\ElkBlock\Evaevienetanj.dwg"
Beep
End Sub

Ekler:
Dosya: Dwg2Jpg.zip
Dosya içeriği: Dwg2Jpg.bas

Kolay gelsin

Dwg2Bmp

noreply@blogger.com (Biolight) — Sun, 2 Sep 2007 20:46:00 +0300

Merhaba,
DWG dosyasını BMP dosyasına dönüştüren Makro Function'u
yeni oluşturulacak olan bmp dosyası
dwg dosyanızla aynı klasöre kayıt edilecektir.

Function Dwg2Bmp(DwgFullName As String)
Dim NewDwg As AcadDocument
Set NewDwg = Documents.Open(DwgFullName)

Dim DwgPath As String
Dim DwgName As String
DwgPath = ThisDrawing.Path
DwgName = Left(ThisDrawing.Name, (InStr(ThisDrawing.Name, ".dwg")) - 1)

Dim exportFile As String
exportFile = DwgPath & "\" & DwgName

Dim mode As Integer
Dim corner1(0 To 2) As Double
Dim corner2(0 To 2) As Double
Dim BlockSS As AcadSelectionSet

On Error Resume Next
Set BlockSS = ThisDrawing.SelectionSets("BlockSS")
If Err Then Set BlockSS = ThisDrawing.SelectionSets.Add("BlockSS")
BlockSS.Clear

mode = acSelectionSetCrossing
corner1(0) = ThisDrawing.Limits(0): corner1(1) = ThisDrawing.Limits(1): corner1(2) = 0
corner2(0) = ThisDrawing.Limits(2): corner2(1) = ThisDrawing.Limits(3): corner2(2) = 0

BlockSS.Select mode, corner1, corner2

ThisDrawing.Export exportFile, "bmp", BlockSS

BlockSS.Delete

NewDwg.Close

Set NewDwg = Nothing

End Function
Sub TestBmp()
Dwg2Bmp "C:\Documents and Settings\bla bla\My Documents\MyProgram\AutocadVBA\ElkBlock\Evaevienetanj.dwg"
Beep
End Sub

Ekler:
Dosya: Dwg2Bmp.zip
Dosya içeriği: Dwg2Bmp.bas

Kolay gelsin

LayerBack

noreply@blogger.com (Biolight) — Sat, 1 Sep 2007 22:00:00 +0300

Merhaba,
çiziminiz de ki bir objeyi seçmeniz istenir ve
seçtiğiniz objeye ait Layer'e ait objelerin hepsini arkaya atar.

AutoCAD diliyle anlatmak gerekir se
Layer e ait tüm objeleri seçer ve DrawOrder Send To Back uygular.

Public Sub SendLayerBack(strLayer As String)
Dim fType(0) As Integer
Dim fData(0) As Variant
fType(0) = 8: fData(0) = strLayer

With ThisDrawing.PickfirstSelectionSet
.Clear
.Select acSelectionSetAll, , , fType, fData
If .Count > 0 Then ThisDrawing.SendCommand ("DrawOrder p Back") & vbCr
End With

End Sub

Sub LayerBack()
Dim objEnt As AcadObject
Dim i As Integer

On Error Resume Next
TEKRARSEC:
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Arkaya göndermek istediğiniz Layer e ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
GoTo TEKRARSEC
End If
End If

SendLayerBack objEnt.Layer

GoTo TEKRARSEC

End Sub

Ekler:
Dosya: LayerBack.zip
Dosya içeriği: LayerBack.bas

Kolay gelsin.

Düzeltme : 06.09.2007

Programcı bir arkadaşım uyarıda bulundu
Kodlar da kullandığım GoTo nun
eskide kaldığı ve artık kullanılmadığını söyledi.

Bizde arkadaşımızı kırmadık
kodları evirdik çevirdik, olmadı yan yatırdık hallettik :)

Buyrun alternatif yeni kodlar :

Sub LayerBack()
Dim objEnt As AcadObject

On Error Resume Next

Do
Do While Err = 0
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Arkaya göndermek istediğiniz Layer e ait bir obje seçiniz: "
If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
Exit Do
End If
End If
SendLayerBack objEnt.Layer
Loop
Loop

End Sub

Kolay gelsin.

LayerOff - LayerOnAll

noreply@blogger.com (Biolight) — Sat, 1 Sep 2007 14:00:00 +0300

Merhaba,
çiziminizde ki bir objeyi seçmeniz istenir ve
sectiğiniz objeye ait Layer i kapatır.

eğer AutoCAD'iniz de expresstools yüklü ise
komut satırına layoff yazdıgınız da
oluşan işlemin aynısını gerçekleştirecektir

Sub LayerOff()
Dim objEnt As AcadObject
Dim i As Integer

On Error Resume Next
TEKRARSEC:
ThisDrawing.Utility.GetEntity objEnt, emptyPt, "Kapatmak istediğiniz Layer e ait bir obje seçiniz: "

If Err <> 0 Then
' esc, space veya enter tıklanırsa sonlandır
If CInt(ThisDrawing.GetVariable("ERRNO")) = 52 Then
ThisDrawing.SendCommand Chr(3)
Err.Clear
Exit Sub
Else
ThisDrawing.Utility.Prompt "Obje Seçmediniz" & vbCrLf
Err.Clear
GoTo TEKRARSEC
End If
End If

If ThisDrawing.ActiveLayer.Name <> objEnt.Layer Then
ThisDrawing.Layers(objEnt.Layer).LayerOn = False
ThisDrawing.Utility.Prompt objEnt.Layer & " Layeri Kapatıldı." & vbCrLf
Else
Dim SoruEH As String
SoruEH = "Evet Hayır"
ThisDrawing.Utility.InitializeUserInput 1, SoruEH
Dim returnString As String
returnString = ThisDrawing.Utility.GetKeyword("Kapatmak istediğiniz (" & objEnt.Layer & ") Layeri Aktif! Yine de kapatmak istiyormusun (Evet/Hayır): ")
If returnString = "Evet" Then
ThisDrawing.Layers(objEnt.Layer).LayerOn = False
ThisDrawing.Utility.Prompt objEnt.Layer &" Layeri Kapatıldı." & vbCrLf
End If
End If

GoTo TEKRARSEC

End Sub

Sub LayerOnAll()
Dim LayerAll As AcadLayers
Dim LayerOne As AcadLayer
Set LayerAll = ThisDrawing.Layers
On Error Resume Next
For Each LayerOne In LayerAll
LayerOne.LayerOn = True
Next LayerOne
End Sub

Ekler:
Dosya: LayerOff.zip
Dosya içeriği: LayerOff.bas

Kolay gelsin.

Giriş04

noreply@blogger.com (Biolight) — Sun, 26 Aug 2007 00:50:00 +0300

Merhaba,

5. AutoCAD başka programlarla etkileşimli çalışması :

AutoCAD in bazen başka bir programla
iletişim halinde olmasını isteyebiliriz.

Örneğin:
AutoCAD doyamız da kullandığımız blockların veya
Layerlerin listesini bir Excel dosyasına kaydetmek isteyebiliriz.
Tabi ki bu programın ille de Excel olma şartı yok
bazen Word veya başka bir program olabilir.

Bu tür işlemler için VBA kodlarımız da

Dim Excel As Excel.Application

tarzın da kodlar kullanmamız gerekir.

Ve bu tür kodların aşağıda ki hatayı vermemesi için

VB Editör penceremiz de ufak bir ayar yapmamız gerekmektedir.
VBE penceresi nasıl açılır ? (resmi inceleyiniz)

Açılacak olan VBE (Visual Basic Editor) Menüsünden
Tools - References... tıklayınız

Bu örnek anlatım da Excel programını kullandım
Microsoft Excel 11.0 Object Library i bulup
yanında ki kutucuğu işaretleyin ve OK tıklayın
Not: Kullandığınız Excel sürümüne göre 11.0 değişebilir (9.0 veya 5.0)

Artık yüklediğiz VBA kodlarında ki Macroları Çalıştırabilirsiniz.

Kolay gelsin.

Giriş03

noreply@blogger.com (Biolight) — Sat, 25 Aug 2007 14:05:00 +0300

Merhaba,

4. VBA - DVB dosyası nasıl İPTAL edilir :
AutoCAD ana menüden
Toos - Load Application... tıklayınız
veya Command: satırına AP yazıp enter tıklayın
aynı işlemi gerçekleştirmiş olursunuz.

4.a eğer iptal etmek istediğiniz *.dvb dosyası
geçici yani sadece çalışmakta olduğunuz AutoCAD dosyasında ise
açılacak olan pencerenin Loaded Applications sekmesinden
dvb dosyanızı seçip Unload tıklamanız yeterlidir.

4.b eğer iptal etmek istediğiniz *.dvb dosyası
Tüm AutoCAD dosyalarınız da etkinse
Açılacak olan pencerenin sağ alt tarafta bulunan
Startup Suite bölmesinde ki
Contents... (çanta resminin altında) tıklayınız
yeni bir pencere açılacak.

Önceden yüklediğiniz dosyaları göreceksiniz.
Remove butonu ilk başta tıklanır Değildir.
iptal etmek istediğiniz dosyayı seçtiğiniz de
Remove butonu tıklanır olacaktır.

Remove butonunu tıklayınız

ardından tüm açık pencereleri kapatıp Close Close
AutoCAD ana penceresine dönünüz.

artık dvb dosyanız iptal edilmiştir

Kolay gelsin.

Giriş02

noreply@blogger.com (Biolight) — Sat, 25 Aug 2007 14:00:00 +0300

Merhaba,

3. VBA - DVB dosyası AutoCAD e nasıl YÜKLENİR :
AutoCAD ana menüden
Toos - Load Application... tıklayınız
veya Command: satırına AP yazıp enter tıklayın
aynı işlemi gerçekleştirmiş olursunuz.

Açılacak olan pencere de *.dvb (örnekte: BioCAD.dvb) dosyamızı buluyoruz

Şimdi karar zamanı

3.a. Eğer kodları bir kereliğine yani
AutoCAD dosyanız açıkken kullanacaksanız

Dosyayı seçip Load tıklamanız yeterli
Pencereyi kapatıp dvb dosyasında ki makroları
Giriş01 de anlatıldıgı gibi çalıştıra bilirsiniz.

3.b. Eğer dvb dosyasının
AutoCAD in her dosyasın da çalışmasını istiyorsanız

sağ alt tarafta bulunan Startup Suite bölmesinde ki
Contents... (çanta resminin altında) tıklayınız
yeni bir pencere açılacak.

Add... tıklayıp tüm AutoCAD dosyalarında
çalışmasını istediğiniz *.dvb (örnek: BioCAD.dvb)
dosyasını bulup Add tıklayın

tüm açık pencereleri kapatıp Close Close
AutoCAD ana penceresine dönünüz.

artık DVB dosyasında ki kodlar kullanıma hazırdır.

Kolay gelsin.

Giriş01

noreply@blogger.com (Biolight) — Sat, 25 Aug 2007 13:00:00 +0300

Merhaba,

1. VBA - Macro kodlar AutoCAD e nasıl yazılır(yüklenir) :
AutoCAD ana menüden
Toos - Macro - Visual Basic Editor tıklayınız
veya Alt+F11 tıkladığızda da aynı işlemi gerçekleştirmiş olursunuz.

kodları direk yazmak isterseniz eğer
yeni açılacak pencerede ki VBE (Visual Basic Editor) Menüsünden
Insert - Module tıklayınız

sağ tarafta açılacak olan boş module sayfasına kodları yazıyorsunuz

eğer kodlar direk *.bas dosya sı olarak verilmişse
VBE penceresin deki menuden
File - Import File... tıklayıp
*.bas dosyasını bulup Aç tıklayınız

2. VBA - Macro kodlar AutoCAD de nasıl çalıştırılır :

Not: Ben şuan örnek olması için LayerBack.bas dosyasını yükledim
şimdi bu kodları çalıştırmasını göstereceğim.

Kodlarımızı yukarıda ki şekilde yazdık veya yükledikten sonra
VBE penceresini kapatıyor ve AutoCAD ana penceresine geliyoruz
Toos - Macro - Macros... tıklıyoruz,
veya Command: satırına VBARUN yazıp enter tıklayın,
veya Alt+F8 tıkladığızda da aynı işlemi gerçekleştirmiş olursunuz.

Açılan pencerede macromuzu seçip (bu örnekte LayerBack Macrosu)
RUN tıklıyoruz ve kodlarımız çalışmaya başlıyor

ÖNSÖZ

noreply@blogger.com (Biolight) — Sat, 25 Aug 2007 12:17:00 +0300

Merhaba VBA severler,

Sonunda bir blog oluşturmaya karar verdim,

vba yı seviyor ama bu konuda konuşabilecek insan bulmak oldukca zorlanıyorum

belki benim gibi VBA yı seven ve de AutoCAD kullanan kişiler vardır düşüncesiyle blogu oluşturuyorum.

Neleri paylaşacağım ;

genelde kendi yazdığım kodları paylaşamayı düşünüyorum bunlar *.dvd *.bas veya direk kod olabilir.

Esasında ilk olarak vba nedir, ne değildir ve nasıl yüklenip nasıl çalıştırılır şeklinde bir açıklama yazmak gerekmek te yeni vba severler kazanmak adına ;)

ama sanırım ben biraz üşengecim direk kod yazmak kolayıma geliyor,

bir gün eser ve çoşarsam detaylı bir vba başlangıç düzeyi anlatırım.

şimdi kendimi tanıtıyım ve blog başlasın artık

Ben ibrahim Yorulmaz www de biolight olarak tanınıyorum

28.08.1970 yılında Antalya da dünya ya gelmişim

evli bir erkek, bir kız çocuk babasıyım

Trakya üniversitesi Fen-Edebiyat fakültesi

Biyoloji mezunuyum

elektrik tesisat taaahhüt işleri üzerine çalışmaktayım

AutoCAD'i 2 boyut lu çizimler için kullanmaktayım

çoğunluk la yaptığımız işlerle ilgili

ataşmanlar hazırlamak için kullanıyorum

ilk kullandığım AutoCAD versiyonu R12 dir.