Aller au contenu
Problème de lien d'inscription (résolu ?) ×

Tableau attribut (constant et classique) de bloc + propriétés dynamiques

sechanbask

Par sechanbask
dans Routines VBA

 Partager

Messages recommandés

sechanbask Newbie

sechanbask

Posté(e)
Posté(e)

En fusionnant quelques codes (aide autoccad + http://www.cadforums.net/ftopic5694.html et http://www.cadtutor.net/forum/archive/index.php/t-14130.html) est en grattant là où ça fait mal :

 

Principe de foncitonnement: Autocad est l'interpréteur de la macro

 

Algorithme : (à décrire quand j'aurais du temps)

/Algorithme

 

 

 

J'ai mis dans la nom des colonnes un (*) pour indiquer que l'attribut est constant, c'est pour une future importation pour éviter de faire n'importe quoi...

 

Il reste des choses à faire tel que :

[surligneur]-ajout des coordonnées, des échelles, de la rotation et du calques[/surligneur]

[surligneur]-choix utilisateur sur la fermeture ou non du fichier Excel à la fin de la procédure[/surligneur]

-filtrer au début les entités afin de gagner du temps sur les boucles ?;

-ajout d'attribut possible pour créer un nouvel attribut dans le bloc (pas facile surtout si l'attribut est visible);

-connaitre les coordonnées des blocs sans avoir à rajouter un attributs (champs) dans les blocs;

-rajouter le calque du blocs;

-choix du tableur : Excel, OOO, ou données tubulées;

-gérer l'erreur lorsque le fichier existe et qu'il est déjà ouvert: ne pas le ouvrir un nouveau classeur et tenter d'enregistrer dessus, mais trouver le classeur dans les documents ouverts effacer la feuille et mettre les données dessus; et enregistrer à la fin;

-permettre à l'utilisateur de choisir un ou plusieurs dessins ouverts ou non pour en faire l'exportation;

-faire le code inverse pour que ce soit Excel qui fasse le boulot... comme ça le code sera utilisable par les Version LT...

-faire la même chose pour open office... et faire le code inverse...

 

Macro version 0.2:

Testé pour 2006 et 2008... à vous de faire le test et de me dire si ça marche pour d'autres versions.

 

Modifications notables :

voir les éléments surlignés dans la liste des souhaits.

ajout d'un forme donc la totalité du programme et disponible ici :

 

http://cjoint.com/?jkrk6lFXd5

 

le code du module

Sub lance_test()
Load TL_choix
TL_choix.Show
End Sub


Sub ExtractionVersTableur()

Dim X As Integer
Dim U As Integer
Dim p As Integer
Dim PointXYZ As Variant
Dim Nomcolonne As String
Dim Ent As AcadEntity
Dim AutocadApp As AcadApplication
Dim strNumeroVersion As String

Set AutocadApp = GetObject(, "AutoCAD.Application")
strNumeroVersion = Left(AutocadApp.Version, 4)

Debug.Print strNumeroVersion

'-------EXCEL
Dim Excelobj As Excel.Application
Dim ExcelobjWorkbook As Excel.Workbook
Dim ExcelobjSheet As Excel.Worksheet
'------------


On Error Resume Next
'capture l'objet autocad en tant qu'application
Set Excelobj = GetObject(, "Excel.Application")
   If Err <> 0 Then
   Err.Clear
   'si l'objet n'existe pas, c'est que l'application n'est pas lancée, donc création de l'objet
   Set Excelobj = New Excel.Application
       If Err <> 0 Then
       MsgBox "La macro n'a pu ouvrir Excel!" & Err.Number & Err.Description, vbExclamation
       Err.Clear
       End
       End If
   End If
On Error GoTo gestionEx


'il serait bien de ne pas tenter de ré-ouvrir le fichier s'il est déjà ouvert voir gestionEX n° 1004
Dim sngNbFeuille As Single
sngNbFeuille = Excelobj.SheetsInNewWorkbook
'les nouveaux classeur comporteront une feuille
Excelobj.SheetsInNewWorkbook = 1
'crée un nouveau classeur
Set ExcelobjWorkbook = Excelobj.Workbooks.Add
Set ExcelobjWorkbook = Excelobj.ActiveWorkbook


'rend visible l'application
If TL_choix.CheckBox1 = True Then
Excelobj.Visible = False
Excelobj.ScreenUpdating = False
Else
Excelobj.Visible = True
Excelobj.ScreenUpdating = False
End If


'récupère la feuille active
Set ExcelobjSheet = Excelobj.ActiveSheet
'l'enregistre dans le dossier par défaut sous Attribute.xls
On Error Resume Next
ExcelobjWorkbook.SaveAs "Propriétés des blocs et attributs.xls"
       If Err = 1004 Then
       MsgBox "déjà ouvert", vbExclamation
       Excelobj.ScreenUpdating = True
       Err.Clear
       End If

On Error GoTo gestionEx
'supprimer cette colonne pour les versions sans bloc dynamique
ExcelobjSheet.Cells(1, 1).Value = "Dynamique?"
ExcelobjSheet.Cells(1, 2).Value = "Nom du bloc utilisateur"
ExcelobjSheet.Cells(1, 3).Value = "Nom du bloc autocad"
ExcelobjSheet.Cells(1, 4).Value = "Handle"
ExcelobjSheet.Cells(1, 5).Value = "OwnerID"
ExcelobjSheet.Cells(1, 6).Value = "ObjectID"
ExcelobjSheet.Cells(1, 7).Value = "Position X"
ExcelobjSheet.Cells(1, 8).Value = "Position Y"
ExcelobjSheet.Cells(1, 9).Value = "Position Z"
ExcelobjSheet.Cells(1, 10).Value = "Rotation"
ExcelobjSheet.Cells(1, 11).Value = "Calque"
ExcelobjSheet.Cells(1, 12).Value = "Echelle X"
ExcelobjSheet.Cells(1, 13).Value = "Echelle Y"
ExcelobjSheet.Cells(1, 14).Value = "Echelle Z"


X = 0
Dim strNomPlan As String
strNomPlan = ThisDrawing.Name
ExcelobjSheet.Name = strNomPlan
'cherche parmi les entités de l'espce objet
For Each Ent In ThisDrawing.ModelSpace
'si l'entité est un bloc
If Ent.ObjectName = "AcDbBlockReference" Then
X = 1 + X



'enregistrer l'entité en tant que IAcadBlockReference2 ou
'IAcadBlockReference pour les versions sup à 2006
Dim oBkRef As IAcadBlockReference
'enregistrer l'entité en tant que IAcadBlockReference2
   Select Case strNumeroVersion
   Case 16.2
   sautfunction
   
   Case Else
   Set oBkRef = Ent
   End Select

'si l'entité est un bloc dynamique
If oBkRef.IsDynamicBlock = True Then
'récuperer dans v les propriétés dynamiques
Dim v As Variant
v = oBkRef.GetDynamicBlockProperties


For p = LBound(v) To UBound(v)
Dim oDynProp As AcadDynamicBlockReferenceProperty
Set oDynProp = v(p)

's'il y a plusieurs propriétés dynamiques
If IsArray(oDynProp.Value) Then
Dim J As Long

For J = LBound(oDynProp.Value) To UBound(oDynProp.Value)

'remplir les intitulés des colonnes supplémentaires
ExcelobjSheet.Cells(X + 1, 1).Value = "Oui"
ExcelobjSheet.Cells(X + 1, 2).Value = oBkRef.EffectiveName
ExcelobjSheet.Cells(X + 1, 3).Value = oBkRef.Name
ExcelobjSheet.Cells(X + 1, 4).Value = oBkRef.Handle
ExcelobjSheet.Cells(X + 1, 5).Value = oBkRef.OwnerID
ExcelobjSheet.Cells(X + 1, 6).Value = oBkRef.ObjectID

PointXYZ = oBkRef.InsertionPoint

ExcelobjSheet.Cells(X + 1, 7).Value = PointXYZ(0)
ExcelobjSheet.Cells(X + 1, 8).Value = PointXYZ(1)
ExcelobjSheet.Cells(X + 1, 9).Value = PointXYZ(2)
ExcelobjSheet.Cells(X + 1, 10).Value = oBkRef.Rotation
ExcelobjSheet.Cells(X + 1, 11).Value = oBkRef.Layer
ExcelobjSheet.Cells(X + 1, 12).Value = oBkRef.XScaleFactor
ExcelobjSheet.Cells(X + 1, 13).Value = oBkRef.YScaleFactor
ExcelobjSheet.Cells(X + 1, 14).Value = oBkRef.ZScaleFactor
'Debug.Print oDynProp.PropertyName, oDynProp.Value(J)
'je n'obtiens pas la même chose dans le debug.print et excel, je pense avoir commis une erreur car 'normalement, il ne devrait pas écrire dans excel pour ce cas de figure, je me trompe ?
'cependant, j'obtiens sur excel la liste des paramètres personnalisés (ce qui apparait dans la palettes 'propriétés sous "Personnalisé", mais je ne sais pas comment ça entre dans excel ?
Next J
Else
's'il n'y a qu'une propriété dynamique

'remplir les intitulés des colonnes supplémentaires
ExcelobjSheet.Cells(X + 1, 1).Value = "Oui"
ExcelobjSheet.Cells(X + 1, 2).Value = oBkRef.EffectiveName
ExcelobjSheet.Cells(X + 1, 3).Value = oBkRef.Name
ExcelobjSheet.Cells(X + 1, 4).Value = oBkRef.Handle
ExcelobjSheet.Cells(X + 1, 5).Value = oBkRef.OwnerID
ExcelobjSheet.Cells(X + 1, 6).Value = oBkRef.ObjectID
PointXYZ = oBkRef.InsertionPoint

ExcelobjSheet.Cells(X + 1, 7).Value = PointXYZ(0)
ExcelobjSheet.Cells(X + 1, 8).Value = PointXYZ(1)
ExcelobjSheet.Cells(X + 1, 9).Value = PointXYZ(2)
ExcelobjSheet.Cells(X + 1, 10).Value = oBkRef.Rotation
ExcelobjSheet.Cells(X + 1, 11).Value = oBkRef.Layer
ExcelobjSheet.Cells(X + 1, 12).Value = oBkRef.XScaleFactor
ExcelobjSheet.Cells(X + 1, 13).Value = oBkRef.YScaleFactor
ExcelobjSheet.Cells(X + 1, 14).Value = oBkRef.ZScaleFactor

For U = 7 To 256
Nomcolonne = ExcelobjSheet.Cells(1, U)
If Nomcolonne = oDynProp.PropertyName Or Nomcolonne = "" Then
ExcelobjSheet.Cells(1, U).Value = oDynProp.PropertyName
ExcelobjSheet.Cells(X + 1, U).Value = oDynProp.Value
Exit For
Else
End If
Next U


End If
Next p
Else

ExcelobjSheet.Cells(X + 1, 1).Value = "Non"
ExcelobjSheet.Cells(X + 1, 2).Value = oBkRef.EffectiveName
ExcelobjSheet.Cells(X + 1, 3).Value = oBkRef.Name
ExcelobjSheet.Cells(X + 1, 4).Value = oBkRef.Handle
ExcelobjSheet.Cells(X + 1, 5).Value = oBkRef.OwnerID
ExcelobjSheet.Cells(X + 1, 6).Value = oBkRef.ObjectID
PointXYZ = oBkRef.InsertionPoint

ExcelobjSheet.Cells(X + 1, 7).Value = PointXYZ(0)
ExcelobjSheet.Cells(X + 1, 8).Value = PointXYZ(1)
ExcelobjSheet.Cells(X + 1, 9).Value = PointXYZ(2)
ExcelobjSheet.Cells(X + 1, 10).Value = oBkRef.Rotation
ExcelobjSheet.Cells(X + 1, 11).Value = oBkRef.Layer
ExcelobjSheet.Cells(X + 1, 12).Value = oBkRef.XScaleFactor
ExcelobjSheet.Cells(X + 1, 13).Value = oBkRef.YScaleFactor
ExcelobjSheet.Cells(X + 1, 14).Value = oBkRef.ZScaleFactor

End If



If oBkRef.HasAttributes Then
Dim varAttributes As Variant
varAttributes = oBkRef.GetAttributes


Dim strAttributes As String

strAttributes = ""
Dim n As Integer
For n = LBound(varAttributes) To UBound(varAttributes)
strAttributes = strAttributes & " Tag: " & varAttributes(n).TagString & _
" Value: " & varAttributes(n).TextString & " "

For U = 7 To 255
Nomcolonne = ExcelobjSheet.Cells(1, U)
If Nomcolonne = varAttributes(n).TagString Or Nomcolonne = "" Then
ExcelobjSheet.Cells(1, U) = varAttributes(n).TagString
ExcelobjSheet.Cells(X + 1, U) = varAttributes(n).TextString
'Debug.Print varAttributes(n).TagString
Exit For
Else
End If
Next U

Next n

Dim varAttributesC As Variant
varAttributesC = oBkRef.GetConstantAttributes
Dim strAttributesC As String
For n = LBound(varAttributesC) To UBound(varAttributesC)
strAttributesC = strAttributesC & " Tag: " & varAttributesC(n).TagString & _
" Value: " & varAttributesC(n).TextString & " "

For U = 7 To 255
Nomcolonne = ExcelobjSheet.Cells(1, U)
Dim strattributC As String
strattributC = varAttributesC(n).TagString & "(*)"
If Nomcolonne = strattributC Or Nomcolonne = "" Then

ExcelobjSheet.Cells(1, U).Value = varAttributesC(n).TagString & "(*)"
ExcelobjSheet.Cells(X + 1, U).Value = varAttributesC(n).TextString

Exit For
Else
End If
Next U

Next n

Else
End If
End If

Next Ent

Excelobj.ScreenUpdating = True
Select Case X
Case 0
ThisDrawing.Utility.Prompt "Le fichier ne contient pas de blocs"
Case 1
ThisDrawing.Utility.Prompt X & " bloc a été trouvé."
Case Else
ThisDrawing.Utility.Prompt X & " blocs ont été trouvés."
End Select

Excelobj.SheetsInNewWorkbook = sngNbFeuille


If TL_choix.CheckBox1 = True Then

Set ExcelobjSheet = Nothing
Excelobj.ActiveWorkbook.Close True
Set ExcelobjWorkbook = Nothing
Excelobj.Quit
Set Excelobj = Nothing
Else
'ne rien faire
End If

Exit Sub

gestionEx:
Debug.Print Err.Number, Err.Description
Select Case Err.Number
Case "1004" 'donné par ligne
ThisDrawing.Utility.Prompt ("Le fichiers dans lequel nous essayons d'écrire est dejà ouvert, veuillez fermer Attribute.xls. Si Excel n'est pas ouvert visuelllement, veuillez faire CTL+ALT+SUPPR et arrêter EXCEL.")
MsgBox "Le fichiers dans lequel nous essayons d'écrire est dejà ouvert, veuillez fermer Attribute.xls. Si Excel n'est pas ouvert visuelllement, veuillez faire CTL+ALT+SUPPR et arrêter EXCEL."

Set ExcelobjSheet = Nothing
Excelobj.ActiveWorkbook.Close True
Set ExcelobjWorkbook = Nothing
Excelobj.Quit
Set Excelobj = Nothing

End Select
Excelobj.ScreenUpdating = True
End Sub


Function sautfunction()

Dim oBkRef2 As IAcadBlockReference2
       Set oBkRef2 = Ent
       Set oBkRef = oBkRef2
End Function

 

 

Code de la form :

Private Sub ComOk_Click()
Call ExtractionVersTableur
Me.Hide
End Sub

 

la forme s'appelle "Tl_choix" et possède un label et un checkbox

 

[Edité le 8/9/2007 par sechanbask][Edité le 8/9/2007 par sechanbask][Edité le 8/9/2007 par sechanbask][Edité le 9/9/2007 par sechanbask][Edité le 10/9/2007 par sechanbask][Edité le 13/9/2007 par sechanbask][Edité le 1/11/2007 par sechanbask]

 

[Edité le 1/11/2007 par sechanbask]

ATEGIE - Bureau d'Études Fluides

http://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.png

Exécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffrage

www.ategie.fr

  • 3 semaines après...
sechanbask Newbie

sechanbask

Posté(e)
  • Auteur
Posté(e)

sous VBA d'autocad, tu as rajouté la référence EXCEL ?

si oui, de quelle version d'EXCEL tu disposes?

 

Merci pour l'aide au débuggage

ATEGIE - Bureau d'Études Fluides

http://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.png

Exécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffrage

www.ategie.fr

lili2006 Rising Star

lili2006

Posté(e)
Posté(e)

Bonjour à toutes et tous,

 

sous VBA d'autocad, tu as rajouté la référence EXCEL ?

 

Heu, non (oubli de débutant, désolé!)

 

quelle version d'EXCEL tu disposes?

 

Deux versions sont installées 2003 & 2007 et ton code ouvre bien avec les deux.

 

Il génére bien un fichier .xls, mais mes blocs sont toujours dynamiques !!!

 

Je n'ai pas d'information en "Y" et les "X" me semblent improbables.

Par contre, pour la distance, c'est ok !

 

J'ai encore du rater une étape,...

Civil 3D 2025 - COVADIS_18.3c

https://www.linkedin...3%ABt-95313341/

sechanbask Newbie

sechanbask

Posté(e)
  • Auteur
Posté(e)

Ce code là, c'est uniquement pour répertorier les propriété des blocs rien d'autre...

 

Ce code fonctionne bien s'il extraire :

-propriétés classique (colonne A à F inclus)

-les attributs(en majuscule),

-les attributs constants (pas la même méthode que pour les attributs)(en majuscule avec un *devant),

-les propriétés dynamiques et visibilité (avec seulement la première lettre en majuscule),

 

en gros si ça te donne ça c'est bon :

 

http://cjoint.com/?jjlPYqC2qm

 

 

-Pour l'instant je ne sais pas chercher dans les codes DXF pour obtenir X et Y des blocs... je vais chercher mais déjà , je suis content que ça marche pour toi...Après il faudra que je fasse le code dans l'autres senes pour que ceux qui ont les LT puissent l'utiliser..

et après faire l'injection des données vers autocad...

ATEGIE - Bureau d'Études Fluides

http://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.png

Exécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffrage

www.ategie.fr

Créer un compte ou se connecter pour commenter

Vous devez être membre afin de pouvoir déposer un commentaire

Créer un compte

Créez un compte sur notre communauté. C’est facile !

Créer un nouveau compte

Se connecter

Vous avez déjà un compte ? Connectez-vous ici.

Connectez-vous maintenant
 Partager
Aller sur la liste des sujets
×
×
  • Créer...

Information importante

Nous avons placé des cookies sur votre appareil pour aider à améliorer ce site. Vous pouvez choisir d’ajuster vos paramètres de cookie, sinon nous supposerons que vous êtes d’accord pour continuer. Politique de confidentialité