tyrese69_

Bonsoir à tous, Une petite question complémentaire: Comment se met à jour le dictionnaire si l'on change le fichier "stb" de la présentation active ? Afin de récupérer la bonne liste des styles ! Daniel OLIVES

Voici la m^me routine en VBA que je souhaite transposer en Vlisp : Sub NewMenuTPS() Dim objMenuGroups As AcadMenuGroups Dim objMenuPop As AcadPopupMenu Dim objMenu As AcadMenuGroup Dim CommandLisp As String Dim NomMenu As String Dim NomMenuCui As String Dim NomMenuMnr As String Dim i As Integer Dim j As Integer Dim k As Integer Dim menuGrp00 As String Dim menuSsGrp00 As String Dim BitNewMenuTPS As Boolean Dim currMenuGroup As AcadMenuGroup Dim currssMenuGroup As AcadMenuGroup Dim Index As Integer Index = 1 Set objMenuGroups = ThisDrawing.Application.MenuGroups For Each objMenu In ThisDrawing.Application.MenuGroups ' Test des menus de la barre principale If objMenu.name = "TPS" Then ' Test des menus de la barre principale Set currMenuGroup = ThisDrawing.Application.MenuGroups.item(Index - 1) For i = 0 To objMenu.Menus.Count - 1 If objMenu.Menus.item(i).name = "TPS" Then ' Parcours les items du menu "TPS" For j = 0 To objMenu.Menus.item(i).Count - 1 menuGrp00 = currMenuGroup.Menus.item(i).item(j).Label ' Test des item des menus TPS de 1er rang If left(menuGrp00, 11) = "B- à propos" Then '--------------------------------------------------- ' Parcours les items du sous-menu "B- à propos" For k = 0 To objMenu.Menus.item(i).item(j).SubMenu.Count - 1 menuSsGrp00 = currMenuGroup.Menus.item(i).item(j).SubMenu.item(k).Caption ' Test des item du sous-menus "B- à propos" de 2eme rang ' Afin de vérifier la version et la date If menuSsGrp00 = VersionMenuTPS Then BitNewMenuTPS = True Exit For End If Next '---------------------------------------------------- End If Next If BitNewMenuTPS = True Then Exit For End If End If Next If BitNewMenuTPS = True Then Exit For End If End If If BitNewMenuTPS = True Then Exit For End If Next ' Dans le cas ou le menu n'a pas la bonne version , il est RECHARGE ! ' Il faut faire ATTENTION à bien mettre à jour la version dans TPS.mnu en cas de modification ' ainsi le rechargement est automatique ! If BitNewMenuTPS = 0 Then MenuReloadTPS End If End Sub '

Bonjour à tous, J'ai un petit problème ! J'ai un menu partiel "TPS" par exemple qui comporte des sous menus de niveau 1, 2 et 3 ! Comment avoir la liste des item de niveau 1 ? Et comment avoir la liste des item de l'item 1-2 par exemple ? C'est pour vérifier si le texte de cet item est bien à la valeur "TPS1-2" par exemple -0----1----2 TPS ----TPS0 ----TPS1 ---------TPS1-1 ---------TPS1-2 Pas de problèmes pour réaliser cette fonction en VBA, mais comment faire avec les vla et vlax ? daniel OLIVES

0----1----2 TPS ---TPS0 ---TPS1 -------TPS1-1 -------TPS1-2 Pour être plus clair !

Bonjour à tous, J'ai un petit problème ! J'ai un menu partiel "TPS" par exemple qui comporte des sous menus de niveau 1, 2 et 3 ! Comment avoir la liste des item de niveau 1 ? Et comment avoir la liste des item de l'item 1-2 par exemple ? C'est pour vérifier si le texte de cet item est bien à la valeur "toto" par exemple 0 1 2 TPS TPS0 TPS1 TPS1-1 TPS1-2 Pas de problèmes pour réaliser cette fonction en VBA, mais comment faire avec les vla et vlax ? daniel OLIVES

Bonjour Gile, Merci pour ton aide, à bientôt sur le forum ! Olives daniel

