BlocksExplode

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

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

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