ObjectDBX

[tyrese69_]

Bonsoir,

Aprés avoir lu le sujet sur les objets DBX du forum vlisp,

j'ai cherché sur le net ce qui existe en VBA.

 

Un peut en vrac le résultat !

 

Juste un petit point par rapport Vlisp, par le VBA l'accès aux possibiltés de ces fonctions est

beaucoup plus aisé.

 

Mais le but de toute chose varie selon chacun !

 

Daniel OLIVES

Lyon - FRANCE

 

Option Explicit

 

' Module

Type MessPunkt

Rechtswert As Double

Hochwert As Double

Höhe As Double

PNR As String

End Type

 

Public Punkte() As MessPunkt

'

 

 

' Opening a drawing with ObjectDBX

'Function dbxOpen(fn As String) As AXDB16Lib.AxDbDocument

' If Dir(fn) <> "" Then

' Dim dwgX As New AXDB16Lib.AxDbDocument

' dwgX.Open (fn)

'

' If Err.Number <> 0 Then

' If Err.Number <> -2147467259 Then 'Invalid filename

' regObjectDBX

' dwgX.Open (fn)

' End If

' End If

' Set dbxOpen = dwgX

' End If

'End Function

'

 

 

Sub ImportLayout(ByVal lyName As String, ByVal fileName As String)

Dim cmdName As String

