Communication Excel - AutoCAD
Bonjour,
Je vais regarder ce que je peux faire. Normalement il ne devrait pas y avoir de problème... ca fait bien longtemps que je n'ai plus développer en VBA pour AutoCAD (VB.NET est nettement plus complet).
Par contre j'ai deux remarques et une question :
- Remarque 1 : Lors de la livraison de DWG, il est préférable de les enregistrer dans une version 2000 pour qu'il puisse être ouvert sur l'ensemble des postes.
- Remarque 2 : Les macros VBA du fichier "ancrage V2.0 pour forum.xlsm" étaient actuellement protégés par mot de passe donc le code n'était pas modifiable en l'état normalement (j'ai pu le faire sauter, par contre je ne me considère pas comme responsable en cas de litige)
Dans le code on trouve :
'
'
' Propriété de Valentin LAMOUREUX
' ---- NGE TSO CATENAIRES ----
' ---- NGE TSO CATENAIRES ----
' ---- NGE TSO CATENAIRES ----
'
'
Question :
- Le bloc "nom_anc" que tu cherches a ajouter dans ton tableau est-il déjà présent dans le dwg lors du lancement de la commande? Si non, merci de me préciser son emplacement sur ton PC / serveur.
Je regarderai ça a tête reposée ce week-end, merci de répondre à ma question d'ici là stp.
Yoan
Yoan AUBRY
Bonjour,
Ci-joint le code pour la mise à jour du module "Export_Nomenclature"
Tu as un exemple pour insérer un bloc avec mise à jour d'attributs
Je te laisse finaliser pour la mise en forme (positions des blocs, chargement des autres informations...)
Public Sub ExportNomenclatureTeemo()
Call Concat_Mat
Call Ecriture_Nomenclature1
Call Ecriture_Nomenclature2
'Nécessite la référence Autocad xxx Type Library (Menu Outils > Références)
Dim AcadApp As AcadApplication, AcadPlan As AcadDocument
'Création de l'objet AutoCAD dans Excel :
Set AcadApp = AcadApplication
'Rend AutoCAD visible
AcadApp.Visible = True
'ou sinon, utilise le document ouvert :
Set AcadPlan = AcadApp.ActiveDocument
Dim Cible As Integer, i As Integer, j As Integer
Dim Repertoireactuel As String
Dim Name As String
Dim nbcar As Integer
Dim val As Integer
' --- Demande du chemin pour export ---
Name = AcadPlan.Name
Name = Left(Name, Len(Name) - 4)
If MsgBox("Voulez vous exporter la Nomenclature sur la feuille active:" & vbLf & Name & " ?", 4 + 64 + 256, "Chemin d'acces") = 6 Then
Dim Wb As Workbook
Set Wb = ActiveWorkbook
Dim WsR As Worksheet
Set WsR = Wb.Worksheets("Resultats")
'Dans l'exemple ci-dessous je récupère les informations de la ligne 24
Dim NumCol As Integer
NumCol = 24
Dim DESIGNATION, PLAN, REPERE, QTE As String
DESIGNATION = WsR.Range("A" & NumCol).Value
PLAN = WsR.Range("B" & NumCol).Value
REPERE = WsR.Range("C" & NumCol).Value
QTE = WsR.Range("D" & NumCol).Value
'Insertion d'un bloc "Nom_Anc" dans l'espace papier en cours au point 1,2 avec mise à jour des attributs
Insert_Bloc_Nom_Anc AcadPlan, 1, 2, DESIGNATION, PLAN, REPERE, QTE
End If
End Sub
Public Sub Insert_Bloc_Nom_Anc(AcadPlan As AcadDocument, X As Double, Y As Double, DESIGNATION As String, PLAN As String, REPERE As String, QTE As String)
Dim objBRef As AcadBlockReference
Dim PtIns(0 To 2) As Double
PtIns(0) = X
PtIns(1) = Y
PtIns(2) = 0
Dim Att As Variant
Dim AttCount As Integer
Set objBRef = AcadPlan.PaperSpace.InsertBlock(PtIns, "Nom_Anc", 1, 1, 1, 0)
objBRef.Layer = "0"
objBRef.Update
For Each Att In objBRef.GetAttributes
Select Case Att.TagString
Case "DESIGNATION"
Att.TextString = DESIGNATION
Case "PLAN"
Att.TextString = PLAN
Case "REPERE"
Att.TextString = REPERE
Case "QTE"
Att.TextString = QTE
End Select
Next
objBRef.Update
End Sub
Bonne continuation
Yoan
Yoan AUBRY
Si jamais tu veux modifier le calque dans lequel les blocs sont insérés il faut modifier la ligne suivante
objBRef.Layer = "0"
et changer le "0" par le nom de ton calque
Yoan AUBRY
Re-bonjour,
Je viens de m'apercevoir que dans ton fichier dwg il y a déjà un bloc attributaire nommé TSO-anc comportant de nombreux attributs permettant de remplir les informations du tableau
Il aurait été plus simple de le spécifier au départ et de faire la mise à jour de ce bloc plutôt que d'insérer des nouveaux blocs.
Pour information, pour une meilleure organisation des attributs de ce bloc, je te conseille de rentrer dans l'éditeur de bloc (commande "BEDIT") puis d'utiliser la commande "ORDREATTBLOC" pour réorganiser l'ordre des attributs dans ton bloc via les boutons Monter et Descendre sachant qu'une fois que tu à appuyer sur le bouton Monter par exemple tu peux appuyer sur la touche M pour continuer à le faire monter dans la liste (et D pour Descendre)
Une fois cela fait et après avoir fermer l'éditeur de bloc, il faudra synchroniser tes attributs via la commande ATTSYNC
Une fois que tu as bien organiser tes attributs, tu pourrais utilise les commandes ATTOUT pour faire un export des attributs, faire la MAJ via un copier coller puis un ATTIN pour les réinjecter
Bon courage,
Yoan
Yoan AUBRY
je viens d'essayer mais je me retrouve avec ce msg....
Une fois que tu auras repris l'ordre des attributs du bloc, ré-envois moi le fichier dwg mis à jour.
Je te ferai la MAJ du code VBA pour pouvoir injecter directement les valeurs dans les attributs du bloc TSO-anc.
Pour l'instant, je me mets en mode we...
Bon we et à lundi
Yoan AUBRY
OK, j'ai oublié de mettre les "Byval"...
Ci-joint la MAJ de la sub
Public Sub Insert_Bloc_Nom_Anc(AcadPlan As AcadDocument, X As Double, Y As Double, ByVal DESIGNATION As String, ByVal PLAN As String, ByVal REPERE As String, ByVal QTE As String)
Dim objBRef As AcadBlockReference
Dim PtIns(0 To 2) As Double
PtIns(0) = X
PtIns(1) = Y
PtIns(2) = 0
Dim Att As Variant
Dim AttCount As Integer
Set objBRef = AcadPlan.PaperSpace.InsertBlock(PtIns, "Nom_Anc", 1, 1, 1, 0)
objBRef.Layer = "0"
objBRef.Update
For Each Att In objBRef.GetAttributes
Select Case Att.TagString
Case "DESIGNATION"
Att.TextString = DESIGNATION
Case "PLAN"
Att.TextString = PLAN
Case "REPERE"
Att.TextString = REPERE
Case "QTE"
Att.TextString = QTE
End Select
Next
objBRef.Update
End SubYoan AUBRY
En effet, logiquement il n'y a pas autant d'attribut dans ce bloc c'est un vieux bloc. Je viens de le remettre a jour sans tous ces attributs.
Bonjour,
Pas de soucis, j'espère que tu arriveras à programmer le reste.
Pour le reste, du coup, je te conseille de faire quelque chose comme cela (je n'ai pas fait de test)
Public Sub ExportNomenclatureTeemo()
Call Concat_Mat
Call Ecriture_Nomenclature1
Call Ecriture_Nomenclature2
'Nécessite la référence Autocad xxx Type Library (Menu Outils > Références)
Dim AcadApp As AcadApplication, AcadPlan As AcadDocument
'Création de l'objet AutoCAD dans Excel :
Set AcadApp = AcadApplication
'Rend AutoCAD visible
AcadApp.Visible = True
'ou sinon, utilise le document ouvert :
Set AcadPlan = AcadApp.ActiveDocument
Dim Cible As Integer, i As Integer, j As Integer
Dim Repertoireactuel As String
Dim Name As String
Dim nbcar As Integer
Dim val As Integer
' --- Demande du chemin pour export ---
Name = AcadPlan.Name
Name = Left(Name, Len(Name) - 4)
Dim Wb As Workbook
Set Wb = ActiveWorkbook
Dim WsR As Worksheet
Set WsR = Wb.Worksheets("Resultats")
Dim DL As Integer 'dernière ligne du tableau
DL = WsR.Cells(Rows.Count, 1).End(xlUp).Row
If MsgBox("Voulez vous exporter la Nomenclature sur la feuille active:" & vbLf & Name & " ?", 4 + 64 + 256, "Chemin d'acces") = 6 Then
Dim ent As AcadEntity
Dim Block, BlkTSO As AcadBlockReference
Dim bFound As Boolean
bFound = False
For Each ent In ThisDrawing.PaperSpace
If TypeOf ent Is AcadBlockReference Then
Set Block = ent
If UCase(Block.EffectiveName) = "TSO-anc" Then
Set BlkTSO = Block
bFound = True
Exit For
End If
End If
Next
'Si le bloc "TSO-anc" a été trouvé
If bFound = True Then
'Récupération de la position X, Y du bloc TSO pour pouvoir ajouter les
'blocs Nom_Anc avec une position relative par rapport à ce bloc
Dim X_TSO, Y_TSO As Double
X_TSO = Block.InsertionPoint.X
Y_TSO = Block.InsertionPoint.Y
'Mise à jour des attributs du bloc TSO-anc
Dim Att As Variant
Dim AttCount As Integer
For Each Att In BlkTSO.GetAttributes
Select Case Att.TagString
'A modifier
Case "AAAA"
Att.TextString = WsR.Range("A" & 1).Value
Case "BBBB"
Att.TextString = WsR.Range("A" & 1).Value
Case "CCCC"
Att.TextString = WsR.Range("A" & 1).Value
Case "DDDD"
Att.TextString = WsR.Range("A" & 1).Value
End Select
Next
BlkTSO.Update
Dim NumCol, NbL_Anc1, NbL_Anc2 As Integer
NbL_Anc1 = 0 'Nombre de ligne du coté Ancrage 1 pour la gestion du Y de l'insertion des blocs
NbL_Anc2 = 0
For NumCol = 13 To DL
If WsR.Range("B" & NumCol).Value <> "" Then
If WsR.Range("B" & NumCol).Value = "------------------------------------------------" Then
NbL_Anc1 = NbL_Anc1 + 1
Else
Dim DESIGNATION, PLAN, REPERE, QTE As String
DESIGNATION = WsR.Range("A" & NumCol).Value
PLAN = WsR.Range("B" & NumCol).Value
REPERE = WsR.Range("C" & NumCol).Value
QTE = WsR.Range("D" & NumCol).Value
'Insertion d'un bloc "Nom_Anc" dans l'espace papier en coursavec mise à jour des attributs
Insert_Bloc_Nom_Anc AcadPlan, X_TSO + 10, Y_TSO + 110 - 3.692 * NbL_Anc1, DESIGNATION, PLAN, REPERE, QTE
NbL_Anc1 = NbL_Anc1 + 1
End If
End If
Next
For NumCol = 13 To DL
If WsR.Range("F" & NumCol).Value <> "" Then
If WsR.Range("F" & NumCol).Value = "------------------------------------------------" Then
NbL_Anc2 = NbL_Anc2 + 1
Else
Dim DESIGNATION, PLAN, REPERE, QTE As String
DESIGNATION = WsR.Range("F" & NumCol).Value
PLAN = WsR.Range("G" & NumCol).Value
REPERE = WsR.Range("H" & NumCol).Value
QTE = WsR.Range("I" & NumCol).Value
'Insertion d'un bloc "Nom_Anc" dans l'espace papier en coursavec mise à jour des attributs
Insert_Bloc_Nom_Anc AcadPlan, X_TSO + 105, Y_TSO + 110 - 3.692 * NbL_Anc2, DESIGNATION, PLAN, REPERE, QTE
NbL_Anc2 = NbL_Anc2 + 1
End If
End If
Next
End If
End If
End Sub
Public Sub Insert_Bloc_Nom_Anc(AcadPlan As AcadDocument, X As Double, Y As Double, ByVal DESIGNATION As String, ByVal PLAN As String, ByVal REPERE As String, ByVal QTE As String)
Dim objBRef As AcadBlockReference
Dim PtIns(0 To 2) As Double
PtIns(0) = X
PtIns(1) = Y
PtIns(2) = 0
Dim Att As Variant
Dim AttCount As Integer
Set objBRef = AcadPlan.PaperSpace.InsertBlock(PtIns, "Nom_Anc", 1, 1, 1, 0)
objBRef.Layer = "0"
objBRef.Update
For Each Att In objBRef.GetAttributes
Select Case Att.TagString
Case "DESIGNATION"
Att.TextString = DESIGNATION
Case "PLAN"
Att.TextString = PLAN
Case "REPERE"
Att.TextString = REPERE
Case "QTE"
Att.TextString = QTE
End Select
Next
objBRef.Update
End Sub
Yoan AUBRY
Bonjour,
Je me base du coup sur ce modèle pour la suite du code
Ci-joint le code finaliser:
Public Sub ExportNomenclatureTeemo()
Call Concat_Mat
Call Ecriture_Nomenclature1
Call Ecriture_Nomenclature2
'Nécessite la référence Autocad xxx Type Library (Menu Outils > Références)
Dim AcadApp As AcadApplication, AcadPlan As AcadDocument
'Création de l'objet AutoCAD dans Excel :
Set AcadApp = AcadApplication
'Rend AutoCAD visible
AcadApp.Visible = True
'ou sinon, utilise le document ouvert :
Set AcadPlan = AcadApp.ActiveDocument
Dim Cible As Integer, i As Integer, j As Integer
Dim Repertoireactuel As String
Dim Name As String
Dim nbcar As Integer
Dim val As Integer
Dim Wb As Workbook
Set Wb = ActiveWorkbook
Dim WsR As Worksheet
Set WsR = Wb.Worksheets("Resultats")
Dim DL As Integer 'dernière ligne on vide du tableau excel
DL = WsR.Cells(Rows.Count, 1).End(xlUp).Row
' --- Demande du chemin pour export ---
Name = AcadPlan.Name
Name = Left(Name, Len(Name) - 4)
If MsgBox("Voulez vous exporter la Nomenclature sur la feuille active:" & vbLf & Name & " ?", 4 + 64 + 256, "Chemin d'acces") = 6 Then
Dim ent As AcadEntity
Dim block, BlkTSO As AcadBlockReference
Dim bFound As Boolean
bFound = False
For Each ent In AcadPlan.PaperSpace
If TypeOf ent Is AcadBlockReference Then
Set block = ent
If block.EffectiveName = "TSO-anc" Then
bFound = True
Set BlkTSO = ent
Exit For
End If
End If
Next
'Si le bloc "TSO-anc" a été trouvé
If bFound = True Then
'Récupération de la position X, Y du bloc TSO pour pouvoir ajouter les
'blocs Nom_Anc avec une position relative par rapport à ce bloc
Dim X_TSO, Y_TSO As Double
X_TSO = BlkTSO.InsertionPoint(0) 'récupération de la position en X du bloc TSO-ANC
Y_TSO = BlkTSO.InsertionPoint(1) 'récupération de la position en Y du bloc TSO-ANC
'Mise à jour des attributs du bloc TSO-anc
Dim Att As Variant
Dim AttCount As Integer
For Each Att In BlkTSO.GetAttributes
Select Case Att.TagString
Case "massif_1"
Att.TextString = WsR.Range("F5").Value
'A compléter s'il y a d'autres informations a mettre à jour
'dans les attributs du bloc TSO-ANC
' Case "BBBB"
' Att.TextString = WsR.Range("A" & 1).Value
' Case "CCCC"
' Att.TextString = WsR.Range("A" & 1).Value
' Case "DDDD"
' Att.TextString = WsR.Range("A" & 1).Value
End Select
Next
BlkTSO.Update
Dim NumCol, NbL_Anc1, NbL_Anc2 As Integer
Dim DESIGNATION, PLAN, REPERE, QTE As String
NbL_Anc1 = 0 'Nombre de ligne du coté Ancrage 1 pour la gestion du Y de l'insertion des blocs
NbL_Anc2 = 0 'Nombre de ligne du coté Ancrage 2 pour la gestion du Y de l'insertion des blocs
'On parcours toutes les lignes entre la 13 et la dernière ligne du document Excel
For NumCol = 13 To DL
If WsR.Range("A" & NumCol).Value <> "" Then 'Si la cellule colonne A de la ligne en cours n'est pas vide
If WsR.Range("A" & NumCol).Value Like "---*" Then
'Si la cellule colonne A de la ligne commence par "---"
'NbL_Anc1 = NbL_Anc1 + 1 'on incrément NbL_Anc1 pour décaler d'un cran en Y
Else
'Si la cellule colonne B de la ligne en cours n'est pas vide et ne commence pas par "---"
'On récupère les valeurs des colonnes A, B, C, D de la ligne en cours
DESIGNATION = WsR.Range("A" & NumCol).Value
PLAN = WsR.Range("B" & NumCol).Value
REPERE = WsR.Range("C" & NumCol).Value
QTE = WsR.Range("D" & NumCol).Value
'Insertion d'un bloc "Nom_Anc" dans l'espace papier en coursavec mise à jour des attributs
Insert_Bloc_Nom_Anc AcadPlan, X_TSO + 10, Y_TSO + 110.532 - 3.692 * NbL_Anc1, DESIGNATION, PLAN, REPERE, QTE
NbL_Anc1 = NbL_Anc1 + 1
End If
End If
Next
'Même principe pour l'ancrage N°2
For NumCol = 13 To DL
If WsR.Range("F" & NumCol).Value <> "" Then
If WsR.Range("F" & NumCol).Value Like "---*" Then
'Si la cellule colonne F de la ligne commence par "---"
'NbL_Anc2 = NbL_Anc2 + 1
Else
DESIGNATION = WsR.Range("F" & NumCol).Value
PLAN = WsR.Range("G" & NumCol).Value
REPERE = WsR.Range("H" & NumCol).Value
QTE = WsR.Range("I" & NumCol).Value
'Insertion d'un bloc "Nom_Anc" dans l'espace papier en coursavec mise à jour des attributs
Insert_Bloc_Nom_Anc AcadPlan, X_TSO + 105.201, Y_TSO + 110.532 - 3.692 * NbL_Anc2, DESIGNATION, PLAN, REPERE, QTE
NbL_Anc2 = NbL_Anc2 + 1
End If
End If
Next
End If
End If
End Sub
Public Sub Insert_Bloc_Nom_Anc(AcadPlan As AcadDocument, X As Double, Y As Double, ByVal DESIGNATION As String, ByVal PLAN As String, ByVal REPERE As String, ByVal QTE As String)
Dim objBRef As AcadBlockReference
Dim PtIns(0 To 2) As Double
PtIns(0) = X
PtIns(1) = Y
PtIns(2) = 0
Dim Att As Variant
Dim AttCount As Integer
Set objBRef = AcadPlan.PaperSpace.InsertBlock(PtIns, "Nom_Anc", 1, 1, 1, 0)
objBRef.Layer = "0"
objBRef.Update
For Each Att In objBRef.GetAttributes
Select Case Att.TagString
Case "DESIGNATION"
Att.TextString = DESIGNATION
Case "PLAN"
Att.TextString = PLAN
Case "REPERE"
Att.TextString = REPERE
Case "QTE"
Att.TextString = QTE
End Select
Next
objBRef.Update
End Sub
Yoan AUBRY
Bonjour @jverdier927VN ,
Content d'avoir pu t'aider.
Dans ces cas-là, je te laisse cliquer sur le bouton APPROUVER LA SOLUTION en bas de la réponse qui apporte une solution (le message 16 étant le plus complet) pour que le sujet soit marqué comme traité et que la communauté puisse avoir accès à la solution rapidement.
PI : J'ai précisé sur Cadxp que ce sujet est finalisé.
Bonne continuation,
Yoan
Yoan AUBRY
