CADsite

  • ma 25 10 2021, 13:19:09
  • Welkom, gast
Log in of registreer jezelf.

Login met gebruikersnaam, wachtwoord en sessielengte
Geavanceerd zoeken  

Nieuws:

Toon bijdragen

Deze sectie stelt je in staat om alle bijdragen van dit lid te bekijken. Je kunt alleen de bijdragen zien waar je op dit moment toegang toe hebt.

Topics - cadtools@gmail.com

Pagina's: [1] 2
1
forum / Nieuw hoofstuk: BricsCAD !
« Gepost op: zo 23 08 2020, 22:59:26 »
 Nieuw hoofdstuk: BricsCAD !

Bye Bye AutoCAD

2
AutoCAD probleem / omzetten naar dll
« Gepost op: zo 23 08 2020, 22:55:53 »
Hallo

Een eeuwigheid geleden dat ik hier vaker kwam. Sorry  :(
Zal mijn best weer doen om vaker van de partij te zijn.
Vraagje: is er iemand bekend met omzetten code naar dll .net
Ik ben er neit bedreven in. Ben geen fan van Visual studio. Te complex, te grote installs.

Deze code wil ik graag inladen


===



Imports Autodesk.AutoCAD.ApplicationServices
Imports Autodesk.AutoCAD.Runtime
Imports Autodesk.AutoCAD.DatabaseServices
Imports Autodesk.AutoCAD.EditorInput
Imports Autodesk.AutoCAD.Geometry

Public Class Contour_rhino
<CommandMethod("CONTOUR", CommandFlags.Modal)> Sub Contour()
        'Create sections of surfaces and solids at intervals in a specific direction.
        Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
        Dim ed As Editor = doc.Editor
        Dim db As Database = doc.Database

        Try
            ed.WriteMessage(vbLf & "Select one or more 3Dsolids or Surfaces:")
            Dim sf As New SelectionFilter(New TypedValue() {New TypedValue(0, "SURFACE,PLANESURFACE,EXTRUDEDSURFACE,SWEPTSURFACE,LOFTEDSURFACE,REVOLVEDSURFACE,NURBSURFACE,3DSOLID")})

            Dim pSelRes As PromptSelectionResult = ed.GetSelection(sf)
            If pSelRes.Status <> PromptStatus.OK Then
                Return
            End If

            Dim objIdArray() As ObjectId = pSelRes.Value.GetObjectIds()
            ed.WriteMessage(vbLf & "{0} Solids or Surfaces were selected.", objIdArray.Count)

            Using trx As Transaction = db.TransactionManager.StartTransaction()
                Dim btr As BlockTableRecord = TryCast(trx.GetObject(db.CurrentSpaceId, OpenMode.ForWrite), BlockTableRecord)
                Dim StrtPt, EndPt As Point3d

                With Start_End_Direction.LineJigger.Jig()
                    StrtPt = .startpunt
                    EndPt = .eindpunt
                End With

                Dim Dist As Double = SelDistance() 'Distance
                If Dist = Nothing Then Exit Sub

                Dim IntermediatePt As Point3d = StrtPt
                Dim vecDir As Vector3d = StrtPt.GetVectorTo(EndPt).GetNormal 'normalvector of direction
                vecDir = vecDir.MultiplyBy(Dist) 'Normal vector multiplied by distance
                For Each oid As ObjectId In objIdArray
                    Dim ent As DBObject = trx.GetObject(oid, OpenMode.ForRead)

                    If TypeOf ent Is Solid3d Then 'Solid3D

                        Using sol As Solid3d = DirectCast(trx.GetObject(oid, OpenMode.ForRead), Solid3d)
                            While Not IntermediatePt.DistanceTo(EndPt) < Dist
                                Try

                                    Dim SectReg As Autodesk.AutoCAD.DatabaseServices.Region = sol.GetSection(New Plane(IntermediatePt, vecDir))
                                    SectReg.ColorIndex = 1
                                    btr.AppendEntity(SectReg)
                                    trx.AddNewlyCreatedDBObject(SectReg, True)
                                    'RegionToPolyline(SectReg.ObjectId, True) 'Hier zit nog een klein gekkigheidje in.
                                    IntermediatePt = New Point3d((IntermediatePt.X + vecDir.X), (IntermediatePt.Y + vecDir.Y), (IntermediatePt.Z + vecDir.Z))

                                Catch NoIntersection As Exception When NoIntersection.Message = "eNoIntersections"
                                    IntermediatePt = New Point3d((IntermediatePt.X + vecDir.X), (IntermediatePt.Y + vecDir.Y), (IntermediatePt.Z + vecDir.Z))

                                End Try
                            End While

                        End Using
                    End If

                    If TypeOf ent Is Autodesk.AutoCAD.DatabaseServices.Surface Then 'Surface

                        Using surf As Autodesk.AutoCAD.DatabaseServices.Surface = DirectCast(trx.GetObject(oid, OpenMode.ForRead), Autodesk.AutoCAD.DatabaseServices.Surface)
                            While Not IntermediatePt.DistanceTo(EndPt) < Dist

                                Dim SectionEntities As Entity() = surf.CreateSectionObjects(New Plane(IntermediatePt, vecDir))
                                If SectionEntities IsNot Nothing Then

                                    For Each SectEnt As Entity In SectionEntities
                                        SectEnt.ColorIndex = 1
                                        btr.AppendEntity(SectEnt)
                                        trx.AddNewlyCreatedDBObject(SectEnt, True)
                                    Next
                                End If

                                IntermediatePt = New Point3d((IntermediatePt.X + vecDir.X), (IntermediatePt.Y + vecDir.Y), (IntermediatePt.Z + vecDir.Z))

                            End While
                        End Using
                    End If

                    IntermediatePt = StrtPt
                Next

                trx.Commit()
            End Using

        Catch ex As Exception
            ed.WriteMessage(vbLf & "Something went wrong:"  & vbLf & ex.ToString())

        End Try
    End Sub


Function SelDistance() As Double
       
        Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
        Dim pDblOpts As PromptDoubleOptions = New PromptDoubleOptions("") With {
            .Message = vbCrLf & "Enter interval distance: ",
            .AllowZero = False,
            .AllowNegative = False,
            .AllowNone = False
          }
        Dim PromptDistance = doc.Editor.GetDouble(pDblOpts)

        If PromptDistance.Status = PromptStatus.OK Then
            SelDistance = PromptDistance.Value
        Else
            SelDistance = Nothing
        End If

    End Function


End Class


Namespace Start_End_Direction
    'Adapted from:
    'https://spiderinnet1.typepad.com/blog/2013/07/autocad-jig-vbnet-dynamic-dimension-and-line-jig-using-entityjig.html

    Public Class LineJigger
        Inherits EntityJig

        Private Shared mEndPoint As Point3d = New Point3d()

        Public Sub New(ByVal ent As Line)
            MyBase.New(ent)
        End Sub

        Protected Overrides Function Update() As Boolean
            '(TryCast(Entity, Line)).EndPoint = mEndPoint
            Dim lijn As Line = TryCast(Entity, Line)
            lijn.EndPoint = mEndPoint
            Return True
        End Function

        Protected Overrides Function Sampler(ByVal prompts As JigPrompts) As SamplerStatus
            Dim prOptions1 As JigPromptPointOptions = New JigPromptPointOptions(vbLf & "Select endpoint and direction: ") With {
                .BasePoint = (TryCast(Entity, Line)).StartPoint,
                .UseBasePoint = True,
                .UserInputControls = UserInputControls.Accept3dCoordinates Or UserInputControls.AnyBlankTerminatesInput Or UserInputControls.GovernedByOrthoMode Or UserInputControls.GovernedByUCSDetect Or UserInputControls.UseBasePointElevation Or UserInputControls.InitialBlankTerminatesInput Or UserInputControls.NullResponseAccepted
            }
            Dim prResult1 As PromptPointResult = prompts.AcquirePoint(prOptions1)
            If prResult1.Status = PromptStatus.Cancel Then Return SamplerStatus.Cancel

            If prResult1.Value.Equals(mEndPoint) Then
                Return SamplerStatus.NoChange
            Else
                mEndPoint = prResult1.Value
                Return SamplerStatus.OK
            End If
        End Function

        Public Shared Function Jig() As (startpunt As Point3d, eindpunt As Point3d)
            Try

                Dim doc As Document = Autodesk.AutoCAD.ApplicationServices.Application.DocumentManager.MdiActiveDocument
                Dim ed As Editor = doc.Editor
                Dim ppr As PromptPointResult = ed.GetPoint(vbLf & "Select startpoint: ")
                If ppr.Status <> PromptStatus.OK Then Return Nothing
                Dim pt As Point3d = ppr.Value
                Dim ent As Line = New Line(pt, pt) With {
                    .ColorIndex = 4
                }
                ent.TransformBy(ed.CurrentUserCoordinateSystem)
                Dim jigger As LineJigger = New LineJigger(ent)
                Dim pr As PromptResult = ed.Drag(jigger)

                Return (ent.StartPoint, ent.EndPoint)
            Catch

                Return (Nothing, Nothing)
            End Try

        End Function

    End Class
End Namespace


3
AutoCAD tips / AutoCAD PLAN (that does not zoom out)
« Gepost op: wo 06 09 2017, 23:24:55 »
Hoi Ik heb iets geprogrammeerd.
Misschien denk je, wat moet ik er mee? of misschien .. dat kan beter... Ik doe dat meestal anders ..
Ik hoop op het laatste, daarom deel ik hem even

onderstaande demo over gebruik, spreek neem ik aan voor zich



https://youtu.be/cN_QbiOR7co


; command PLAN gebruiken zonder uit te zoomen
; custom command voor instellen UCS naast ucsfollow                                         
; view to ucs => PLN in plaats van PLAN
; UCS World => WCS
; UCS view / object / face / 3 punten => UCV UCO UCF UCO3
; roteer ucs 90 graden : UCM

; PLN werkt in 3d met EXPLAN (EXPRESS tools)

(defun c:pln ()
    (setq getviewdir (getvar "viewdir"))
    (setq getviewdir_x (car getviewdir))
    (setq getviewdir_y (car (cdr getviewdir)))
    (setq result_pln (+ getviewdir_x getviewdir_y))
    (print result_pln)
    (if (= result_pln 0) (c:pln_2d) (c:explan))
)


(defun c:pln_2d ()
 (setq vctr (getvar "viewctr"))
 (setq vsize (getvar "viewsize"))
 (setq olducsfollow (getvar "ucsfollow"))   
 (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ())     
 (setq getosnapz (getvar "osnapz")) (if (= getosnapz 1) (setvar "gridmode"  1) (setvar "gridmode"  0))   
 (command "plan" "")
 (command "_.zoom" "c" vctr vsize)   
 (command "ucs" "v")
 (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
)


(defun C:ucp ()
  (prompt "\t* UCS - previous")
  (SETVAR "UCSICON" 1)
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ())
  (command "UCS" "p")
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
  (prin1)
)

(defun C:ucf ()
  (prompt "\t* set UCS to face")
  (SETVAR "GRIDMODE" 0)
  (SETVAR "OSNAPZ" 0)
  (SETVAR "UCSICON" 1)
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ()) 
  (command "UCS" "f" pause pause)
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
  (prin1)
)


