winfield Posté(e) le 11 février 2007 Posté(e) le 11 février 2007 Bonsoir,C'est pour faire suite au sujet ci-après http://www.cadxp.com/modules.php?op=modload&name=XForum&file=viewthread&tid=4707#pid54382 Voici une petite contribution à mon niveau.Bien sûr, c'est pour ceux qui n'ont pas/ne veulent pas du pack Office. Cette routine extrait les attributs des blocs dans Calc (tableur d'OpenOffice) 1ere colonne =n° Handle2ème colonne = Nom du bloc3ème colonne=Etiquette d'attribut4ème colonne=Valeur d'attributs ( même si le bloc a plusieurs attributs) (c'est mieux quand le fichier dwg est enregistré, comme ça, le fichier Calc peut être enregistré automatiquement) Sub ExportAttributs_OOOo() Dim ObjSelection As AcadSelectionSet Dim StrSelection As String StrSelection = "MaSelection" On Error Resume Next Set ObjSelection = ThisDrawing.SelectionSets(StrSelection) If Err <> 0 Then Err.Clear Set ObjSelection = ThisDrawing.SelectionSets.Add(StrSelection) End If ObjSelection.Clear Dim DataCodeDxf(1) As Variant Dim CodeDxf(1) As Integer CodeDxf(0) = 0: DataCodeDxf(0) = "INSERT" CodeDxf(1) = 66: DataCodeDxf(1) = 1 ObjSelection.Select acSelectionSetAll, , , CodeDxf, DataCodeDxf If ObjSelection.Count = 0 Then ObjSelection.Delete MsgBox "Il n'y a pas de blocs avec attributs dans ce dessin", vbInformation, "Abandon" Exit Sub End If Dim serviceManager As Object Dim Desktop As Object, DocumentoOOo As Object Dim args() Dim ObjCalc As Object Set serviceManager = CreateObject("com.sun.star.serviceManager") Set Desktop = serviceManager.createInstance("com.sun.star.frame.Desktop") Set DocumentoOOo = Desktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, args) Set ObjCalc = DocumentoOOo.Sheets().getByIndex(0) ObjCalc.GetCellByPosition(0, 0).SetString ("Hand") ObjCalc.GetCellByPosition(1, 0).SetString ("Nom bloc") ObjCalc.GetCellByPosition(2, 0).SetString ("Etiquette") ObjCalc.GetCellByPosition(3, 0).SetString ("Valeur") Ligne = 1 For n = 0 To ObjSelection.Count - 1 Ligne = Ligne + 1 VarAttribut = ObjSelection(n).GetAttributes ObjCalc.GetCellByPosition(0, Ligne).SetString (ObjSelection(n).Handle) ObjCalc.GetCellByPosition(1, Ligne).SetString (ObjSelection(n).Name) For i = LBound(VarAttribut) To UBound(VarAttribut) ObjCalc.GetCellByPosition(2, Ligne).SetString (VarAttribut(i).TagString) ObjCalc.GetCellByPosition(3, Ligne).SetString (VarAttribut(i).TextString) Ligne = Ligne + 1 Next Next If ThisDrawing.FullName <> "" Then Chemin = ThisDrawing.FullName Chemin = Replace(Chemin, "\", "/") Chemin = Replace(Chemin, "dwg", "ods") DocumentoOOo.StoreAsURL "file:///" & Chemin, args End If End Sub Et comme il faut un retour :cool: (Calc=>Acad) Sub ImportAttributs_OOOo() Dim serviceManager As Object Dim Desktop As Object, DocumentoOOo As Object Dim ObjCalc As Object Dim Chemin As String Dim AffichageoOOo(0) If ThisDrawing.FullName <> "" Then Chemin = "file:///" & ThisDrawing.FullName Chemin = Replace(Chemin, "\", "/") Chemin = Replace(Chemin, "dwg", "ods") Else MsgBox "Il n'y a pas de fichier Calc pour ce dessin." & Chr(13) _ & "Le nom du fichier Calc doit avoir le même nom que le fichier dwg" & Chr(13) _ & "et doit se trouver dans le même répertoire.", vbInformation, "Fichier Calc manquant" Exit Sub End If Set serviceManager = CreateObject("com.sun.star.serviceManager") Set Desktop = serviceManager.createInstance("com.sun.star.frame.Desktop") Set AffichageoOOo(0) = serviceManager.Bridge_GetStruct("com.sun.star.beans.PropertyValue") AffichageoOOo(0).Name = "Hidden" AffichageoOOo(0).Value = True Set DocumentoOOo = Desktop.loadComponentFromURL(Chemin, "_blank", 0, AffichageoOOo()) Set ObjCalc = DocumentoOOo.Sheets().getByIndex(0) NumLigne = 2 fin = False Do hand = ObjCalc.GetCellByPosition(0, NumLigne).String Set ObjectTemp = ThisDrawing.HandleToObject(hand) VarAttribut = ObjectTemp.GetAttributes While ObjCalc.GetCellByPosition(2, NumLigne).String <> "" For n = LBound(VarAttribut) To UBound(VarAttribut) If ObjCalc.GetCellByPosition(2, NumLigne).String = VarAttribut(n).TagString Then VarAttribut(n).TextString = ObjCalc.GetCellByPosition(3, NumLigne).String VarAttribut(n).Update End If Next NumLigne = NumLigne + 1 Wend NumLigne = NumLigne + 1 If ObjCalc.GetCellByPosition(2, NumLigne).String = "" And ObjCalc.GetCellByPosition(2, NumLigne + 1).String = "" Then fin = True End If Loop While fin = False DocumentoOOo.dispose End Sub Voilà ! J'espère que ça pourra aider certains d'entre vous. Nous n’ héritons pas de la terre de nos ancêtres.Nous l’empruntons à nos enfants.
fabcad Posté(e) le 12 février 2007 Posté(e) le 12 février 2007 Super y aurait-il la même chose en Vlisp ?Pour le fun merci Fabcad
Steven Posté(e) le 12 février 2007 Posté(e) le 12 février 2007 Alors je dis BRAVO!Parce que j'en ai marre qu'on parle toujours du pack office de crosoft ou de crosoft tout court.Pouvoir utiliser AutoCAD avec autre chose que du crosoft, j'adore :D Merci winfield ;) Steven________________________________________ Pour le taf; Windows (et ses emmerdes) sinon pas d'AutoCAD. Pour le perso Linux Mint et pas de problèmes. Mais pas d'AutoCAD. En rêve; AutoCAD sous Linux.
winfield Posté(e) le 12 février 2007 Auteur Posté(e) le 12 février 2007 Je vous remercie d'avoir testé et je suis content que ça vous plaise Prochaine étape, Base ? :casstet: Nous n’ héritons pas de la terre de nos ancêtres.Nous l’empruntons à nos enfants.
speedy Posté(e) le 13 février 2007 Posté(e) le 13 février 2007 Bonjour à tous et un grand merci à Winfield, je recherche déséspérement, le code vba qui fonctionne depuis excel comme celui de Maxence delanoy import des attributs depuis excel et export je l'ai mis en ligne pour réparer l'erreur, la partie import depuis excel je suis arrivé à le faire mais export je plante toujours.... voir sujet : http://www.cadxp.com/sujetXForum-13635.htm Merci d'avance Michel a
Patrick_35 Posté(e) le 13 février 2007 Posté(e) le 13 février 2007 SalutRegarde ce sujet.Tu as un lisp qui travaille entre Excel et autocad dans les deux sens. Le vlisp étant assez proche du vba, je pense que tu pourras faire la traduction. @+ Les Lisps de PatrickLe but n'est pas toujours placé pour être atteint, mais pour servir de point de mire.Joseph Joubert, 1754-1824
winfield Posté(e) le 13 février 2007 Auteur Posté(e) le 13 février 2007 je recherche déséspérement, le code vba qui fonctionne depuis excel comme celui de Maxence delanoy import des attributs depuis excel Je l'ai déjà dit, le code de Maxence fonctionne très bien. Il te faut juste charger la bonne bibliothèque.Le sujet a d'ailleur été traité sur ce post http:// http://www.cadxp.com/sujetXForum-11717.htm Bonne journée Nous n’ héritons pas de la terre de nos ancêtres.Nous l’empruntons à nos enfants.
speedy Posté(e) le 13 février 2007 Posté(e) le 13 février 2007 Merci à vous tous ça marche, et en plus j'avais regardé et je n'avais pas remarqué la bybliothèque manquante... A+ Michel a
sechanbask Posté(e) le 7 juillet 2007 Posté(e) le 7 juillet 2007 Ça fait quelque temps que je cherchais un macro comme ça. Sauf que l'on ne peut pas considérer l'extraction comme un base de données donc c'est un peu dommage. Quand j'aurais du temps (à la retraite) j'essayerais de le faire... ATEGIE - Bureau d'Études Fluideshttp://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.pngExécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffragewww.ategie.fr
winfield Posté(e) le 7 juillet 2007 Auteur Posté(e) le 7 juillet 2007 Sauf que l'on ne peut pas considérer l'extraction comme un base de données donc c'est un peu dommage Tous le monde sait qu'un tableur n'est pas une base de données mais là, va falloir m'expliquer un peu plus, car je n'ai pas compris où tu veux en venir. Nous n’ héritons pas de la terre de nos ancêtres.Nous l’empruntons à nos enfants.
sechanbask Posté(e) le 8 juillet 2007 Posté(e) le 8 juillet 2007 désolé pour les fautes et abréviations mais je me suis coupé à l'intérieur de la main gauche alors je ne tape qu'avec la main droite...(promis je rendrais ça lisible pour tous quand les points de suture ne me feront plus mal) Je modifie un peu le code que tu avais fait et posté (merci pour ta contribution) pour permettre de faire des tris ou requêtes SQL. il manquait également quelques déclarations. voilà pour extraction : calc to autocad suivra si j'ai un peu de temps : Option Explicit Sub ExportAttributs_OOOo() Dim ligne As Integer Dim i As Integer Dim n As Integer Dim varAttribut As Variant Dim ObjSelection As AcadSelectionSet Dim StrSelection As String Dim chemin As String StrSelection = "MaSelection" On Error Resume Next Set ObjSelection = ThisDrawing.SelectionSets(StrSelection) If Err <> 0 Then Err.Clear Set ObjSelection = ThisDrawing.SelectionSets.Add(StrSelection) End If ObjSelection.Clear Dim DataCodeDxf(1) As Variant Dim CodeDxf(1) As Integer CodeDxf(0) = 0: DataCodeDxf(0) = "INSERT" CodeDxf(1) = 66: DataCodeDxf(1) = 1 ObjSelection.Select acSelectionSetAll, , , CodeDxf, DataCodeDxf If ObjSelection.Count = 0 Then ObjSelection.Delete MsgBox "Il n'y a pas de blocs avec attributs dans ce dessin", vbInformation, "Abandon" Exit Sub End If Dim serviceManager As Object Dim Desktop As Object, DocumentoOOo As Object Dim args() Dim ObjCalc As Object Set serviceManager = CreateObject("com.sun.star.serviceManager") Set Desktop = serviceManager.createInstance("com.sun.star.frame.Desktop") Set DocumentoOOo = Desktop.loadComponentFromURL("private:factory/scalc", "_blank", 0, args) Set ObjCalc = DocumentoOOo.Sheets().getByIndex(0) ObjCalc.GetCellByPosition(0, 0).SetString ("Hand") ObjCalc.GetCellByPosition(1, 0).SetString ("Nom bloc") ObjCalc.GetCellByPosition(2, 0).SetString ("Etiquette") ObjCalc.GetCellByPosition(3, 0).SetString ("Valeur") ligne = 1 For n = 0 To ObjSelection.Count - 1 'ligne = ligne + 1 varAttribut = ObjSelection(n).GetAttributes For i = LBound(varAttribut) To UBound(varAttribut) ObjCalc.GetCellByPosition(0, ligne).SetString (ObjSelection(n).Handle) ObjCalc.GetCellByPosition(1, ligne).SetString (ObjSelection(n).Name) ObjCalc.GetCellByPosition(2, ligne).SetString (varAttribut(i).TagString) ObjCalc.GetCellByPosition(3, ligne).SetString (varAttribut(i).TextString) ligne = ligne + 1 Next i Next n If ThisDrawing.FullName <> "" Then chemin = ThisDrawing.FullName chemin = Replace(chemin, "\", "/") chemin = Replace(chemin, "dwg", "ods") DocumentoOOo.StoreAsURL "file:///" & chemin, args End If End Sub ATEGIE - Bureau d'Études Fluideshttp://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.pngExécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffragewww.ategie.fr
speedy Posté(e) le 8 juillet 2007 Posté(e) le 8 juillet 2007 Bonsoir sechanbask ton VBA fonctionne, peux tu lui rajouter les coordonnées xyz et est ce possible de faire l'inverse (mise à jour depuis OOOo vers autocad ???). @+ Michel a
sechanbask Posté(e) le 8 juillet 2007 Posté(e) le 8 juillet 2007 attendez un peu,je suis blessé et j'ai un boulot monstre pendant le prochain mois (2 collègues en vacances etc.), alors ça risque d'être long, désolé. L'idéal pour moi, ça serait de faire un ligne par bloc avec plein de colonnes pour les différents attributs pour les blocs... mais bon ça se discute. [Edité le 8/7/2007 par sechanbask] ATEGIE - Bureau d'Études Fluideshttp://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.pngExécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffragewww.ategie.fr
winfield Posté(e) le 8 juillet 2007 Auteur Posté(e) le 8 juillet 2007 .....fallait faire un couper-coller des lignes du code, pas celles de ta main ! Nous n’ héritons pas de la terre de nos ancêtres.Nous l’empruntons à nos enfants.
sechanbask Posté(e) le 9 juillet 2007 Posté(e) le 9 juillet 2007 j'ai eu un peu de mal à comprendre ta blague mais j'en ai ri aux éclats !! ATEGIE - Bureau d'Études Fluideshttp://www.ategie.fr/uploads/ategie/ategie-at%C3%A9gie-bureau-%C3%A9tudes-etudes-fluides-logo-100x56.pngExécution, Synthèse, Conception, Maîtrise d'Oeuvre, Audit, Chiffragewww.ategie.fr
Messages recommandés
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 compteSe connecter
Vous avez déjà un compte ? Connectez-vous ici.
Connectez-vous maintenant