phil_vsd

Bonjour, J'ai un problème que je n'arrive pas à solder, et pourtant j'ai cherché. J'ai un dossier avec dedans un CUI perso et un sous-répertoire contenant des icônes perso. Le but étant de coller ce dossier dans les ordis des collègues comme cela tout viens :les CUI, icônes, routines... Dans mon CUi les îcones ont donc leur chemin qui les relie et si j'insère dans mon CUI une icône d'origine Autocad, je me retrouve avec les points d'interrogation dans ma barre d'outil perso pour les icônes perso, et pourtant les chemins sont mémorisés et corrects. Je suis obligé de remontrer le chemin dans le gestionnaire des BO alors qu'il sont justes... Cela ne le fait que lorsque j'insère des icônes Autocad au milieu de mes perso. Si qq'un sait... Merci d'avance !

Salut, J'aimerai bien connaître la réponse à ton sujet. Il faudrait en lisp ou VBA une petite macro qui sauvegarde un état des calques et couleurs à une date comme cela si dans le futur un petit malin change les états des calques il suffirait d'un clik pour tout remettre en place, éteindre ce qui doit l'être, geler, allumer, verrouiller les fenêtres... Le plus délicat sera sans doute de gérer les futurs calques qui seront créés à postériori, il faudrait les anticiper dans la routine avec une fonction logique. Je suis encore novice pour pondre une telle routine mais dans le forum lisp tu dois avoir des traces de code que tu peux assembler. Ceci dit, si quelqu'un a une fonction miracle, il est le bienvenu. A+

Bonjour Patrick, En commentant ma petite routine VBA tu m'a aiguillé sur les champs dynamiques que je ne connaissais pas jusqu'alors et je t'en remercie. C'est vrai que c'est une mine d'or pour ceux qui maîtrisent le sujet. Le fait que les renseignements puissent se réactualiser automatiquement si la variable FIELDEVAL est à 7 est un bien précieux. La petite routine du tampon identité que j'avais mis en place était (trop...) souvent zappée car elle était considérée comme un espion... Avec les champs dynamiques pour tracer un plan papier parmis tant d'autres c'est efficace. Merci encore. Je vais creuser le sujet.

Didier, Je préfère que tu regardes la routine une autre fois... Après les apéros on est pas toujours d'applomb Hé hé... Mon prog va ressembler à : Dim les collants à qui y sont... Goto on sait plus Syntax error selectionset heu... Blague à part je ne suis pas pressé tant j'ai a apprendre... Et puis ce soir y'a Numbers sur la six. Aujourd'hui jai performé les selectionset, les hachures et tout la tralala. Je suis content de vous connaître, j'ai tant galéré tout seul. J'ai acheté le livre "Programmer Autocad", y'a du lisp (Comprend rien encore...) du DCL et un peu de VBA... Le but final de la manip sera que d'un clik, toutes mes polylignes qui représentent des surfaces aient un texte contenant leurs surfaces en leur centre. De plus si les surfaces changent (comme c'est le cas lors de projets d'archi) il faudrait que d'un clik ces textes soient formatés et les calculs relancés et les textes réinsérés. Pour l'instant je sait faire une collections remplies avec toutes les polylignes mais je ne sais pas lancer un calcul du style For each object in ... j'ai hâte d'y être pour voir le résultat ! Allez bon vernissage ! :)

Bonjour, J'ai récupéré une petite routine qui peut être utile à plusieurs d'entres nous. D'un clik cela insère le chemin, le nom, le dessinateur et la date sous forme de texte. Pratique pour retrouver l'origine d'un plan papier. J'ai trouvé des fragments de codes sous les sites autocad les plus connus et je me suis fait la main dessus pour apprendre le VBA. Je n'ai plus les adresses sous la main mais ces fragments se trouvent chez Maxence Dellanoy, Lourdelle, etc... Comme d'habitude, vous suggestions m'intéressent. Public Sub Tampon() ' Déclaration des variables Dim Pt1 As Variant Dim txtTout As String Dim txtTexte1 As String Dim txtTexte2 As String Dim txtTexte3 As String Dim currLayer As AcadLayer Dim newLayer As AcadLayer ' Demande du point d'insertion du texte Pt1 = ThisDrawing.Utility.GetPoint(, "Sélection d'un point SVP") ' Définition du texte à insérer dans le dessin txtTexte1 = " " & ThisDrawing.FullName txtTexte2 = " Par VOTRE NOM le : " txtTexte3 = Now txtTout = txtTexte1 & txtTexte2 & txtTexte3 ' Mémorise le calque courant, l'"active layer" Set currLayer = ThisDrawing.ActiveLayer ' Créé le layer Path finder VBA pour y insérer le texte du chemin Set newLayer = ThisDrawing.Layers.Add("Path finder VBA") ThisDrawing.ActiveLayer = newLayer ' Ajout du texte ThisDrawing.PaperSpace.AddText txtTout, Pt1, 2 ' Retourne sur le calque d'avant l'insertion ThisDrawing.ActiveLayer = currLayer End Sub