(defun C:UCO(/ ENT1 )
  (setq ENT1 (entsel "\nPick object to align UCS:"))
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ()) 
  (command "ucs" "ob" ENT1)
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
  (princ)


(defun C:uc3 ()
  (prompt "\t* set UCS 3 points")
  (SETVAR "GRIDMODE" 0)
  (SETVAR "OSNAPZ" 0)
  (SETVAR "UCSICON" 1)
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ())
  (command "UCS" "3" pause pause pause)
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
  (prin1)
)

(defun C:ucm ()
  (setvar "cmdecho" 0) 
  (prompt "\t* draai UCS haaks MET de klok mee")
  (setvar "UCSICON" 1)
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ()) 
  (command "UCS" "z" "")
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde 
  (prin1)
)


(defun C:WCS ()
  (setvar "UCSICON" 1)
  (setq olducsfollow (getvar "ucsfollow"))   
  (setq getucsfollow (getvar "ucsfollow")) (if (= getucsfollow 1) (setvar "ucsfollow"  0) ())
  (command "UCS" "")
  (setvar "ucsfollow" olducsfollow) ; voorgaande waarde
  (prin1)
)



4
Autolisp / Uitdaging : visual PFACE routine
« Gepost op: vr 21 04 2017, 00:02:49 »
Hoi