cmdName = Join(Split(fileName, "\", , 1), "/")

cmdName = "(command ""._Layout"" ""_T"" """ & cmdName & """ """ & lyName & """) "

ThisDrawing.SendCommand cmdName

End Sub

'

 

 

 

' Add reference to AutoCAD/ObjectDBX Common 16.0 Type Library (axdb16enu.dll)

' This samples copies all dimstyles from specified drawing to the current drawing

' Existing dimstyles are not affected

Public Sub ImportDimstyles()

Dim oAxDbDoc As New AxDbDocument

oAxDbDoc.Open "c:\DimStyles.dwg"

Dim oObj() As Object

Dim oDs As AcadDimStyle

Dim i As Integer

For i = 0 To oAxDbDoc.DimStyles.Count - 1

ReDim Preserve oObj(i)

Set oObj(i) = oAxDbDoc.DimStyles(i)

Next

oAxDbDoc.CopyObjects oObj, ThisDrawing.Database.DimStyles

End Sub

'

 

 

' 2000-03-08

' By Jimmy Bergmark

' Copyright © 1997-2003 JTB World, All Rights Reserved

 

' Website: www.jtbworld.com

' E-mail: info@jtbworld.com

' Runs in All AutoCAD version if axdb1'x'.dll (must be referenced)

' Example of batch for listing all layers on all drawings in a directory.

'

' http://www.jtbworld.com/VBA/listlayer.htm

'

' Corrected by d.OLIVES - for All version and test vbReadOnly

' 2007-02-02

 

Private Sub ListLayers()

 

 

Dim indir As String

Dim elem As Object

Dim filenom As String

Dim WholeFile As String

Dim newHeight As Double

Dim objDbx As AxDbDocument

Dim MyAttr As Integer

Dim acadTyp As String

 

acadTyp = Left$(ThisDrawing.Application.Version, 2)

 

Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument." & acadTyp)

 

indir = "C:\Program Files\Egid\Cache"

filenom = Dir$(indir & "\*.dwg")

MyAttr = GetAttr(indir & "\" & filenom)

Do While filenom <> ""

ThisDrawing.Utility.Prompt vbCrLf & "File: " & filenom

ThisDrawing.Utility.Prompt vbCrLf & "-----------------"

WholeFile = indir & "\" & filenom

objDbx.Open WholeFile

For Each elem In objDbx.Layers

ThisDrawing.Utility.Prompt vbCrLf & elem.name

Next

Set elem = Nothing

If (MyAttr And vbReadOnly) <> vbReadOnly Then

objDbx.SaveAs WholeFile

End If

filenom = Dir$

ThisDrawing.Utility.Prompt vbCrLf

Loop

End Sub

'

 

'

' 2000-03-08

' By Jimmy Bergmark

' Copyright © 1997-2003 JTB World, All Rights Reserved

' Website: www.jtbworld.com

' E-mail: info@jtbworld.com

' Runs in All AutoCAD version if axdb1'x'.dll (must be referenced)

' Example of batch for listing all xrefs on all drawings in a directory.

'

' http://www.jtbworld.com/VBA/listxref.htm

'

' Corrected by d.OLIVES - for All version and test vbReadOnly

' 2007-02-02

 

Private Sub ListXREF()

 

Dim indir As String

Dim elem As Object

Dim filenom As String

Dim WholeFile As String

Dim newHeight As Double

Dim objDbx As AxDbDocument

Dim MyAttr As Integer

Dim acadTyp As String

 

acadTyp = Left$(ThisDrawing.Application.Version, 2)

 

Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument." & acadTyp)

indir = "C:\Program Files\Egid\Cache"

filenom = Dir$(indir & "\*.dwg")

MyAttr = GetAttr(indir & "\" & filenom)

Do While filenom <> ""

ThisDrawing.Utility.Prompt vbCrLf & "File: " & filenom

ThisDrawing.Utility.Prompt vbCrLf & "-----------------"

WholeFile = indir & "\" & filenom

objDbx.Open WholeFile

For Each elem In objDbx.Blocks

If elem.IsXRef = True Then

ThisDrawing.Utility.Prompt vbCrLf & elem.name

End If

Next

Set elem = Nothing

If (MyAttr And vbReadOnly) <> vbReadOnly Then

objDbx.SaveAs WholeFile

End If

filenom = Dir$

ThisDrawing.Utility.Prompt vbCrLf

Loop

End Sub

'

 

' Runs in All AutoCAD version if axdb1'x'.dll (must be referenced)

' Example of batch for listing all SummaryInfo = DWG Properties in a directory.

' by d.OLIVES - for All version and test vbReadOnly

' 2007-02-02

 

Private Sub ListPROPS()

 

Dim indir As String

Dim elem As Object

Dim filenom As String

Dim WholeFile As String

Dim newHeight As Double

Dim objDbx As AxDbDocument

Dim MyAttr As Integer

Dim acadTyp As String

 

Dim myProps As AcadSummaryInfo

Set myProps = ThisDrawing.SummaryInfo

myProps.RevisionNumber = 1

Set myProps = Nothing

 

 

acadTyp = Left$(ThisDrawing.Application.Version, 2)

 

Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument." & acadTyp)

indir = "C:\Program Files\Egid\Cache"

filenom = Dir$(indir & "\*.dwg")

MyAttr = GetAttr(indir & "\" & filenom)

Do While filenom <> ""

ThisDrawing.Utility.Prompt vbCrLf & "File: " & filenom

ThisDrawing.Utility.Prompt vbCrLf & "-----------------"

WholeFile = indir & "\" & filenom

objDbx.Open WholeFile

ThisDrawing.Utility.Prompt vbCrLf & "Auteur : " & objDbx.SummaryInfo.Author

Set elem = Nothing

If (MyAttr And vbReadOnly) <> vbReadOnly Then

objDbx.SaveAs WholeFile

End If

filenom = Dir$

ThisDrawing.Utility.Prompt vbCrLf

Loop

End Sub

'

 

' Pour VB

'http://discussion.autodesk.com/thread.jspa?messageID=5167190

Public Sub DbxRefTest()

' To test, set references to:

'Microsoft Visual Basic for Applications Extensibility 5.3

'C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6EXT.OLB

'AutoCAD/ObjectDBX Common 16.0 Type Library

'C:\Program Files\Common Files\Autodesk Shared\axdb16enu.tlb

'Run in: AutoCAD 2007

 

Dim Dbx As AxDbDocument

Dim i As Integer

Dim oVBE As VBE

 

Dim oVBP As VBProject

 

Dim Version As String

 

Version = Mid(ThisDrawing.GetVariable("acadver"), 1, 2)

 

'Fix Reference

Set oVBE = Application.VBE

Set oVBP = oVBE.ActiveVBProject

 

With oVBP.References

For i = 1 To .Count

If .Item(i).name Like "AXDBLib" Then

If Not .Item(i).Description Like _

"AutoCAD/ObjectDBX Common " & _

Version & ".0 Type Library" Then

.Remove .Item(i)

.AddFromFile _

"C:\Program Files\Common Files" & _

"\Autodesk Shared\axdb" & _

Version & "enu.tlb"

End If

GoTo FixRefDone

End If

Next

End With

FixRefDone:

Set oVBP = Nothing

Set oVBE = Nothing

 

 

'Get Template Dbx

If CInt(Version) < 16 Then

Set Dbx = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument")

Else

Set Dbx = AcadApplication.GetInterfaceObject("ObjectDBX.AxDbDocument." & Version) '

End If

Dbx.Open ThisDrawing.Application.Preferences.Files.QNewTemplateFile

 

'Clear Dbx

Set Dbx = Nothing

 

End Sub

'

 

 

Sub TestATTRIBUTS()

 

Dim objDbx As Object

'Dim arx As AxDbDocument

Dim col(0) As Object

Dim blockdef As AcadBlock

Dim acadTyp As String

 

Dim indir As String

Dim elem As Object

Dim filenom As String

Dim WholeFile As String

Dim newHeight As Double

'Dim objDbx As AxDbDocument

Dim MyAttr As Integer

 

Dim Anzahl As Long

Dim Entity As AcadEntity

Dim BlockRef As AcadBlockReference

Dim InsPkt As Variant

Dim PNR As String

Dim Attr As AcadAttributeReference

ReDim Punkte(0 To 0)

acadTyp = Left$(ThisDrawing.Application.Version, 2)

 

' For Each blockdef In objDbx.Blocks

' If blockdef.IsLayout = False Then

' Set col(0) = blockdef

' Call objDbx.CopyObjects(col, ThisDrawing.Blocks)

' End If

' Next blockdef

 

Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument." & acadTyp)

indir = "C:\TEMP\T_Essai"

filenom = Dir$(indir & "\*.dwg")

MyAttr = GetAttr(indir & "\" & filenom)

 

Do While filenom <> ""

 

WholeFile = indir & "\" & filenom

On Error GoTo Err_Trap

objDbx.Open WholeFile

 

 

For Each Entity In objDbx.PaperSpace

If Entity.EntityType = acBlockReference Then

If Entity.name = "Cartouche" Then

Anzahl = Anzahl + 1

Set BlockRef = Entity

InsPkt = BlockRef.insertionPoint

ReDim Preserve Punkte(0 To UBound(Punkte) + 1)

Punkte(UBound(Punkte)).Rechtswert = InsPkt(0)

Punkte(UBound(Punkte)).Hochwert = InsPkt(1)

Punkte(UBound(Punkte)).Höhe = InsPkt(2)

If BlockRef.HasAttributes Then

Dim varAttributes As Variant

Dim i As Integer

Dim strAttributes As String

 

ThisDrawing.Utility.Prompt vbCrLf & "File: " & filenom

ThisDrawing.Utility.Prompt vbCrLf & "-----------------"

varAttributes = BlockRef.GetAttributes

For i = LBound(varAttributes) To UBound(varAttributes)

strAttributes = strAttributes & " Tag: " & varAttributes(i).TagString & _

" Value: " & varAttributes(i).textString & " "

ThisDrawing.Utility.Prompt vbCrLf & "Auteur : " & strAttributes

ThisDrawing.SummaryInfo.Author = varAttributes(i).textString

strAttributes = ""

Next

 

PNR = 12345678

Punkte(UBound(Punkte)).PNR = PNR

If (MyAttr And vbReadOnly) <> vbReadOnly Then

objDbx.SaveAs WholeFile

End If

End If

End If

End If

Next Entity

 

' Cas du fichier déjà ouvert passe au fichie suivant

suite:

filenom = Dir$

ThisDrawing.Utility.Prompt vbCrLf

Loop

Set objDbx = Nothing

ThisDrawing.Utility.Prompt vbCrLf

Exit Sub

 

Err_Trap:

Select Case Err.Number

' Cas du fichier déjà ouvert

Case -2147467259

MsgBox "Attention ce fichier est déjà ouvert veuillez d'abord le fermer !", _

vbCritical, "Gestion des cartouches"

Err.Clear

GoTo suite

Case Else

Err.Clear

Exit Sub ' Sortie sous-routine

End Select

 

End Sub

' - - - - - - - - - - - - - - - - - - - - - - - - - -

Sub TestobjDbx()

 

Dim objDbx As Object

'Dim arx As AxDbDocument

Dim col(0) As Object

Dim blockdef As AcadBlock

Dim acadTyp As String

 

acadTyp = Left$(ThisDrawing.Application.Version, 2)

 

Set objDbx = ThisDrawing.Application.GetInterfaceObject("ObjectDBX.AxDbDocument." & acadTyp)

objDbx.Open "C:\Program Files\Egid\Modeles\2002\Cartouche.DWG"

 

For Each blockdef In objDbx.Blocks

If blockdef.IsLayout = False Then

Set col(0) = blockdef

Call objDbx.CopyObjects(col, ThisDrawing.Blocks)

End If

Next blockdef

 

Set objDbx = Nothing

End Sub