Salut, Je suis nouveau en VBA et je suis confronté moi aussi aux codes DXF. Il se peut que les codes soient les même, et je t'avoue que je me suis posé la question qu'après avoir posté l'adresse, j'aurai dû vérifier avant d'écrire... :P J'ai posté en "VBA-routine" deux routine pour du calcul de surfaces, si tu les testes dis-moi ce que tu en penses. Si je rencontre qqchose de sympa je penserai à toi. A bientôt

Bonjour à tous. Je suis intéressé pas l'option centroid car je dois l'inclure dans une routine de calcul de surface. Dans ma routine (Voir forum VBA-routine "Calcul de surface" 24-08-06) je clique sur la polyligne dont je doit calculer l'aire puis je clique sur un point dinserton pour qu'apparaisse un texte contenant l'aire. En fait j'aimerai en un clik que le texte s'insère au milieu de la polyligne, d'où mon intêret pour le centroid. Si vous avez un lien... Merci d'avance.

Bonjour, J'ai quelque chose qui pourrait t'aider sur le forum VBA-Routine. Dis-moi si cela peut t'aider car c'est en-cours d'évolution et toutes les suggestions sont les bienvenues... A+

Bonjour, J'ai trouvé cette liste code à cette adresse : http://aidacad.com/fr/dxf.htm Si ça peut t'aider... A+