Ik zag dat Lee Mac een nieuw stukje code heeft gemaakt voor Grsnap. Nu speel met het idee dat dit een mooie basis zou zijn om een fijnere command te programmeren om basis hiervan.

Ik kan erg weinig vinden qua PFACE lisp voorbeelden en documentatie, maar volgens mij zou het niet zo ingewikkeld moeten zijn en ik denk dat je er veel plezier mee kunt hebben om 3D vlakken te maken.

Broncode voor ondersteuning
http://lee-mac.com/grsnap.html

Het idee in een filmpje..
https://youtu.be/3NSCJs8Q2AY

5
AutoCAD probleem / Snelheid
« Gepost op: zo 16 04 2017, 22:00:16 »
Check gifs.
Kan het zijn dat een locale AutoCAD installatie zo traag werkt..?

6
Autolisp / OpenDCL Color_swatch
« Gepost op: di 14 02 2017, 23:24:57 »
Hoi

Ik heb nogal wat tijd en moeite gestopt om een dialoogvenster voor elkaar te krijgen.
Werkt prima tot nu toe. Wat ik alleen nog zou willen, is dit..:

Het laden en toewijzen van objecten werkt nu alleen ná activeren van de functie. Echter, hij zou ontzettend cool zijn als het ook zou werken als je eerst objecten zou hebben geselecteerd.

