Dwg2Bmp

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

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

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.