Re bonjour... Voici ma deuxième routine que je vous propose. N'hésitez pas à l'améliorer car je ne maîtrise pas les loop et boucles en tous genre... De plus si vous connaissez comment on fait une région sur une polyligne 2D... N'hésitez pas à poster des liens ! Pour cette routine nous sommes limités à douze pièces et que sur des polylignes de dimension d'une pièce. Je ne sais pas comment la modifier pour travailler sur des polyligne de la tailles de grands terrains... De plus le polylignes choisies doivent appartenir à un calque précis. Ici c'est le calque SHAB. Si l'on sélectionne une polyligne qui ne fait pas partie du calque on a un message d'erreur. C'est pour éviter de cliquer sur une surface et de fausser les calculs, mon boss ne me le pardonnerai pas... A très bientôt ! Sub Areatotal() Dim s1 As Double, s2 As Double, s3 As Double, s4 As Double, s5 As Double Dim s6 As Double, s7 As Double, s8 As Double, s9 As Double, s10 As Double Dim st As Single Dim returns1 As AcadObject Dim returns2 As AcadObject Dim returns3 As AcadObject Dim returns4 As AcadObject Dim returns5 As AcadObject Dim returns6 As AcadObject Dim returns7 As AcadObject Dim returns8 As AcadObject Dim returns9 As AcadObject Dim returns10 As AcadObject Dim returns11 As AcadObject Dim returns12 As AcadObject Dim Calqueobjet As String Dim Ptinsert As Variant Dim textStyle1 As AcadTextStyle Dim currFontFile As String Dim newFontFile As String Dim currLayerTetxteSurfacetot As AcadLayer Dim newLayerTetxteSurfacetot As AcadLayer Dim txtsurf As String Dim txtsurf2 As String Dim txtsurftot As String Dim plineAreatot As Single Dim plineAreabistot As Integer Dim plineAreabisbistot As Single Dim areaintegertot As Integer s1 = 0 s2 = 0 s3 = 0 s4 = 0 s5 = 0 s6 = 0 s7 = 0 s8 = 0 s9 = 0 s10 = 0 s11 = 0 s12 = 0 Surface_totale_form.Show 'Fait que si l'on tappe dans le vide l'addition se fait, 'fait aussi qu si l'on tappe entree l'add se fait On Error GoTo CALCUL ' Pour piquer l'objet Surface 1 ThisDrawing.Utility.GetEntity returns1, basePnt, "Sélectionnez la pièce 1 SVP" Calqueobjet = returns1.Layer If Calqueobjet = "SHAB" Then GoTo Objet1 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet1: If returns1.color = acGreen Then returns1.color = acYellow Else: returns1.color = acGreen End If s1 = returns1.Area ' Pour piquer l'objet Surface 2 ThisDrawing.Utility.GetEntity returns2, basePnt, "Sélectionnez la pièce 2 SVP" Calqueobjet = returns2.Layer If Calqueobjet = "SHAB" Then GoTo Objet2 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet2: If returns2.color = acGreen Then returns2.color = acYellow Else: returns2.color = acGreen End If s2 = returns2.Area ' Pour piquer l'objet Surface 3 ThisDrawing.Utility.GetEntity returns3, basePnt, "Sélectionnez la pièce 3 SVP" Calqueobjet = returns3.Layer If Calqueobjet = "SHAB" Then GoTo Objet3 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet3: If returns3.color = acGreen Then returns3.color = acYellow Else: returns3.color = acGreen End If s3 = returns3.Area ' Pour piquer l'objet Surface 4 ThisDrawing.Utility.GetEntity returns4, basePnt, "Sélectionnez la pièce 4 SVP" Calqueobjet = returns4.Layer If Calqueobjet = "SHAB" Then GoTo Objet4 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet4: If returns4.color = acGreen Then returns4.color = acYellow Else: returns4.color = acGreen End If s4 = returns4.Area ' Pour piquer l'objet Surface 5 ThisDrawing.Utility.GetEntity returns5, basePnt, "Sélectionnez la pièce 5 SVP" Calqueobjet = returns5.Layer If Calqueobjet = "SHAB" Then GoTo Objet5 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet5: If returns5.color = acGreen Then returns5.color = acYellow Else: returns5.color = acGreen End If s5 = returns5.Area ' Pour piquer l'objet Surface 6 ThisDrawing.Utility.GetEntity returns6, basePnt, "Sélectionnez la pièce 6 SVP" Calqueobjet = returns6.Layer If Calqueobjet = "SHAB" Then GoTo Objet6 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet6: If returns6.color = acGreen Then returns6.color = acYellow Else: returns6.color = acGreen End If s6 = returns6.Area ' Pour piquer l'objet Surface 7 ThisDrawing.Utility.GetEntity returns7, basePnt, "Sélectionnez la pièce 7 SVP" Calqueobjet = returns7.Layer If Calqueobjet = "SHAB" Then GoTo Objet7 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet7: If returns7.color = acGreen Then returns7.color = acYellow Else: returns7.color = acGreen End If s7 = returns7.Area ' Pour piquer l'objet Surface 8 ThisDrawing.Utility.GetEntity returns8, basePnt, "Sélectionnez la pièce 8 SVP" Calqueobjet = returns8.Layer If Calqueobjet = "SHAB" Then GoTo Objet8 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet8: If returns8.color = acGreen Then returns8.color = acYellow Else: returns8.color = acGreen End If s8 = returns8.Area ' Pour piquer l'objet Surface 9 ThisDrawing.Utility.GetEntity returns9, basePnt, "Sélectionnez la pièce 9 SVP" Calqueobjet = returns9.Layer If Calqueobjet = "SHAB" Then GoTo Objet9 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet9: If returns9.color = acGreen Then returns9.color = acYellow Else: returns9.color = acGreen End If s9 = returns9.Area ' Pour piquer l'objet Surface 10 ThisDrawing.Utility.GetEntity returns10, basePnt, "Sélectionnez la pièce 10 SVP" Calqueobjet = returns10.Layer If Calqueobjet = "SHAB" Then GoTo Objet10 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet10: If returns10.color = acGreen Then returns10.color = acYellow Else: returns10.color = acGreen End If s10 = returns1.Area ' Pour piquer l'objet Surface 11 ThisDrawing.Utility.GetEntity returns11, basePnt, "Sélectionnez la pièce 11 SVP" Calqueobjet = returns11.Layer If Calqueobjet = "SHAB" Then GoTo Objet11 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet11: If returns11.color = acGreen Then returns11.color = acYellow Else: returns11.color = acGreen End If s11 = returns11.Area ' Pour piquer l'objet Surface 12 ThisDrawing.Utility.GetEntity returns12, basePnt, "Sélectionnez la pièce 12 SVP" Calqueobjet = returns12.Layer If Calqueobjet = "SHAB" Then GoTo Objet12 Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "ATTENTION" GoTo SCAPE Objet12: If returns12.color = acGreen Then returns12.color = acYellow Else: returns12.color = acGreen End If s12 = returns12.Area ' Pour calculer le total des surfaces CALCUL: st = s1 + s2 + s3 + s4 + s5 + s6 + s7 + s8 + s9 + s10 + s11 + s12 ' Create new text style Set textStyle1 = ThisDrawing.ActiveTextStyle newFontFile = "C:\WINDOWS\Fonts\arialni.ttf" textStyle1.fontFile = newFontFile ' Arrondit le chiffre de l'aire -en cours de travail- plineAreabistot = st * 100 areaintegertot = plineAreabistot * 1 plineAreabisbistot = plineAreabistot / 100 ' Mémorise le calque courant, l'"active layer" Set currLayerTetxteSurfacetot = ThisDrawing.ActiveLayer ' Créé le layer Texte Surface pour y insérer le texte de la superficie Set newLayerTetxteSurfacetot = ThisDrawing.Layers.Add("Texte Surface Totale") ThisDrawing.ActiveLayer = newLayerTetxteSurfacetot ' Pour insérer le texte Ptinsert = ThisDrawing.Utility.GetPoint(, "Sélectionnez un Point SVP") ' insère le texte de l'aire totale txtsurf = "Surf. Totale = " txtsurf2 = " m²" txtsurftot = plineAreabisbistot & txtsurf2 ThisDrawing.ModelSpace.AddText txtsurftot, Ptinsert, 0.2 ' Retourne sur le calque d'avant l'insertion ThisDrawing.ActiveLayer = currLayerTetxteSurfacetot SCAPE: End Sub