Wie is er handig met OpenDCL?

https://youtu.be/69toSigzGso

7
Autolisp / Willekeurige layer kleuren
« Gepost op: di 02 08 2016, 14:58:32 »
Als je output hebt met veel blocks of veel lagen..
dan kan dit tooltje handig zijn om ze zien wat waar zit.
Geeft contrast..




; random layer colors
;; Rand  -  Lee Mac
;; PRNG implementing a linear congruential generator with
;; parameters derived from the book 'Numerical Recipes'
(defun LM:rand ( / a c m )
    (setq m   4294967296.0
          a   1664525.0
          c   1013904223.0
          $xn (rem (+ c (* a (cond ($xn) ((getvar 'date))))) m)
    )
    (/ $xn m)
)
;; Random in Range  -  Lee Mac
;; Returns a pseudo-random integral number in a given range (inclusive)
(defun LM:randrange ( a b )
    (+ (min a b) (fix (* (LM:rand) (1+ (abs (- a b))))))
)


(defun c:lcolor nil
    (vlax-for x (vla-get-layers (vla-get-activedocument (vlax-get-acad-object)))
        (vla-put-color x (LM:randrange 10 249))
    )
    (princ)
)

(vl-load-com) (princ)

8
Autolisp / Image met standaardwaarde inladen
« Gepost op: di 19 07 2016, 13:10:45 »
Ik heb mijn default routine om images nu aangepast dat deze standaard de fade waarde op 50% zet.
Dat vind ik wel handig zodat deze duidelijk als onderleggers zichtbaar zijn.
Aangezien fade geen property is die via lisp handig te bewerken is doe ik het met een command call.
Ik vroeg me toch even af of iemand een handige manier/betere manier zou kunnen bedenken..


(defun C:IM ()
  (progn
    (initdia)
   ; (updatexrefpath)
    (command ".classicimage" pause pause)
    (command "-imageadjust" "l" "" "fade" "50" "")
    (command "draworder" "l" "" "b")
))

9
Autolisp / make layers unpurge
« Gepost op: ma 04 07 2016, 22:19:53 »
Ik wil een aantal lagen (genaamd "1"  "2"  "3") unpurgeble maken.
Maar ik kom er niet uit hoe ik deze lijst prts aanpas
Ik zou het wel erg handig vinden om mijn vaste lagen te kunnen vasthouden..
BVD

(setq ptrs (cons (cons 340 (tblobjname "LAYER" name)) ptrs))
hoe maak ik een goede layer lijst aan voor prts?

Merci beaucoup



;; gc:GetExtDict (gile)
;; Retourne le dictionnaire d'extension de l'entité (ou nil)
;;
;; Argument : ent (ENAME)
(defun gc:GetExtDict (ent)
  (cdadr (member '(102 . "{ACAD_XDICTIONARY") (entget ent)))
)

;; gc:GetOrCreateExtDict (gile)
;; Retourne le dictionnaire d'extension de l'entité
;; Le dictionnaire est créé s'il n'existe pas
;;
;; Argument : ent (ENAME)
(defun gc:GetOrCreateExtDict (ent / dict)
  (cond
    ((cdadr (member '(102 . "{ACAD_XDICTIONARY") (entget ent))))
    ((setq dict (entmakex
  '((0 . "DICTIONARY") (100 . "AcDbDictionary"))
)
     )
     (entmod (append (entget ent)
     (list '(102 . "{ACAD_XDICTIONARY")
   (cons 360 dict)
   '(102 . "}")
     )
     )
     )
     dict
    )
  )
)

;; gc:SetXrecData
;; Retourne le ENAME du xrecord auquel sont affectées mes données
;;
;; Arguments
;; dict : ENAME du dictionnaire parent
;; key : nom du Xrecord
;; data : liste de paires pointées contenant les données
(defun gc:SetXrecData (dict key data / xrec)
  (if (snvalid key)
    (progn
      (and (setq xrec (dictsearch dict key))
   (entdel (cdr (assoc -1 xrec)))
      )
      (dictadd
dict
key
(entmakex
  (append
    (list '(0 . "XRECORD")
  '(100 . "AcDbXrecord")
    )
    data
  )
)
      )
    )
  )
)

;;----------------------------------------------------;;
;;                      Commands                      ;;
;;----------------------------------------------------;;

;; SETALLLAYERSUNPURGEABLE command to set all layers unpurgeable
(defun c:Unpurg (/ lay name ptrs tbl)
  (while (setq lay (tblnext "LAYER" (not lay)))
    (if (/= (setq name (cdr (assoc 2 lay))) "0")
      (setq ptrs (cons (cons 340 (tblobjname "LAYER" name)) ptrs))
    )
  )
  (setq tbl (cdr (assoc 330 (entget (tblobjname "LAYER" "0")))))
  (gc:SetXrecData
    (gc:GetOrCreateExtDict tbl)
    "LAYER_UNPURGE"
    ptrs
  )
  (princ)
)

;; RESETALLLAYERSPURGEABLE command to reset all layers purgeable
(defun c:Repurg(/ tbl xdict)
  (setq tbl (cdr (assoc 330 (entget (tblobjname "LAYER" "0")))))
  (and
    (setq xdict (gc:GetExtDict tbl))
    (dictremove xdict "LAYER_UNPURGE")
  )
  (princ)
)


10
Autolisp / Multiselect in LM:Entity->PointList (Opgelost)
« Gepost op: di 28 06 2016, 22:06:07 »
Hoi

Is er iemand handig met lisp en repeat and while loops?
Waar ik naar op zoek ben is een aangepaste routine van Lee Mac Entity to Point List routine

https://www.youtube.com/watch?v=M_mminy4FMg

Bij 1m:05s selecteer ik deze een voor een maar daar wil een multi select ..

(defun c:test ( / ent )
    (if (setq ent (car (entsel))).         ;;<=ssget met while repeat loop hier =>
        (foreach x (LM:Entity->PointList ent)
            (entmake (list '(0 . "POINT") (cons 10 x)))
        )
    )
    (princ)
)
(vl-load-com) (princ)

11
AutoCAD tips / Exnest en fix tut. via youtube
« Gepost op: zo 12 07 2015, 08:56:36 »

 Ik heb een 'how to' opgenomen hoe je een DWG model met veel blockdefinties kunt opwerken tot iets meer werkbaars.
 Eerst de nesting exploderen, daarna de blocks transparent maken. Hoeft niet lang te duren.


EXNEST vind je hier www.cadtutor.net/forum/showthread.php?72...e-nested-blocks-only
FIX vind je hier gilecad.azurewebsites.net/LISP.html

https://www.youtube.com/watch?v=CwC92xb1GiM
[/quote]

12
VBA / probleem 2003 / 2010 compabiliteit
« Gepost op: di 24 09 2013, 12:42:14 »
Ik heb ooit een Excel gemaakt of verbasteld van een ander lid die scripts kom maken. Was wel handig. Nu is het probleem dat er een oude code in zit, Application.FileSearch, die niet meer ondersteund wordt. Kan iemand mij hierbij helpen. Ik zou niet weten hoe je dit moet herschrijven.
Muchias gracias

13
Algemeen / ervaring NLCS
« Gepost op: di 29 12 2009, 22:02:04 »
Ik ben benieuwd wat de meningen zijn over de nieuwe cadstandaard nlcs (www.nlcs-gww.nl)
Zijn er mensen die ervaring hebben opgedaan met de nieuwe werkwijze?

14
Autolisp / Super tip : Dynamisch block leest hoogte uit !
« Gepost op: wo 18 02 2009, 11:14:28 »
Beste (HofCAD),

Terecht verdient dit tooltje een dikke 9 uit 10 !!
Bijgevoed een manier om de hoogte uit te lezen en als attributen in een dynamisch te plaatsen.
Op zich werkt deze goed maar hij heeft een kleine tekortkoming.
Het leest nu (alleen) de harde waarde van insertionpoint (WCS).
Je moet dus altijd alles op y=0 tekenen, doet niet iedereen.
Kun jij dit veranderen dat hij dit punt omzet /uitleest van de locaal ingestelde Y waarde van het user definied assenstelsel.

De werkwijze is dan als volgt. UCS instellen op NAP lijn=> update blocks
Ik hoop dat jouw dit lukt, anders iemand anders ?..

Bij voorbaat bedankt voor het meekijken
Hans Lammerts

achtergrond tool
http://www.dailyautocad.com/autocad/autolisp-method-of-giving-elevation-symbols-in-autocad/

omzetten inspt naar insptucs met (trans .. functie) lukt me niet..

.........
..........
              InsPt (vla-get-InsertionPoint obj)
            )

            (setq InsPt
              (vlax-safearray->list (vlax-variant-value Inspt))
...........
...........

15
AutoCAD tips / Scriptpro
« Gepost op: ma 16 06 2008, 21:19:36 »
Is er nederlandse beschrijving van Scriptpro beschikbaar..?
Iemand iets moois gedocumenteerd?
Het is wel een handig programmatje maar helaas niet erg bekend.
Met goeie scripts kun je geweldig veel tijd besparen !
http://autodesk.blogs.com/between_the_lines/2007/04/download_new_sc.html

Pagina's: [1] 2