;;; Programm zum umwandeln von vorhandenen 
;;; 3ds-Dateien in das VRML-Format
;;; Bitte immer eine leere Zeichnung verwenden
(DEFUN c:3ds2VRML (/         *acad*    *acDocs*  *actDoc*  objects
                   vrmlDatNam          vrmlDat   outObjects
                   no3DObjects         oType     i         j
                   k         l         m         n         oName
                   outObs    pnetze    pnetz     pnCoords  pnCntFcs
                   pnCntPts  pnPnts    flaechen  normalen  colors
                   saList    pmin      pmax      _3DFls    pkt
                   flaeche   coords    pkts      elFlaeche avefinish
                   matBlock  material  color     p1        p2
                   p3        nor       Lichter   lJN       anzLight
                   Lights    lightType posLight  tarLight  dirLight
                   gzipBatName         gzipBat   *views*   ze
                   scale     elNetz    face      flPkt     a
                   b         c         ausgabe
                  )
  (IF (NOT VLA-ADD)
    (VL-LOAD-COM)
  )
  (SETQ *acad*   (VLAX-GET-ACAD-OBJECT)
        *acDocs* (VLA-GET-DOCUMENTS *acad*)
        *actDoc* (VLA-GET-ACTIVEDOCUMENT *acad*)
        *views*  (VLA-GET-VIEWS *actDoc*)
  )

  ;;; 3DSOut geladen?
  (IF (NOT C:3DSOUT)
    (ARXLOAD "acrender.arx")
  )
  ;;; Geometrischer Rechner geladen?
  (IF (NOT C:CAL)
    (ARXLOAD "geomcal.arx")
  )
  ;; Zeichnungseinheit zur Skalierung der VRML-Datei
  (INITGET "MIllimeter Zentimeter Dezimeter MEter")
  (SETQ ze (GETKWORD "\nZeichnungseinheit: [MIllimeter/Zentimeter/Dezimeter/MEter] "))
  (SETQ scale (COND
                ((= ze "MIllimeter") " 0.001 0.001 -0.001 ")
                ((= ze "Zentimeter") " 0.01 0.01 -0.01 ")
                ((= ze "Dezimeter") " 0.1 0.1 -0.1 ")
                ((= ze "MEter") " 1.00 1.00 -1.00 ")
              )
  )
  (COMMAND "_undo" "_Begin")
  (SETVAR "orthomode" 0)
  (SETVAR "osmode" 0)
  (SETVAR "regenmode" 1)
  
  (COMMAND "ausschnt" "_save" "vrml")
  (SETQ _3dsInDatNam
                     (GETFILED "3ds-Datei auswählen"
                               (GETVAR "DWGPREFIX")
                               "3ds"
                               8
                     )
        vrmlDatNam
                     (VL-STRING-SUBST ".wrl" ".3ds" _3dsInDatNam)
  )
  ;;; Ausgabe Flächen, Linien oder Beides?
  (INITGET "Flaechen Linien Beides")
  (SETQ
    ausgabe (GETKWORD
              "\nWas soll ausgegeben werden? [Flaechen/Linien/Beides] "
            )
    vrmlDatNam (vl-string-subst (strcat "_" ausgabe ".wrl") ".wrl" vrmlDatNam)
  )
  (SETQ vrmlDat (OPEN vrmlDatNam "w"))
  (WRITE-LINE "#VRML V2.0 utf8" vrmlDat)
  (SETVAR "isolines" 16)
  (SETVAR "ucsfollow" 0)
  (COMMAND "_ucs" "")

  (C:3DSIN 0 0 3 _3dsInDatNam)
  (COMMAND "Drsicht" "Welt")
  (SETQ pnetze (SSGET "X"
                      '((0 . "POLYLINE")
                        (8 . "AVLAYER")
                        (100 . "AcDbPolyFaceMesh")
                       )
               )
        i      0
  )
  (IF pnetze
    (PROGN
      (REPEAT (SSLENGTH pnetze)         ; Liste mit importierten PolyNetzen
        (SETQ pnetz     (VLAX-ENAME->VLA-OBJECT
                          (SETQ pName (SSNAME pnetze i))
                        )
              pnCoords  (VLAX-SAFEARRAY->LIST
                          (VLAX-VARIANT-VALUE
                            (VLA-GET-COORDINATES pnetz)
                          )
                        )
              pnCntFcs  (VLA-GET-NUMBEROFFACES pnetz)     ; Anzahl der PNetz-Flächen
              pnCntpts  (VLA-GET-NUMBEROFVERTICES pnetz)  ; Anzahl der PNetz-Punkte
              pnPnts    nil
              flaechen  nil
              normalen  nil
              colors    nil
              elNetz    (ENTGET pName '("*"))
              ;; Material ermitteln
              avefinish (ASSOC "AVE_FINISH"
                               (MEMBER (NTH 1 (ASSOC -3 elNetz))
                                       (ASSOC -3 elNetz)
                               )
                        )
              avefinish (MEMBER (NTH 1 avefinish) avefinish)
              matBlock  (ENTGET (HANDENT (CDR (ASSOC 1005 avefinish)))
                                '("*")
                        )
              material  (C:RMAT
                          "L"
                          (CDR
                            (ASSOC
                              1000
                              (CDR (ASSOC "AVE_MATERIAL"
                                          (CDR (ASSOC -3 matBlock))
                                   )
                              )
                            )
                          )
                        )
              color     (NTH 2 material)
        )
        ;; Punkte ermitteln
        (SETQ l 0)
        (REPEAT pnCntPts
          (SETQ pkt    (LIST (NTH l pnCoords)
                             (NTH (1+ l) pnCoords)
                             (NTH (+ 2 l) pnCoords)
                       )
                pnPnts (APPEND pnPnts (LIST pkt))
                l      (+ 3 l)
          )
        )
        ;; Flächen ermitteln
        (SETQ pktName (ENTNEXT pName))
        (REPEAT pnCntpts
          (SETQ pktName (ENTNEXT pktName))
        ) ; ende Punktdefinitionen
        (SETQ j 0)
        ; jetzt kommen die Flächendefinitionen
        (REPEAT pnCntFcs
          (SETQ elFlaeche (ENTGET pktname)
                face      (MEMBER (ASSOC 71 elFlaeche) elFlaeche) ; Die FlächenPunkt sind in 71,72,73 und
          )                                                       ; 71,72,73 und 74 gespeichert
          (SETQ flPkte (MAPCAR '(LAMBDA (pkt)
                                  (IF (/= (CDR pkt) 0)
                                    (1- (CDR pkt))
                                  )
                                )
                               face
                       )
          ) ; => z.B. (1 2 3 nil)
          (SETQ p1 (CAR flPkte)
                a  (NTH p1 pnPnts)
                p2 (CADR flPkte)
                b  (NTH p2 pnPnts)
                p3 (CADDR flPkte)
                c  (NTH p3 pnPnts)
          )
          (SETQ nor (C:CAL "nor(a,b,c)")) ; Berechnung der Flächennormalen (wird noch nicht verwendet)
;;; Flaechen = ((1  (pktnrCoord1 pktnrCoord2 pktnrCoord3) normale (R G B))
;;;             (2  (pktnrCoord1 pktnrCoord2 pktnrCoord3) normale (R G B))
;;;            )
          (SETQ flaechen (APPEND
                           flaechen
                           (LIST (CONS j
                                       (LIST (LIST p1 p2 p3)
                                             nor
                                             color
                                       )
                                 )
                           )
                         )
                normalen (APPEND normalen (LIST nor))
                colors   (APPEND colors (LIST color))
                j        (1+ j)
                pktName  (ENTNEXT pktName)
          )
        )

;;; ***************************
;;; VRML-Ausgabe pro Körper   *
;;;                           *
;;;****************************

;;; ToDo
        (IF (OR (= ausgabe "Flaechen") (= ausgabe "Beides"))
          (vrmlout vrmlDat "Face" pnPnts flaechen normalen colors scale)
        )
        (IF (OR (= ausgabe "Linien") (= ausgabe "Beides"))
          (vrmlout vrmlDat "Line" pnPnts flaechen normalen colors scale)
        )
        (COMMAND "_erase" pName "")


        (SETQ i (1+ i))
      )
      (PROMPT
        "\nJetzt müssen noch die Lichter definiert werden."
      )
      (SETQ Lichter (C:LIGHT "L")
            lJN     "Nein"
      )
      (IF Lichter
        (PROGN
          (INITGET 1 "Ja Nein")
          (SETQ lJN
                 (GETKWORD
                   "\nSollen die vorhandenen Lichter verwendet werden? [Ja/Nein] "
                 )
          )
        )
      )
      (IF (OR (NOT lJN) (= "Ja" lJN))
        (PROGN                          ; vorhandene Lichter verwenden
          (ALERT "Diese Funktion ist leider noch nicht implementiert")
        )
        (PROGN                          ; neue Lichter definieren
          (SETQ anzLight (GETINT "\nAnzahl Lichter: ")
                Lights   nil
                o        1
          )

          (REPEAT anzLight
            (INITGET 1 "Punkt Directional Spot")
            (SETQ lightType
                   (GETKWORD
                     "\nLichttyp angeben: [Punkt/Directional/Spot] "
                   )
            )

            (COND
              ((= lightType "Punkt")
               (PROGN
                 (WRITE-LINE
                   "PointLight {"
                   vrmlDat
                 )
                 (SETQ posLight
                        (GETPOINT
                          (STRCAT "\nPosition PunktLicht Nr. " (ITOA o) ": ")
                        )
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  location "
                     (RTOS (* (ATOF scale) (NTH 0 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 posLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE "  radius 1.0" vrmlDat)
                 (WRITE-LINE
                   "  attenuation 1.0 0.0 0.0\n}"
                   vrmlDat
                 )
               )
              )
              ((= lightType "Directional")
               (PROGN
                 (WRITE-LINE
                   "DirectionalLight { "
                   vrmlDat
                 )
                 (SETQ posLight
                                (GETPOINT
                                  (STRCAT
                                    "\nPosition DirectionalLicht (z.B. Sonne) Nr. "
                                    (ITOA o)
                                    ": "
                                  )
                                )
                       tarLight
                                (GETPOINT
                                  posLight
                                  "\nZielPunkt des DirectionalLichtes: "
                                )
                       dirLight (C:CAL "vec1(posLight,tarLight)")
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  direction "
                     (RTOS (* (ATOF scale) (NTH 0 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 dirLight)) 2 3)
                     "\n}"
                   )
                   vrmlDat
                 )
               )
              )
              ((= lightType "Spot")
               (PROGN
                 (WRITE-LINE
                   "SpotLight { "
                   vrmlDat
                 )
                 (SETQ posLight
                                (GETPOINT
                                  (STRCAT "\nPosition SpotLicht (Scheinwerfer) Nr. "
                                          (ITOA o)
                                          ": "
                                  )
                                )
                       tarLight
                                (GETPOINT
                                  posLight
                                  "\nZielPunkt des SpotLicht "
                                )
                       dirLight (C:CAL "vec1(posLight,tarLight)")
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  location "
                     (RTOS (* (ATOF scale) (NTH 0 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 posLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE
                   (STRCAT
                     "  direction "
                     (RTOS (* (ATOF scale) (NTH 0 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 dirLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE "  beamWidth 1.57" vrmlDat)
                 (WRITE-LINE "  cutOffAngle 0.875\n}" vrmlDat)
               )
              )
            )
            (SETQ o (1+ o))
          )
        )
      )
;;;      (SETQ
;;;        anzCamera (GETINT "\nAnzahl Kameras: ")
;;;        Cameras   nil
;;;        o         1
;;;      )
      (SETQ vrmlDat (CLOSE vrmlDat))
      (INITGET "Ja Nein")
      (SETQ jn
             (GETKWORD "\nSoll die VRML-Datei gepackt werden? [Ja/Nein] "
             )
      )
      (IF (= jn "Ja")
        (PROGN
          ; Batch-Datei zur Komprimierung der WRL-Datei erzeugen
          (SETQ gzipBatName (STRCAT (GETENV "TEMP") "\\gzipBat.cmd"))
          (SETQ gzipBat (OPEN gzipBatName "w"))
          (WRITE-LINE "@echo off" gzipBat)
          (WRITE-LINE "echo Die Datei wird komprimiert" gzipBat)
          (WRITE-LINE "dir %1" gzipBat)
          (WRITE-LINE
            (STRCAT
              (FINDFILE "gzip.exe")
              " -9 \"%~1\""
            )
            gzipBat
          )
          (WRITE-LINE "ren \"%~1.gz\" \"%~n1.wrl\"" gzipBat)
          (WRITE-LINE "dir %1" gzipBat)
          (WRITE-LINE "pause" gzipBat)
          (SETQ gzipBat (CLOSE gzipBat))
          ; Datei komprimieren
          (COMMAND "shell" (STRCAT gzipBatName " \"" vrmlDatNam "\""))
        )
      )
      (COMMAND "ausschnt" "holen" "vrml")
      (COMMAND "ausschnt" "löschen" "vrml")
      (COMMAND "_undo" "_end")
    )
  )
)
;;; Programm zum umwandeln von 3D-Elementen 
;;; aus der aktuellen Zeichnung in das VRML-Format

(DEFUN c:vrmlOut (/         *acad*    *acDocs*  *actDoc*  objects
                  vrmlDatNam          vrmlDat   outObjects
                  no3DObjects         oType     i         j
                  k         l         m         n         oName
                  outObs    pnetze    pnetz     pnCoords  pnCntFcs
                  pnCntPts  pnPnts    flaechen  normalen  colors
                  saList    pmin      pmax      _3DFls    pkt
                  flaeche   coords    pkts      elFlaeche avefinish
                  matBlock  material  color     p1        p2
                  p3        nor       Lichter   lJN       anzLight
                  Lights    lightType posLight  tarLight  dirLight
                  gzipBatName         gzipBat   *views*   ze
                  scale     elNetz    face      flPkt     a
                  b         c         ausgabe   views
                 )
  (IF (NOT VLA-ADD)
    (VL-LOAD-COM)
  )
  (SETQ *acad*   (VLAX-GET-ACAD-OBJECT)
        *acDocs* (VLA-GET-DOCUMENTS *acad*)
        *actDoc* (VLA-GET-ACTIVEDOCUMENT *acad*)
        *views*  (VLA-GET-VIEWS *actDoc*)
  )

  (IF (NOT C:3DSOUT)
    (ARXLOAD "acrender.arx")
  )
  (IF (NOT C:CAL)
    (ARXLOAD "geomcal.arx")
  )
 ;; Zeichnungseinheit zur Skalierung der VRML-Datei
  (INITGET "MIllimeter Zentimeter Dezimeter MEter")
  (SETQ ze (GETKWORD "\nZeichnungseinheit: [MIllimeter/Zentimeter/Dezimeter/MEter] "))
  (SETQ scale (COND
                ((= ze "MIllimeter") " 0.001 0.001 -0.001 ")
                ((= ze "Zentimeter") " 0.01 0.01 -0.01 ")
                ((= ze "Dezimeter") " 0.1 0.1 -0.1 ")
                ((= ze "MEter") " 1.00 1.00 -1.00 ")
              )
  )
  (PROMPT "\nObjekte wählen: ")
  (SETQ objects (SSGET '((-4 . "<OR")
                         (0 . "3DFACE")
                         (100 . "AcDbPolyFaceMesh")
                         (0 . "REGION")
                         (0 . "BODY")
                                        ;(0 . "LINE")
                                        ;(0 . "TEXT")
                                        ;(0 . "TRACE")
                                        ;(0 . "ARC")
                         (0 . "3DSOLID")
                                        ;(0 . "POINT")
                         (-4 . "OR>")
                        )
                )
  )
  (IF objects
    (PROGN
      (COMMAND "_undo" "_Begin")
      (SETVAR "orthomode" 0)
      (SETVAR "osmode" 0)
      (SETQ vctr  (GETVAR "viewctr")
            vdir  (GETVAR "viewdir")
            vsize (GETVAR "viewsize")
      )
      (COMMAND "ausschnt" "_save" "vrml")
      (SETQ vrmlDatNam
             (GETFILED "VRML-Ausgabedatei erzeugen"
                       (GETVAR "DWGPREFIX")
                       "wrl"
                       1
             )
            *views*  (VLA-GET-VIEWS *actDoc*)
      )
      (setq views nil)
      (VLAX-FOR item *views*
        (setq views(append views (list (vla-get-name item))))
      )
      
      (INITGET "Flaechen Linien Beides")
      (SETQ ausgabe
             (GETKWORD
               "\nWas soll ausgegeben werden? [Flaechen/Linien/Beides] "
             )
            vrmlDatNam (vl-string-subst (strcat "_" ausgabe ".wrl") ".wrl" vrmlDatNam)
      )
      (SETQ outObjects  (SSADD)
            no3DObjects (SSADD)
      )
      (SETVAR "ucsfollow" 0)
      (COMMAND "_ucs" "")
      (COMMAND "Drsicht" "Welt")

      (SETQ i 0)
      (REPEAT (SSLENGTH objects)
        (SETQ oType
               (CDR (ASSOC 0 (setq oEListe(ENTGET (SETQ oName (SSNAME objects i))))))
        )
        (COND
          ((= oType "3DFACE")
           (SETQ outObjects (SSADD oName outObjects))
          )
          ((= oType "REGION")
           (SETQ outObjects (SSADD oName outObjects))
          )
          ((= oType "BODY")
           (SETQ outObjects (SSADD oName outObjects))
          )
          ((= oType "3DSOLID")
           (SETQ outObjects (SSADD oName outObjects))
          )
          ((= (vla-get-objectname (vlax-ename->vla-object oName))  "AcDbPolyFaceMesh")
           (SETQ outObjects (SSADD oName outObjects))
          )
          (T (SETQ no3DObjects (SSADD oName no3DObjects)))
        )
        (SETQ i (1+ i))
      )

      (SETQ _3dsout (STRCAT (GETENV "temp") "\\objecte.3ds"))
      (SETQ vrmlDat (OPEN vrmlDatNam "w"))
      (WRITE-LINE "#VRML V2.0 utf8" vrmlDat)
      (SETVAR "isolines" 16)
        
      (SETQ n 0)
      (REPEAT (SSLENGTH outObjects)
        (IF (FINDFILE _3dsout)
          (VL-FILE-DELETE _3dsout)
        )
        (SETQ outObs (SSADD (SSNAME outObjects n)))
        (C:3DSOUT outObs 0 0 30 0.001 _3dsout)
        (VLAX-FOR item (VLA-GET-VIEWS *actDoc*)
          (if (not (member (vla-get-name item) views))
            (VLA-DELETE item)
          )
        )
        (C:3DSIN 0 0 3 _3dsout)
        (VLAX-FOR item (VLA-GET-VIEWS *actDoc*)
          (if (not (member (vla-get-name item) views))
            (VLA-DELETE item)
          )
        )
        (SETQ pnetze (SSGET "X"
                            '((0 . "POLYLINE")
                              (8 . "AVLAYER")
                              (100 . "AcDbPolyFaceMesh")
                             )
                     )
              i      0
        )
        (IF pnetze
          (PROGN
            (repeat (sslength outObs)
              (ssdel (ssname outObs i) pnetze)
              (setq i(1+ i))
            )
            (setq i 0)
            (REPEAT (SSLENGTH pnetze)   ; Liste mit importierten PolyNetzen
              (SETQ pnetz     (VLAX-ENAME->VLA-OBJECT
                                (SETQ pName (SSNAME pnetze i))
                              )
                    pnCoords  (VLAX-SAFEARRAY->LIST
                                (VLAX-VARIANT-VALUE
                                  (VLA-GET-COORDINATES pnetz)
                                )
                              )
                    pnCntFcs  (VLA-GET-NUMBEROFFACES pnetz)
                    pnCntpts  (VLA-GET-NUMBEROFVERTICES pnetz)
                    pnPnts    nil
                    flaechen  nil
                    normalen  nil
                    colors    nil
                    saList    nil
                    elNetz    (ENTGET pName '("*"))
                    ;; Material ermitteln
                    avefinish (ASSOC "AVE_FINISH"
                                     (MEMBER (NTH 1 (ASSOC -3 elNetz))
                                             (ASSOC -3 elNetz)
                                     )
                              )
                    avefinish (MEMBER (NTH 1 avefinish) avefinish)
                    matBlock  (ENTGET (HANDENT (CDR (ASSOC 1005 avefinish)))
                                      '("*")
                              )
                    material  (C:RMAT
                                "L"
                                (CDR
                                  (ASSOC
                                    1000
                                    (CDR (ASSOC "AVE_MATERIAL"
                                                (CDR (ASSOC -3 matBlock))
                                         )
                                    )
                                  )
                                )
                              )
                    color     (NTH 2 material)
              )
              ;; Punkte ermitteln
              (SETQ l 0)
              (REPEAT pnCntPts
                (SETQ pkt    (LIST (NTH l pnCoords)
                                   (NTH (1+ l) pnCoords)
                                   (NTH (+ 2 l) pnCoords)
                             )
                      pnPnts (APPEND pnPnts (LIST pkt))
                      l      (+ 3 l)
                )
              )
              ;; Flächen ermitteln
              (SETQ pktName (ENTNEXT pName))
              (REPEAT pnCntpts
                (SETQ pktName (ENTNEXT pktName))
              )
              (SETQ j 0)
              (REPEAT pnCntFcs
                (SETQ elFlaeche (ENTGET pktname)
                      face      (MEMBER (ASSOC 71 elFlaeche) elFlaeche)
                )
                (SETQ flPkte (MAPCAR '(LAMBDA (pkt)
                                        (IF (/= (CDR pkt) 0)
                                          (1- (CDR pkt))
                                        )
                                      )
                                     face
                             )
                )
                (SETQ p1 (CAR flPkte)
                      a  (NTH p1 pnPnts)
                      p2 (CADR flPkte)
                      b  (NTH p2 pnPnts)
                      p3 (CADDR flPkte)
                      c  (NTH p3 pnPnts)
                )
                (SETQ nor (C:CAL "nor(a,b,c)"))
;;; Flaechen = ((1  (pktnrCoord1 pktnrCoord2 pktnrCoord3) normale (R G B))
;;;             (2  (pktnrCoord1 pktnrCoord2 pktnrCoord3) normale (R G B))
;;;            )
                (SETQ flaechen (APPEND
                                 flaechen
                                 (LIST (CONS j
                                             (LIST (LIST p1 p2 p3)
                                                   nor
                                                   color
                                             )
                                       )
                                 )
                               )
                      normalen (APPEND normalen (LIST nor))
                      colors   (APPEND colors (LIST color))
                      j        (1+ j)
                      pktName  (ENTNEXT pktName)
                )
              )

;;; ***************************
;;; VRML-Ausgabe pro Körper   *
;;;                           *
;;;****************************

;;; ToDo
              (IF (OR (= ausgabe "Flaechen") (= ausgabe "Beides"))
                (vrmlout vrmlDat "Face" pnPnts flaechen normalen colors
                         scale)
              )
              (IF (OR (= ausgabe "Linien") (= ausgabe "Beides"))
                (vrmlout vrmlDat "Line" pnPnts flaechen normalen colors
                         scale)
              )
              (COMMAND "_erase" pName "")


              (SETQ i (1+ i))
            )
          )
        )

        (SETQ n (1+ n))
      )
      (PROMPT
        "\nJetzt müssen noch die Lichter definiert werden."
      )
      (SETQ Lichter (C:LIGHT "L")
            lJN     "Nein"
      )
      (IF Lichter
        (PROGN
          (INITGET 1 "Ja Nein")
          (SETQ lJN
                 (GETKWORD
                   "\nSollen die vorhandenen Lichter verwendet werden? [Ja/Nein] "
                 )
          )
        )
      )
      (IF (OR (NOT lJN) (= "Ja" lJN))
        (PROGN                          ; vorhandene Lichter verwenden
          (ALERT "Diese Funktion ist leider noch nicht implementiert")
        )
        (PROGN                          ; neue Lichter definieren
          (SETQ anzLight (GETINT "\nAnzahl Lichter: ")
                Lights   nil
                o        1
          )

          (REPEAT anzLight
            (INITGET 1 "Punkt Directional Spot")
            (SETQ lightType
                   (GETKWORD
                     "\nLichttyp angeben: [Punkt/Directional/Spot] "
                   )
            )

            (COND
              ((= lightType "Punkt")
               (PROGN
                 (WRITE-LINE
                   "PointLight {"
                   vrmlDat
                 )
                 (SETQ posLight
                        (GETPOINT
                          (STRCAT "\nPosition PunktLicht Nr. " (ITOA o) ": ")
                        )
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  location "
                     (RTOS (* (ATOF scale) (NTH 0 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 posLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE "  radius 1.0" vrmlDat)
                 (WRITE-LINE
                   "  attenuation 1.0 0.0 0.0\n}"
                   vrmlDat
                 )
               )
              )
              ((= lightType "Directional")
               (PROGN
                 (WRITE-LINE
                   "DirectionalLight { "
                   vrmlDat
                 )
                 (SETQ posLight
                                (GETPOINT
                                  (STRCAT
                                    "\nPosition DirectionalLicht (z.B. Sonne) Nr. "
                                    (ITOA o)
                                    ": "
                                  )
                                )
                       tarLight
                                (GETPOINT
                                  posLight
                                  "\nZielPunkt des DirectionalLichtes: "
                                )
                       dirLight (C:CAL "vec1(posLight,tarLight)")
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  direction "
                     (RTOS (* (ATOF scale) (NTH 0 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 dirLight)) 2 3)
                     "\n}"
                   )
                   vrmlDat
                 )
               )
              )
              ((= lightType "Spot")
               (PROGN
                 (WRITE-LINE
                   "SpotLight { "
                   vrmlDat
                 )
                 (SETQ posLight
                                (GETPOINT
                                  (STRCAT "\nPosition SpotLicht (Scheinwerfer) Nr. "
                                          (ITOA o)
                                          ": "
                                  )
                                )
                       tarLight
                                (GETPOINT
                                  posLight
                                  "\nZielPunkt des SpotLicht "
                                )
                       dirLight (C:CAL "vec1(posLight,tarLight)")
                 )
                 (WRITE-LINE "  intensity 1.0" vrmlDat)
                 (WRITE-LINE "  ambientIntensity 0.85" vrmlDat)
                 (WRITE-LINE "  color 1.0 1.0 1.0" vrmlDat)
                 (WRITE-LINE
                   (STRCAT
                     "  location "
                     (RTOS (* (ATOF scale) (NTH 0 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 posLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 posLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE
                   (STRCAT
                     "  direction "
                     (RTOS (* (ATOF scale) (NTH 0 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) (NTH 2 dirLight)) 2 3)
                     " "
                     (RTOS (* (ATOF scale) -1 (NTH 1 dirLight)) 2 3)
                   )
                   vrmlDat
                 )
                 (WRITE-LINE "  beamWidth 1.57" vrmlDat)
                 (WRITE-LINE "  cutOffAngle 0.875\n}" vrmlDat)
               )
              )
            )
            (SETQ o (1+ o))
          )
        )
      )
;;;      (SETQ
;;;        anzCamera (GETINT "\nAnzahl Kameras: ")
;;;        Cameras   nil
;;;        o         1
;;;      )
      (SETQ vrmlDat (CLOSE vrmlDat))
      (INITGET "Ja Nein")
      (SETQ jn
             (GETKWORD "\nSoll die VRML-Datei gepackt werden? [Ja/Nein] "
             )
      )
      (IF (= jn "Ja")
        (PROGN
          (SETQ gzipBatName (STRCAT (GETENV "TEMP") "\\gzipBat.cmd"))
          (SETQ gzipBat (OPEN gzipBatName "w"))
          (WRITE-LINE "@echo off" gzipBat)
          (WRITE-LINE "echo Die Datei wird komprimiert" gzipBat)
          (WRITE-LINE "dir %1" gzipBat)
          (WRITE-LINE
            (STRCAT
              (FINDFILE "gzip.exe")
              " -9 \"%~1\""
            )
            gzipBat
          )
          (WRITE-LINE "ren \"%~1.gz\" \"%~n1.wrl\"" gzipBat)
          (WRITE-LINE "dir %1" gzipBat)
          (WRITE-LINE "pause" gzipBat)
          (SETQ gzipBat (CLOSE gzipBat))
          (COMMAND "shell" (STRCAT gzipBatName " \"" vrmlDatNam "\""))
        )
      )
      (COMMAND "ausschnt" "holen" "vrml")
      (COMMAND "ausschnt" "löschen" "vrml")
      (COMMAND "_undo" "_end")
    )
  )
  (PRIN1)
)


(DEFUN vrmlout
       (datei Art shpPts fls nors cols scale / i farbe pt fl pts)
;;; ToDo
  (WRITE-LINE "Transform {" datei)
  (WRITE-LINE
    "  translation 0.0 0.0 0.0 "
    datei
  )
  (WRITE-LINE (STRCAT "  scale " scale) datei)
  (WRITE-LINE "  children Shape {" datei)

  (WRITE-LINE
    "      appearance Appearance { "
    datei
  )

  (WRITE-LINE "        material Material {" datei)
  (WRITE-LINE
    (STRCAT "          diffuseColor "
            (RTOS (NTH 0 (SETQ farbe (NTH 0 cols))) 2 2)
            " "
            (RTOS (NTH 1 farbe) 2 2)
            " "
            (RTOS (NTH 2 farbe) 2 2)
            "\n"
            "        } "
    )
    datei
  )

  (WRITE-LINE
    "      } "
    datei
  )

  (WRITE-LINE
    (STRCAT "      geometry Indexed" Art "Set {")
    datei
  )
;;;  (IF (= Art "Face")
;;;    (WRITE-LINE "        solid TRUE" datei)
;;;  )
  (WRITE-LINE
    (STRCAT
      "        coord Coordinate{\n"
      "        point["
    )
    datei
  )
  (SETQ i 0)
  (REPEAT (LENGTH shpPts)
    (SETQ pt (NTH i shpPts))
    (WRITE-LINE
      (STRCAT
        "          "
        (RTOS (NTH 0 pt) 2 3)
        " "
        (RTOS (NTH 2 pt) 2 3)
        " "
        (RTOS (NTH 1 pt) 2 3)
        (COND ((< i (1- (LENGTH shpPts))) ",")
              (T "]")
        )
      )
      datei
    )
    (SETQ i (1+ i))
  )
  (WRITE-LINE "        }" datei)
  (WRITE-LINE "        coordIndex [" datei)
  (SETQ i 0)
  (REPEAT (LENGTH fls)
    (SETQ fl  (CDR (ASSOC i fls))
          pts (CAR fl)
    )
    (IF (= Art "Line")
      (WRITE-LINE
        (STRCAT
          "          "
          (ITOA (NTH 0 pts))
          ","
          (ITOA (NTH 1 pts))
          ","
          (ITOA (NTH 2 pts))
          ","
          "-1"
          (COND ((< i (1- (LENGTH fls))) ",")
                (T "]")
          )
        )
        datei
      )
    )
    (IF (= Art "Face")
      (PROGN
        (WRITE-LINE
          (STRCAT
            "          "
            (ITOA (NTH 0 pts))
            ","
            (ITOA (NTH 1 pts))
            ","
            (ITOA (NTH 2 pts))
            ","
            "-1,"
          )
          datei
        )

        (WRITE-LINE
          (STRCAT
            "          "
            (ITOA (NTH 0 pts))
            ","
            (ITOA (NTH 2 pts))
            ","
            (ITOA (NTH 1 pts))
            ","
            "-1"
            (COND ((< i (1- (LENGTH fls))) ",")
                  (T "]")
            )
          )
          datei
        )
      )
    )
    (SETQ i (1+ i))
  )
  (WRITE-LINE "      } " datei)
  (WRITE-LINE
    "    }"
    datei
  )
  (WRITE-LINE "} \n\n" datei)
)

(DEFUN nth-xte (search liste / anz anztmp tmplst pos)
  (SETQ anz (LENGTH liste))
  (IF (SETQ tmplst (MEMBER search liste))
    (PROGN
      (SETQ anztmp (LENGTH tmplst)
            pos    (- anz anztmp)
      )
    )
    (SETQ pos nil)
  )
)
(PROMPT
  "\nAutoCAD 3D-Objekte nach VRML speichern mit VRMLout. "
)
(PROMPT
  "\n3ds-Datei in das VRML-Format konvertieren mit 3ds2VRML"
)
(PRIN1)