Bonjour Tramber, J'ai bien compris qu'il fallait construire la liste, donc j'ai corrigé le code comme suis : (setq ValPrec (cons (cons (XML-Get-Attribute itm "Name" nil) (XML-Get-Attribute itm "Nombre" nil)) ValPrec) En prennant bien soin d'initialiser la 1ere valeur (en réalité la dernière) pour qu'elle corresponde au titres des colonnes. Cela fonctionne donc trés bien maintenant ! Le but est tout simplement de comptabiliser les commandes lisp lancées depuis nos menu entreprise ou via la ligne de commande. Afin de réaliser des statistiques sur leur utilisation par nos partenaires et par nos propres utilisateurs en interne ! C'est dans fichier XML que sont répertoriées les commandes, les fichiers dont elles sont issue et le nombre de fois où elles ont été utilisée. Daniel OLIVES (defun c:LXCU () ;; Load the VisualLISP stuff (vl-load-com) (if (= (GetVerx64) "x64") (setq PathTPSLoad "c:\\TPS\\Acad\\Routinesx64\\") (setq PathTPSLoad "c:\\TPS\\Acad\\Routines\\") ) ;; Store an Active-X object to the main node ("Settings") of the XML data file. (setq oSettings (XML-Get-XMLObject (strcat PathTPSLoad "TPS_Cmd.xml"))) ; (vlax-dump-object oTPSCmds) ;; Store an Active-X object to the "DrawingVars" node of the XML file. (setq oTPSCmds (XML-Get-Child oSettings nil "TPSCmds")) ; (XML-Get-ChildList oTPSCmds) ; (setq oTPSCmd (XML-Get-Child oTPSCmds nil "TPSCmd")) ; (XML-Get-Attribute-List oTPSCmd) (setq ValPrec (list '(" " . " "))) ; (list valprec valret) (foreach itm (XML-Get-ChildList oTPSCmds) ; #<VLA-OBJECT IXMLDOMElement 000000002b3adf60> ; (XML-Get-Attribute-List itm) (if (/= (XML-Get-Attribute itm "Name" nil) "") ; (cons (XML-Get-Attribute itm "Name" nil) (XML-Get-Attribute itm "Nombre" nil)) = ("WC" . "0") (progn ; (list (car exist_list) new_item (last exist_list)) (setq ValPrec (cons (cons (XML-Get-Attribute itm "Name" nil) (XML-Get-Attribute itm "Nombre" nil)) ValPrec)) ) ) ) ;(setq ValPrec (cons (cons '("Name" . "Nombre"))) ValPrec) ; (setq x '(("Title" . "Floorplan") ("Project" . "Project A"))) ; (reverse Valprec) (setq ValPrec (cons (cons "Name" "Nombre") ValPrec)) (dos_proplist "Technip TPS - Comptage des commandes TPS" "Listes des données" ValPrec) )

Re bonjour, Car avec : (setq valprec (list valPrec valLuex)) J'ai par exemple : ((((((((((((((("Name" . "Nombre") ("VC" . "0")) ("PTM" . "0")) ("INS" . "0")) ("INSDS" . "0")) ("INSDT" . "0")) ("XCL" . "0")) ("VT" . "0")) ("SCUG" . "0")) ("SCUO" . "0")) ("SCUI" . "0")) ("ASCU" . "0")) ("DIVPT" . "0")) ("VPCTAB" . "0")) ("WC" . "0")) Mes listes sont imbriquées ! Daniel OLIVES

Bonjour à tous, Voici mon problème : Je souhaite utiliser la fonction: (dos_proplist "Drawing Properties" "Modify Properties" x) Et dans la liste les données doivent ^tre sous la forme : (setq x '(("Title" . "Floorplan") ("Project" . "Project A"))) J'ai dans mon programme une boucle qui lit les valeur d'un fichier XML : dont le résultat est sous la forme : ("WC . "0") extrait du code en fin ! Et du format du fichier XML ! Les fonction XML peuvent être jointes, si vous ne les avez pas déjà ! Daniel OLIVES Ma question est comment ajouter à chaque boucle, la valeur de l'atome trouvé ! Afin de conserver la forme de la liste qui sera utilisable dans (dos_proplist (setq oTPSCmds (XML-Get-Child oSettings nil "TPSCmds")) ; (XML-Get-ChildList oTPSCmds) ; (setq oTPSCmd (XML-Get-Child oTPSCmds nil "TPSCmd")) ; (XML-Get-Attribute-List oTPSCmd) (setq valPrec (cons "Name" "Nombre")) ; (list valprec valret) (foreach itm (XML-Get-ChildList oTPSCmds) ; #<VLA-OBJECT IXMLDOMElement 000000002b3adf60> ; (XML-Get-Attribute-List itm) (if (/= (XML-Get-Attribute itm "Name" nil) "") ; (cons (XML-Get-Attribute itm "Name" nil) (XML-Get-Attribute itm "Nombre" nil)) = ("WC" . "0") (progn ; (list (car exist_list) new_item (last exist_list)) (setq valLuex (cons (XML-Get-Attribute itm "Name" nil) (XML-Get-Attribute itm "Nombre" nil))) ; partie du code à corriger pour conserver la syntaxe !!! [i](setq valprec (list (car valPrec) valLuex (last valPrec)))[/i] ; ) ) ) <?xml version="1.0"?> <Settings> <TPSCmds> <TPSCmd Name="EJPROPS" Fichier="Egidj_acad.vlx" Nombre="0"/> <TPSCmd Name="EJRIMG" Fichier="Egidj_acad.vlx" Nombre="0"/> </TPSCmds> </Settings>

Bonjour à tous, Est ce qu'il est possible de faire une pop up temporisée (et si possible sans aucun bouton!) comme le suggère : (setq WScript (vlax-create-object "WScript.Shell")) (setq ret (vlax-invoke WScript 'Popup Message Timeout Title Flags)) Mais qui ne marche pas avec mon Pc avec AutoCAd 2010, sous Seven en x64 ! Quelqu'un a t'il une solution? daniel OLIVES

Re bonjour, C'était tout simple avec une autre routine dispo sur le site ! J'ai convertit la liste sans guillemets en liste avec ! ; (str2lst "a b c" " ") (defun str2lst (str sep / pos) (if (setq pos (vl-string-search sep str)) (cons (substr str 1 pos) (str2lst (substr str (+ (strlen sep) pos 1)) sep) ) (list str) ) ) Daniel OLIVES

Bonjour à tous, Je cherche à afficher une liste sans guillemets du type : s::startup getverx64 tpsload doslibcharg C:TPSDOSLIB C:TPSH C:TPSA C:MSADOX issue de la commande "lstdefun" de ce même forum ! sujet de ce forum : Afin d'améliorer l'affichage, dans une fenêtre avec liste déroulante comme celle des doslib ou autre ! (dos_listbox "Set Current Layer" "Select a layer" '("Layer1" "Layer2" "Layer3")) daniel OLIVES

Bonjour à tous, Encore merci à toi Gile, il faudra que je regarde le dot net un de ces jours ! Voici le résultat en VLISP: avec les routines de : ;;;************************************************************************ ;;; 100 - api-xml.lsp ;;; Prepared by: J. Szewczak ;;; Date: 4 January 2004 ;;; Purpose: To provide an API for interfacing with XML files. ;;; Copyright (c) 2004 - AMSEC LLC - All rights reserved du forum TheSwamp : http://www.theswamp.org/index.php?topic=525.30 ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - ; "C:\\TPS\\Acad\\Routinesx64\\TPS-Cmd.xml" ;<Settings> ; <Layers> ; <Layer Name="Walls" Color="2" LineType="continuous"/> ; <Layer Name="Furniture" Color="3" LineType="HIDDEN"/> ; </Layers> ; <DrawingVars> ; <RegenAuto>1</RegenAuto> ; <EdgeMode>0</EdgeMode> ; <Osmode>383</Osmode> ; </DrawingVars> ; <TPSCmds> ; <TPSCmd Name="VC" Fichier="TPS_Cmd.lsp" Nombre="1"/> ; <TPSCmd Name="PTM" Fichier="TPS_Cmd.lsp" Nombre="1"/> ; <TPSCmd Name="INS" Fichier="TPS_Cmd.lsp" Nombre="1"/> ; <TPSCmd Name="INSDS" Fichier="TPS_Cmd.lsp" Nombre="1"/> ; <TPSCmd Name="INSDT" Fichier="TPS_Cmd.lsp" Nombre="1"/> ; </TPSCmds> ;</Settings> ; (defun ReadXml ( oXML (defun LecCmdXml ( FileCmd NameCmd /) ;; Load the VisualLISP stuff (vl-load-com) ;; Store an Active-X object to the main node ("Settings") of the XML data file. (setq oSettings (XML-Get-XMLObject "C:\\TPS\\Acad\\Routinesx64\\TPS_Cmd1.xml")) ;; Store an Active-X object to the "DrawingVars" node of the XML file. ;;(setq oDwgVars (XML-Get-Child oSettings nil "DrawingVars")) ; ; (setq oTPSCmds (XML-Get-Child oSettings nil "TPSCmds")) ;; The following two lines return the exact same thing. ;; An string object representing the value stored in the RegenAuto child node of the DrawingVars node. ;; (setq sRegenValue (XML-Get-Child-Value oDwgVars nil "RegenAuto")) ; or ;; (setq sRegenValue (XML-Get-Child-Value oSettings "DrawingVars" "RegenAuto")) ;; Return the value that is stored inside a "Color" attribute from the child node of Layers whose "Name" attribute = "Walls" ;;(setq color (read (XML-Get-Attribute (XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" "-1"))) (setq Lnbre (read (XML-Get-Attribute (XML-Get-Child-ByAttribute oSettings "TPSCmds" "Name" NameCmd) "Nombre" "-1"))) ;; if the value for 'color' that we got above is less than the zero (our supplied default argument was -1). ;; then we'll set that attribute to 2. ;(if (< Lnbre 0) (progn ;; (XML-Put-Attribute (XML-Get-Child-ByAttribute oSettings "Layers" "Name" "Walls") "Color" 2) (XML-Put-Attribute (XML-Get-Child-ByAttribute oSettings "TPSCmds" "Name" NameCmd) "Nombre" (itoa (+ Lnbre 1))) ;; After changing the Active-X object that is resident in memory, ;; we have to save all of our changes back to the XML file. (XML-Save oSettings) ) ;) ;; release the objects (vlax-release-object oSettings) ; (vlax-release-object oDwgVars) )

Bonsoir à tous, Voici un fichier XML : <?xml version="1.0"?> <TPS_CMD_TABLE> <TPSCmds><NAME>XCL</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>1</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>VC</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>VT</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>PTM</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>SCUG</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>SCUO</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>SCUI</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>INS</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>INSDS</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>INSDT</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>ASCU</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>TPSU</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>DIVPT</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> <TPSCmds><NAME>VPCTAB</NAME><FILENAME>TPS_Cmd.lsp</FILENAME><CMD_NUMBER>0</CMD_NUMBER></TPSCmds> </TPS_CMD_TABLE> Qui doit mémoriser, les actions faites par une commande AutoCAD ! Ma question est comment incrémenter la valeur de <CMD_NUMBER>0</CMD_NUMBER> de 0 à 1 etc Pour une valeur spécifique de la valeur <NAME>ASCU</NAME> Je n'ai pas de problème de lecture, mais pour écrire .???? merci d'avance ! Daniel OLIVES

Bonjour et tous mes meilleurs voeux pour cette nouvelle année ! Je m'interroge sur un pointdans la pièce jointe j'ai bien les deux filtres de couche de mon dessin, mais à quoi correspondent les deux suivants ? "Remplacements de fenêtre" "Nouveaux calques non rapprochés" Daniel OLIVES

Bonjour Patrick_35, Merci à toi ! Il va bien falloir qu'un de ces jours je me penche sur ces fonctions LISP: member mapcar append lambda etc qui simplifie bien la vie des programmeurs ! car l'imbrication de celles-ci n'est pas des plus explicite ! Daniel OLIVES

Re , Au fait si je souhaite avoir la valeur texte de : <Nom d'entité: 7ed8ca98> Comment doit je procéder (pour afficher la valeur pour essais !) Daniel OLIVES Merci encore à toi (Gile)

Re bonjour, J'ai enfin compris ! (defun c:GetVP (/ vp elst) (setq vp (car (entsel "\nSélectionnez une fenêtre simple ou de type polyLigne: "))) (if (= (cdr (assoc 0 (setq elst (entget vp)))) "VIEWPORT") ;_ l'objet sélectionné est une fenêtre (setq ValVP vp) ) (if (and (setq vpPol (cdr (assoc 330 (member '(102 . "{ACAD_REACTORS") elst)))) ;_ l'objet sélectionné a un groupe 330 <Nom d'entité: 7ed8ca98> Cas d'une polyLigne (= "VIEWPORT" (cdr (assoc 0 (entget vpPol))))) ; qui est bien une fenêtre (setq ValVP vpPol) ) ValVP ) Dans ValVP j'ai bien soit l'une soit l'autre selon le fenêtre choisie ! Daniel OLIVES

Re Bonjour Gile je crois que mon problème vient du fait que je sélectionne une fenêtre polyligne !

Bonjour Gile J'ai un petit PB ave ton code, le if est toufour faux Dans le And j'ai bien (= "VIEWPORT" (cdr (assoc 0 (entget vp)))) = T Mais pour : (setq vp (cdr (assoc 330 (member '(102 . "{ACAD_REACTORS") elst)))) = <Nom d'entité: 7ed8ca98> Par contre (= (cdr (assoc 0 (setq elst (entget vp)))) "VIEWPORT") = T Donc le Or devrait donner (J'ai un peut de mal avec le LISP !) (defun c:GetV (/ vp elst) (setq vp (car (entsel "\nSélectionnez une fenêtre: "))) (if (or (= (cdr (assoc 0 (setq elst (entget vp)))) "VIEWPORT") ;_ l'objet sélectionné est une fenêtre (and (setq vp (cdr (assoc 330 (member '(102 . "{ACAD_REACTORS") elst)))) ;_ l'objet sélectionné a un groupe 330 (= "VIEWPORT" (cdr (assoc 0 (entget vp)))) ; qui est bien une fenêtre ) ) vp ) ) Quelle est la différence car ici dans !vp j'ai bien <Nom d'entité: 7ed8ca98> Daniel OLIVES

Bonsoir à tous, Dans une couche d'un dessin certain paramètres sont spécifiques, si la PVIEWPORT est dans l'espace model (objet) 1°) Par exemple, les couches gelées sont gérées par des Xdatas (1003), pour ce point pas de problèmes pour lire ces données. Mais pour le point suivant: Comment recopier les données d'une fenêtre afin de les coller à une autre ? 2°) De plus comment modifie t'on tous les autres paramètres par programmation et comment bien les différencier ? Qui me semble t'il sont : - la couleur - le type de ligne - épaisseur de la ligne - style de tracé Aprés quelques recherches sur divers forums : Dans l'exemple : (((102 . "{ADSK_LYR_COLOR_OVERRIDE") (335 2128140952 2095807911) (420 . -1023409976) (102 . "}") (102 . "{ADSK_LYR_COLOR_OVERRIDE") (335 2128146920 2095797975) (420 . -1023409974) (102 . "}")) ((290 . 1))) (335 2128140952 2095807911) ^ ^ 7ed8da98 7ceb7da7 Ce sont les nom des entités VIEWPORT et COUCHE concernées ! et pour la couleur : ; (last (LM:TRUE->RGB -1023409976 )) ---> 200 -1023409974 = 202 (defun LM:True->RGB ( c ) (list (lsh (lsh (fix c) 8) -24) (lsh (lsh (fix c) 16) -24) (lsh (lsh (fix c) 24) -24) ) ) Daniel OLIVES

Bonjour, Patrick, Avec les class VLAX je mixe le VBA et le LISP donc ce message aurait pu être mis aussi en VBA ou LISP car le problème est lié !! Désolé !! Daniel OLIVES Je vais le mettre en LISP ce sera plus judicieux !

Bonjour à tous, La commande suivante : (LM:GetOverrideData "EL_CDC_CFa-hach") Dans dessin dont la couche nommée : "EL_CDC_CFa-hach" possède un type de ligne forcée en espace objet flottant d'une viewport, idem pour un style et pour une épaisseur de ligne ! D'où les trois Xrec ci-aprés pour cette couche ! ( ((102 . "{ADSK_LYR_LINETYPE_OVERRIDE") (335 2128120472 2081625312) (343 2128127064 2081634848) (102 . "}")) ((102 . "{ADSK_LYR_LINEWT_OVERRIDE") (335 2128120472 2081625312) (91 . 80) (102 . "}")) ((102 . "{ADSK_LYR_PLOTSTYLE_OVERRIDE") (335 2128120472 2081625312) (344 2128108584 2081669712) (102 . "}")) ) Ma question est comment selon ces data extraire les valeur spécifiques des record en fonction de : "{ADSK_LYR_LINEWT_OVERRIDE" afin d'avoir seulement la valeur : "2128127064" et "2081634848" de (343 ... ou "{ADSK_LYR_LINETYPE_OVERRIDE") afin d'avoir seulement la valeur : "80" de (91 ... ou "{ADSK_LYR_PLOTSTYLE_OVERRIDE") afin d'avoir seulement la valeur : "2128108584" et "2081669712" de (344 ... et comment des ces valeur d'entity name en decimal retrouver les objets associés ? Daniel OLIVES (defun LM:GetOverrideData ( layer / data ) (vl-load-com) ;; © Lee Mac 2010 (if (and (not (vl-catch-all-error-p (setq layer (vl-catch-all-apply 'vla-item (list (vla-get-Layers (vla-get-ActiveDocument (vlax-get-acad-object) ) ) layer ) ) ) ) ) (eq :vlax-true (vla-get-HasExtensionDictionary layer)) ) (vlax-for xRecord (vla-getExtensionDictionary layer) (vla-getXRecordData xRecord 'typ 'val) (setq data (cons (LM:Variants->DXF typ val) data)) ) ) (reverse data) ) ;;-------------------=={ Variant Value }==--------------------;; ;; ;; ;; Converts a VLA Variant into native AutoLISP data types ;; ;;------------------------------------------------------------;; ;; Author: Lee McDonnell, 2010 ;; ;; ;; ;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; ;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; value - VLA Variant to process ;; ;;------------------------------------------------------------;; ;; Returns: Data contained within variant ;; ;;------------------------------------------------------------;; ; (defun LM:VariantValue ( value ) ;; © Lee Mac 2010 (cond ( (eq 'variant (type value)) (LM:VariantValue (vlax-variant-value value)) ) ( (eq 'safearray (type value)) (mapcar 'LM:VariantValue (vlax-safearray->list value)) ) ( value ) ) ) ;;------------------=={ Variants->DXF }==---------------------;; ;; ;; ;; Converts Type and Value Variants to a DXF List ;; ;;------------------------------------------------------------;; ;; Author: Lee McDonnell, 2010 ;; ;; ;; ;; Copyright © 2010 by Lee McDonnell, All Rights Reserved. ;; ;; Contact: Lee Mac @ TheSwamp.org, CADTutor.net ;; ;;------------------------------------------------------------;; ;; Arguments: ;; ;; typ - VLA Variant of Integer type ;; ;; val - VLA Variant of Variant type ;; ;;------------------------------------------------------------;; ;; Returns: DXF List ;; ;;------------------------------------------------------------;; ; (defun LM:Variants->DXF ( typ val ) ;; © Lee Mac 2010 (apply 'mapcar (cons 'cons (mapcar 'LM:VariantValue (list typ val)) ) ) ) ;Example: ; (LM:GetOverrideData "0") ; * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

La suite : '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * '* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '* 05 - Affichage des couches gelées * '* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * ' Sub VpLayerAffListOff(objPViewport As AcadPViewport) Dim xdataType As Variant Dim xdataValue As Variant Dim newXdataType As Variant Dim newXdataValue As Variant Dim i As Integer Dim counter As Integer Dim Pt1 As Variant Dim varCenter As Variant Dim dblWidth As Double Dim dblHeight As Double Dim objViewPortNew As AcadPViewport ' Get the Xdata from the Viewport objPViewport.GetXData "ACAD", xdataType, xdataValue For i = LBound(xdataType) To UBound(xdataType) ' Look for frozen Layers in this viewport If xdataType(i) = 1003 Then ' Set the counter AFTER the position of the Layer frozen layer(s) counter = i + 1 mess = mess & xdataValue(i) & vbCrLf ' Match the layer we are looking for and exit the sub -- ' bingo we have the frozen layer location! End If Next ' Layer not found in this Mview If counter = 0 Then MsgBox "Pas de couches gelées", vbInformation, "Technip TPS - PViewport Xdata - Liste des Layer Off" Exit Sub End If MsgBox mess, vbInformation, "Technip TPS - PViewport Xdata - Liste des Layer Off" End Sub '

Bonjour à tous, Losque l'on sélectionne une viewport (fenêtre) de type polyligne, c'est toujour l'objet "polyligne" qui est retourné ! Comment obtenir la fenêtre associée ? La même question pourrait être faite pour les objets sélectionnés de type ellipse, cercle, spline ou nuage (idem polyligne) Dans l'exemple ci-aprés, la sélection se fait par les caractéristiques des objets ! : Daniel OLIVES '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * '* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '* 04 - Test les fenêtre afin d'afficer les couches gelées * '* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - * '* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * Sub TestVpLayerX() Dim strLayer As String Dim objAcad As AcadObject Dim Pt1 As Variant Dim strPrompt As String ' Dim bValtrouv As Boolean Dim myLayout As AcadLayout Dim myPViewport As IAcadPViewport Dim PtCenterEll As Variant Dim PtCenterPV As Variant Dim PtCenterPLW(0 To 2) As Double Dim region_element(0) As AcadEntity Dim region As Variant Dim reg As AcadRegion Dim centroid As Variant Dim returnPnt(0 To 2) As Double Dim MinPTBx As Variant Dim MaxPTBx As Variant Dim MilieuxPTBx(0 To 2) As Double Dim AreaSpline As Variant Dim AreaRegion As Variant On Error GoTo err_selectVPobjectsToFreeze ' set an undo mark in the drawing ThisDrawing.StartUndoMark If ThisDrawing.ActiveSpace = acModelSpace Then ' Passe en espace papier ThisDrawing.ActiveSpace = acPaperSpace ' Non flottant ThisDrawing.Mspace = False 'MsgBox "This program only works with PaperSpace Viewports" & vbCr & _ ' "Please go to PaperSpace", vbCritical 'Exit Sub End If ' let's get into Paper Space ' ThisDrawing.Mspace = False '************************* ' VIEWPORT '********** ThisDrawing.Utility.GetEntity objAcad, Pt1, "Sélectionner une fenêtre (ViewPort) :" bValtrouv = False If TypeOf objAcad Is AcadPViewport Then Set myPViewport = objAcad bValtrouv = True mess = "Vous avez sélectionné une fenêtre type ""PViewport"" !" & vbCrLf & vbCrLf End If '************************* ' SPLINE '******** If TypeOf objAcad Is IAcadSpline Then ' - - - - - - - - - - - - - - - - - - - - - - - - - - ' Création de la région '------------------------ Set region_element(0) = objAcad region = ThisDrawing.ModelSpace.AddRegion(region_element) Set reg = region(0) ' Le point de base du texte est le centre de la region centroid = reg.centroid PtCenterPLW(0) = centroid(0): PtCenterPLW(1) = centroid(1): PtCenterPLW(2) = 0 ' - - - - - - - - - - - - - - - - - - - - - - - - - - mess = "Vous avez sélectionné une fenêtre type ""SPLINE"" !" & vbCrLf & vbCrLf For Each objAcad In ThisDrawing.PaperSpace If TypeOf objAcad Is IAcadPViewport Then Set myPViewport = objAcad PtCenterPV = myPViewport.center ' Attention différences selon précision ! If myPViewport.Clipped = True And (Abs(PtCenterPLW(0) - PtCenterPV(0)) < (1 * (PtCenterPV(0) / 100)) And _ Abs(PtCenterPLW(1) - PtCenterPV(1)) < (1 * (PtCenterPV(1) / 100)) And PtCenterPLW(2) = PtCenterPV(2)) Then ' MsgBox "Fenêtre récupérée !" bValtrouv = True Exit For End If End If Next End If '************************* ' CERCLE '******** If TypeOf objAcad Is IAcadCircle Then PtCenterEll = objAcad.center mess = "Vous avez sélectionné une fenêtre type ""Cercle"" !" & vbCrLf & vbCrLf For Each objAcad In ThisDrawing.PaperSpace If TypeOf objAcad Is IAcadPViewport Then Set myPViewport = objAcad PtCenterPV = myPViewport.center ' Attention différences selon précision ! Faire essai avec % de valeur If myPViewport.Clipped = True And ((PtCenterEll(0) - PtCenterPV(0)) < (0.1 * (PtCenterPV(0) / 100)) And _ (PtCenterEll(1) - PtCenterPV(1)) < (0.1 * (PtCenterPV(1) / 100)) And PtCenterEll(2) = PtCenterPV(2)) Then ' MsgBox "Fenêtre récupérée !" bValtrouv = True Exit For End If End If Next End If '************************* ' ELLIPSE '********* If TypeOf objAcad Is IAcadEllipse Then PtCenterEll = objAcad.center mess = "Vous avez sélectionné une fenêtre type ""Ellipse"" !" & vbCrLf & vbCrLf For Each objAcad In ThisDrawing.PaperSpace If TypeOf objAcad Is IAcadPViewport Then Set myPViewport = objAcad PtCenterPV = myPViewport.center If myPViewport.Clipped = True And (PtCenterEll(0) = PtCenterPV(0) And _ PtCenterEll(1) = PtCenterPV(1) And PtCenterEll(2) = PtCenterPV(2)) Then ' MsgBox "Fenêtre récupérée !" bValtrouv = True Exit For End If End If Next End If '************************* ' POLYLIGNE ou NUAGE '******************** If TypeOf objAcad Is AcadLWPolyline Then objAcad.GetBoundingBox MinPTBx, MaxPTBx MilieuxPTBx(0) = (MaxPTBx(0) + MinPTBx(0)) / 2 MilieuxPTBx(1) = (MaxPTBx(1) + MinPTBx(1)) / 2 MilieuxPTBx(2) = 0 mess = "Vous avez sélectionné une fenêtre type ""Polyligne"" !" & vbCrLf & vbCrLf ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - For Each objAcad In ThisDrawing.PaperSpace If TypeOf objAcad Is IAcadPViewport Then Set myPViewport = objAcad PtCenterPV = objAcad.center If myPViewport.Clipped = True And (MilieuxPTBx(0) = PtCenterPV(0) And _ MilieuxPTBx(1) = PtCenterPV(1) And MilieuxPTBx(2) = PtCenterPV(2)) Then ' MsgBox "Fenêtre récupérée !" bValtrouv = True Exit For End If End If Next End If If bValtrouv = True Then VpLayerAffListOff myPViewport ' Place an end to the undo mark ThisDrawing.EndUndoMark End If ' exit this sub Exit Sub ' error handling err_selectVPobjectsToFreeze: MsgBox Err.Description, vbInformation Err.Clear ThisDrawing.EndUndoMark End Sub '