Bonjour à tous... Je vous présente une petite routine qui permet en cliquant sur une polyligne d'insérer un texte contenant la surface arrondie. C'est un outil qui peut servir lors du calcul de surfaces d'appartements. Si quelqu'in pouvait la corriger, notament lorsque je clique sur des surface trop grandes ça ne marche pas. De plus je ne maîtrise pas la fonction "round" alors j'ai rusé... J'ai d'autres routines je vais les chercher et je reviens... Merci d'avance pour vos conseils ! phil_vsd@yahoo.fr Sub Area() ' Calcul de l'aire d'une polyligne et insère la surface dans un calque précis line1: On Error GoTo line2 Dim plineArea As Single Dim plineAreabis As Integer Dim plineAreabisbis As Single Dim areainteger As Integer Dim returnObj As AcadObject Dim Pt1 As Variant Dim Textesurf As String Dim Textem2 As String Dim Texttout As String Dim currLayerTetxteSurface As AcadLayer Dim newLayerTetxteSurface As AcadLayer Dim textStyle1 As AcadTextStyle Dim currFontFile As String Dim newFontFile As String Dim currLayer As AcadLayer 'Variable pour le Calque courant Dim newLayer As AcadLayer ' Variable pour le calque Texte Surface Dim Calqueobjet As String ' Pour piquer l'objet ThisDrawing.Utility.GetEntity returnObj, basePnt, "Sélectionnez un objet SVP" ' Récupère le nom du calque de l'objet choisi, cela permet de prendre un objet qui soit bien une surface Calqueobjet = returnObj.Layer If Calqueobjet = "SHAB" Then GoTo alpha Else MsgBox "Ce n'est pas une Surface SHAB !", vbInformation, "Preuve de votre manque d'attention... :) " GoTo line1 alpha: ' Pour calculer l'aire de l'objet piqué plineArea = returnObj.Area ' Met la surface en rouge pour ne pas se tromper lors du clik, 3000 euros le m² à Marseille... returnObj.color = acRed ' Pour insérer le texte Pt1 = ThisDrawing.Utility.GetPoint(, "Sélectionnez un Point SVP") ' Create new text style Set textStyle1 = ThisDrawing.ActiveTextStyle newFontFile = "C:\WINDOWS\Fonts\ARIALNI.TTF" textStyle1.fontFile = newFontFile ' Arrondit le chiffre de l'aire -en cours de travail- plineArea = Format(plineArea, "#0.00") ' Mémorise le calque courant, l'"active layer" Set currLayerTetxteSurface = ThisDrawing.ActiveLayer ' Créé le layer Texte Surface pour y insérer le texte de la superficie Set newLayerTetxteSurface = ThisDrawing.Layers.Add("Texte Surface Appartement") ThisDrawing.ActiveLayer = newLayerTetxteSurface ' insère le texte de l'aire Textesurf = "Surf. : " Textem2 = " m²" Texttout = plineArea & Textem2 ' Dans ce cas les mots "Surf = " ont été supprimés ThisDrawing.ModelSpace.AddText Texttout, Pt1, 0.14 ' Retourne sur le calque d'avant l'insertion ThisDrawing.ActiveLayer = currLayerTetxteSurface GoTo line1 line2: End Sub

Merci à tous pour vos réponses ! Je vous réponds un peu tard car je n'ai pas eu de net pendant une longue période. J'ai fait quelques routine VBA qui peuvent peut-être aider quelques-un d'entre-nous, je vais tâcher de les faire paraître dans le forum VBA quand j'aurai corrigé les BUGS. :D

Bonjour à tous ! Je suis passé de 2005 à 2006 et sous la version 06 lorsque l'on édite un bloc nous avons un arrière plan blanc, l'espace objet n'est plus visible. Je me servais de l'espace objet pour recaler mes blocs au mieux. Je n'ai pas trouvé l'option pour rendre l'espace objet visible en arrière plan, si quelqu'un pouvait me renseigner... Mille mercis !

Bonjour à tous, il existe un petit logiciel pour capturer les barre d'outils pour en faire un coller dans un autre logiciel, il suffit juste de cliquer sur la barre d'outil. Un prof de CAO me l'avait passé mais je l'ai perdu en cours de route. Je vais tâcher de me le procurer mais je ne garantis pas les délais...