;;; MAGIC DWG2KML V1.0
;;; Standalone DWG -> KML / KMZ exporter
;;; Commands: DWG2KML / KML
;;; AutoCAD / Civil 3D / AutoCAD LT 2024+ with AutoLISP
(vl-load-com)

; MAGIC V6.55 - DWG -> KML / KMZ
; Command: DWG2KML
; Windows / AutoCAD-family / AutoCAD LT 2024+ (AutoLISP)
;
; Supports:
;   LINE, LWPOLYLINE, POLYLINE, POINT, INSERT, TEXT, MTEXT
; Coordinate systems:
;   NAD83 / UTM or WGS84 / UTM, zones 1-60, N/S hemisphere.
; KML coordinates are WGS84 longitude,latitude[,altitude].
; ============================================================

(if (null KML:*Zone*)       (setq KML:*Zone* 17))
(if (null KML:*Datum*)      (setq KML:*Datum* "NAD83"))
(if (null KML:*Hemisphere*) (setq KML:*Hemisphere* "N"))
(if (null KML:*Output*)     (setq KML:*Output* "KML"))
(if (null KML:*UseZ*)       (setq KML:*UseZ* nil))
(if (null KML:*OpenAfter*)  (setq KML:*OpenAfter* nil))

(defun KML:BoolStr (v)
  (if v "1" "0")
)

(defun KML:Trim (s)
  (if s (vl-string-trim " \t\r\n" s) "")
)

(defun KML:ReplaceAll (s old new / p)
  (if (null s) (setq s ""))
  (while (setq p (vl-string-search old s))
    (setq s (vl-string-subst new old s p)))
  s
)

(defun KML:XMLEscape (s)
  (setq s (if s s ""))
  (setq s (KML:ReplaceAll s "&" "&"))
  (setq s (KML:ReplaceAll s "<" "&lt;"))
  (setq s (KML:ReplaceAll s ">" "&gt;"))
  (setq s (KML:ReplaceAll s "\"" "&quot;"))
  (setq s (KML:ReplaceAll s "'" "&apos;"))
  s
)

(defun KML:Tan (x)
  (/ (sin x) (cos x))
)

(defun KML:Deg (rad)
  (* rad (/ 180.0 pi))
)

(defun KML:UTMToLonLat
  (easting northing zone hemisphere datum
   / a eccSq eccPrimeSq k0 x y longOrigin
     m mu e1 phi1 n1 t1 c1 r1 d lat lon
     s1 cphi denom)

  ; GRS80 for NAD83; WGS84 ellipsoid otherwise.
  (setq a 6378137.0
        eccSq
          (if (= (strcase datum) "NAD83")
            0.00669438002290
            0.00669437999014)
        k0 0.9996
        x (- easting 500000.0)
        y northing)

  (if (= (strcase hemisphere) "S")
    (setq y (- y 10000000.0)))

  (setq longOrigin (+ (* (- zone 1) 6.0) -180.0 3.0)
        eccPrimeSq (/ eccSq (- 1.0 eccSq))
        m (/ y k0)
        mu
          (/ m
             (* a
                (- 1.0
                   (/ eccSq 4.0)
                   (/ (* 3.0 eccSq eccSq) 64.0)
                   (/ (* 5.0 eccSq eccSq eccSq) 256.0))))
        e1
          (/ (- 1.0 (sqrt (- 1.0 eccSq)))
             (+ 1.0 (sqrt (- 1.0 eccSq))))
        phi1
          (+ mu
             (* (- (/ (* 3.0 e1) 2.0)
                   (/ (* 27.0 e1 e1 e1) 32.0))
                (sin (* 2.0 mu)))
             (* (- (/ (* 21.0 e1 e1) 16.0)
                   (/ (* 55.0 e1 e1 e1 e1) 32.0))
                (sin (* 4.0 mu)))
             (* (/ (* 151.0 e1 e1 e1) 96.0)
                (sin (* 6.0 mu))))
        s1 (sin phi1)
        cphi (cos phi1)
        denom (- 1.0 (* eccSq s1 s1))
        n1 (/ a (sqrt denom))
        t1 (* (KML:Tan phi1) (KML:Tan phi1))
        c1 (* eccPrimeSq cphi cphi)
        r1 (/ (* a (- 1.0 eccSq))
              (expt denom 1.5))
        d (/ x (* n1 k0)))

  (setq lat
    (- phi1
       (* (/ (* n1 (KML:Tan phi1)) r1)
          (- (/ (* d d) 2.0)
             (/ (* (+ 5.0
                      (* 3.0 t1)
                      (* 10.0 c1)
                      (* -4.0 c1 c1)
                      (* -9.0 eccPrimeSq))
                   (expt d 4.0))
                24.0)
             (* -1.0
                (/ (* (+ 61.0
                         (* 90.0 t1)
                         (* 298.0 c1)
                         (* 45.0 t1 t1)
                         (* -252.0 eccPrimeSq)
                         (* -3.0 c1 c1))
                      (expt d 6.0))
                   720.0))))))

  (setq lon
    (/ (- d
          (/ (* (+ 1.0 (* 2.0 t1) c1)
                (expt d 3.0))
             6.0)
          (* -1.0
             (/ (* (+ 5.0
                      (* -2.0 c1)
                      (* 28.0 t1)
                      (* -3.0 c1 c1)
                      (* 8.0 eccPrimeSq)
                      (* 24.0 t1 t1))
                   (expt d 5.0))
                120.0)))
       cphi))

  (list
    (+ longOrigin (KML:Deg lon))
    (KML:Deg lat))
)

(defun KML:Ensure3D (p defaultZ)
  (list
    (car p)
    (cadr p)
    (if (and KML:*UseZ* (caddr p))
      (caddr p)
      (if KML:*UseZ* defaultZ 0.0)))
)

(defun KML:ProjectPoint (p / ll)
  (setq ll
    (KML:UTMToLonLat
      (car p)
      (cadr p)
      KML:*Zone*
      KML:*Hemisphere*
      KML:*Datum*))
  (list
    (car ll)
    (cadr ll)
    (if KML:*UseZ* (caddr p) 0.0))
)

(defun KML:Fmt (x n)
  (rtos x 2 n)
)

(defun KML:CoordText (p)
  (strcat
    (KML:Fmt (car p) 8) ","
    (KML:Fmt (cadr p) 8) ","
    (KML:Fmt (caddr p) 3))
)

(defun KML:CoordsText (pts / out p)
  (setq out "")
  (foreach p pts
    (setq out
      (strcat
        out
        (if (= out "") "" " ")
        (KML:CoordText p))))
  out
)

(defun KML:LWPolyCoords (ename / ed elev pts pair p)
  (setq ed (entget ename)
        elev (if (assoc 38 ed) (cdr (assoc 38 ed)) 0.0)
        pts '())
  (foreach pair ed
    (if (= (car pair) 10)
      (progn
        (setq p (cdr pair))
        (setq pts
          (append pts
            (list
              (KML:ProjectPoint
                (KML:Ensure3D p elev))))))))
  pts
)

(defun KML:PolyCoords (ename / next ed pts p)
  (setq pts '()
        next (entnext ename))
  (while next
    (setq ed (entget next))
    (cond
      ((= (cdr (assoc 0 ed)) "VERTEX")
       (setq p (cdr (assoc 10 ed)))
       (setq pts
         (append pts
           (list
             (KML:ProjectPoint
               (KML:Ensure3D p 0.0))))))
      ((= (cdr (assoc 0 ed)) "SEQEND")
       (setq next nil)))
    (if next (setq next (entnext next))))
  pts
)

(defun KML:LineCoords (ename / ed p1 p2)
  (setq ed (entget ename)
        p1 (KML:ProjectPoint
             (KML:Ensure3D (cdr (assoc 10 ed)) 0.0))
        p2 (KML:ProjectPoint
             (KML:Ensure3D (cdr (assoc 11 ed)) 0.0)))
  (list p1 p2)
)

(defun KML:PointCoords (ename / ed p)
  (setq ed (entget ename)
        p (cdr (assoc 10 ed)))
  (list
    (KML:ProjectPoint
      (KML:Ensure3D p 0.0)))
)

(defun KML:ClosedP (ename / ed flags typ)
  (setq ed (entget ename)
        typ (cdr (assoc 0 ed))
        flags (if (assoc 70 ed) (cdr (assoc 70 ed)) 0))
  (and
    (or (= typ "LWPOLYLINE") (= typ "POLYLINE"))
    (= 1 (logand flags 1)))
)

(defun KML:CloseCoords (pts)
  (if (and pts
           (not (equal (car pts) (car (last pts)) 1e-12)))
    (append pts (list (car pts)))
    pts)
)

(defun KML:EntityName (ename / ed typ value)
  (setq ed (entget ename)
        typ (cdr (assoc 0 ed)))
  (cond
    ((= typ "INSERT")
     (setq value (cdr (assoc 2 ed))))
    ((or (= typ "TEXT") (= typ "MTEXT"))
     (setq value (cdr (assoc 1 ed))))
    ((= typ "POINT")
     (setq value "Point"))
    (T
     (setq value typ)))
  (if (= (KML:Trim value) "")
    typ
    value)
)

(defun KML:LayerName (ename / ed)
  (setq ed (entget ename))
  (if (assoc 8 ed)
    (cdr (assoc 8 ed))
    "0")
)

(defun KML:LayerACI (layer / rec aci)
  (setq rec (tblsearch "LAYER" layer))
  (if (and rec (assoc 62 rec))
    (progn
      (setq aci (abs (cdr (assoc 62 rec))))
      (if (= aci 0) 7 aci))
    7)
)

(defun KML:ACIColor (aci)
  ; KML color is AABBGGRR.
  (cond
    ((= aci 1) "ff0000ff")
    ((= aci 2) "ff00ffff")
    ((= aci 3) "ff00ff00")
    ((= aci 4) "ffffff00")
    ((= aci 5) "ffff0000")
    ((= aci 6) "ffff00ff")
    ((= aci 8) "ff808080")
    ((= aci 9) "ffc0c0c0")
    (T "ffffffff"))
)

(defun KML:PolyColor (kmlColor)
  (strcat "66" (substr kmlColor 3))
)

(defun KML:EntityRecord (ename / ed typ layer name coords closed kind)
  (setq ed (entget ename)
        typ (cdr (assoc 0 ed))
        layer (KML:LayerName ename)
        name (KML:EntityName ename)
        coords nil
        closed nil
        kind nil)

  (cond
    ((= typ "LINE")
     (setq coords (KML:LineCoords ename)
           kind "LINE"))

    ((= typ "LWPOLYLINE")
     (setq coords (KML:LWPolyCoords ename)
           closed (KML:ClosedP ename)
           kind (if closed "POLYGON" "LINE")))

    ((= typ "POLYLINE")
     (setq coords (KML:PolyCoords ename)
           closed (KML:ClosedP ename)
           kind (if closed "POLYGON" "LINE")))

    ((or (= typ "POINT")
         (= typ "INSERT")
         (= typ "TEXT")
         (= typ "MTEXT"))
     (setq coords (KML:PointCoords ename)
           kind "POINT")))

  (if (and kind coords)
    (progn
      (if (= kind "POLYGON")
        (setq coords (KML:CloseCoords coords)))
      (list layer kind name coords))
    nil)
)

(defun KML:CollectRecords (ss / i rec out)
  (setq i 0
        out '())
  (while (< i (sslength ss))
    (setq rec (KML:EntityRecord (ssname ss i)))
    (if rec
      (setq out (append out (list rec))))
    (setq i (1+ i)))
  out
)

(defun KML:UniqueLayers (records / out rec layer)
  (setq out '())
  (foreach rec records
    (setq layer (nth 0 rec))
    (if (not (member layer out))
      (setq out (append out (list layer)))))
  out
)

(defun KML:IndexOf (item items / i found)
  (setq i 0
        found nil)
  (while (and items (null found))
    (if (= item (car items))
      (setq found i)
      (progn
        (setq i (1+ i)
              items (cdr items)))))
  found
)

(defun KML:WritePlacemark (fp rec styleId / kind name coords altitude)
  (setq kind (nth 1 rec)
        name (nth 2 rec)
        coords (nth 3 rec)
        altitude (if KML:*UseZ* "absolute" "clampToGround"))

  (write-line "    <Placemark>" fp)
  (write-line
    (strcat "      <name>" (KML:XMLEscape name) "</name>")
    fp)
  (write-line
    (strcat "      <styleUrl>#" styleId "</styleUrl>")
    fp)

  (cond
    ((= kind "POINT")
     (write-line "      <Point>" fp)
     (write-line
       (strcat "        <altitudeMode>" altitude "</altitudeMode>")
       fp)
     (write-line
       (strcat "        <coordinates>"
               (KML:CoordsText coords)
               "</coordinates>")
       fp)
     (write-line "      </Point>" fp))

    ((= kind "LINE")
     (write-line "      <LineString>" fp)
     (write-line "        <tessellate>1</tessellate>" fp)
     (write-line
       (strcat "        <altitudeMode>" altitude "</altitudeMode>")
       fp)
     (write-line
       (strcat "        <coordinates>"
               (KML:CoordsText coords)
               "</coordinates>")
       fp)
     (write-line "      </LineString>" fp))

    ((= kind "POLYGON")
     (write-line "      <Polygon>" fp)
     (write-line "        <tessellate>1</tessellate>" fp)
     (write-line
       (strcat "        <altitudeMode>" altitude "</altitudeMode>")
       fp)
     (write-line "        <outerBoundaryIs><LinearRing>" fp)
     (write-line
       (strcat "          <coordinates>"
               (KML:CoordsText coords)
               "</coordinates>")
       fp)
     (write-line "        </LinearRing></outerBoundaryIs>" fp)
     (write-line "      </Polygon>" fp)))

  (write-line "    </Placemark>" fp)
)

(defun KML:WriteKML (path records / fp layers i layer styleId color rec)
  (setq fp (open path "w"))
  (if (null fp)
    nil
    (progn
      (setq layers (KML:UniqueLayers records))

      (write-line "<?xml version=\"1.0\" encoding=\"UTF-8\"?>" fp)
      (write-line
        "<kml xmlns=\"http://www.opengis.net/kml/2.2\">"
        fp)
      (write-line "  <Document>" fp)
      (write-line
        (strcat "    <name>"
                (KML:XMLEscape (vl-filename-base path))
                "</name>")
        fp)

      ; One style per AutoCAD layer.
      (setq i 0)
      (foreach layer layers
        (setq styleId (strcat "layer_" (itoa i))
              color (KML:ACIColor (KML:LayerACI layer)))
        (write-line
          (strcat "    <Style id=\"" styleId "\">")
          fp)
        (write-line
          (strcat "      <LineStyle><color>"
                  color
                  "</color><width>2</width></LineStyle>")
          fp)
        (write-line
          (strcat "      <PolyStyle><color>"
                  (KML:PolyColor color)
                  "</color></PolyStyle>")
          fp)
        (write-line "    </Style>" fp)
        (setq i (1+ i)))

      ; Preserve AutoCAD layers as KML folders.
      (setq i 0)
      (foreach layer layers
        (setq styleId (strcat "layer_" (itoa i)))
        (write-line "    <Folder>" fp)
        (write-line
          (strcat "      <name>"
                  (KML:XMLEscape layer)
                  "</name>")
          fp)
        (foreach rec records
          (if (= (nth 0 rec) layer)
            (KML:WritePlacemark fp rec styleId)))
        (write-line "    </Folder>" fp)
        (setq i (1+ i)))

      (write-line "  </Document>" fp)
      (write-line "</kml>" fp)
      (close fp)
      T))
)

(defun KML:PSQuote (s)
  (KML:ReplaceAll s "'" "''")
)

(defun KML:WaitForFile (path timeoutMs / start now)
  (setq start (getvar "MILLISECS"))
  (while
    (and
      (not (findfile path))
      (progn
        (setq now (getvar "MILLISECS"))
        (if (>= now start)
          (< (- now start) timeoutMs)
          nil))))
  (findfile path)
)

(defun KML:MakeKMZ (kmlPath kmzPath / zipPath args started)
  ; Compress-Archive expects a .zip destination. Create ZIP first,
  ; then rename it to .kmz after compression finishes.
  (setq zipPath (strcat kmzPath ".zip"))

  (if (findfile kmzPath)
    (vl-file-delete kmzPath))
  (if (findfile zipPath)
    (vl-file-delete zipPath))

  (setq args
    (strcat
      "-NoProfile -ExecutionPolicy Bypass -Command "
      "\"Compress-Archive -LiteralPath '"
      (KML:PSQuote kmlPath)
      "' -DestinationPath '"
      (KML:PSQuote zipPath)
      "' -Force\""))

  (setq started (startapp "powershell.exe" args))

  (if (and started
           (KML:WaitForFile zipPath 10000))
    (progn
      (if (vl-file-rename zipPath kmzPath)
        T
        nil))
    nil)
)

(defun KML:WriteDCL (/ path fp lines)
  (setq path
    (strcat (getvar "TEMPPREFIX") "MAGIC_DWG2KML.dcl"))

  (setq lines
    '(
      "dwg2kml_dialog : dialog {"
      " label = \"MAGIC - DWG to KML / KMZ\";"

      " : boxed_column {"
      "  label = \"Input coordinate system\";"
      "  : row {"
      "   : text { label=\"UTM Zone (1-60):\"; width=20; }"
      "   : edit_box { key=\"zone\"; edit_width=6; }"
      "  }"
      "  : boxed_radio_row {"
      "   label = \"Datum\";"
      "   : radio_button { key=\"datum_nad83\"; label=\"NAD83\"; }"
      "   : radio_button { key=\"datum_wgs84\"; label=\"WGS84\"; }"
      "  }"
      "  : boxed_radio_row {"
      "   label = \"Hemisphere\";"
      "   : radio_button { key=\"hemi_n\"; label=\"North\"; }"
      "   : radio_button { key=\"hemi_s\"; label=\"South\"; }"
      "  }"
      "  : text { label=\"Ontario quick use: NAD83 / Zone 17N is the default.\"; }"
      "  : text { label=\"Drawing XY units must be UTM metres.\"; }"
      " }"

      " : boxed_radio_row {"
      "  label = \"Output\";"
      "  : radio_button { key=\"out_kml\"; label=\"KML\"; }"
      "  : radio_button { key=\"out_kmz\"; label=\"KMZ\"; }"
      " }"

      " : toggle { key=\"use_z\"; label=\"Use drawing elevations (3D KML)\"; }"
      " : toggle { key=\"open_after\"; label=\"Open exported file after creation\"; }"

      " : row {"
      "  : button { key=\"accept\"; label=\"Export\"; is_default=true; width=14; }"
      "  : button { key=\"cancel\"; label=\"Cancel\"; is_cancel=true; width=14; }"
      " }"
      "}"
    ))

  (if (setq fp (open path "w"))
    (progn
      (foreach line lines (write-line line fp))
      (close fp)
      path)
    nil)
)

(defun KML:Dialog (/ path id result zone)
  (setq path (KML:WriteDCL))
  (if (null path)
    nil
    (progn
      (setq id (load_dialog path))
      (if (or (null id)
              (< id 0)
              (not (new_dialog "dwg2kml_dialog" id)))
        (progn
          (if (and id (>= id 0)) (unload_dialog id))
          nil)
        (progn
          (set_tile "zone" (itoa KML:*Zone*))
          (set_tile
            (if (= (strcase KML:*Datum*) "NAD83")
              "datum_nad83"
              "datum_wgs84")
            "1")
          (set_tile
            (if (= (strcase KML:*Hemisphere*) "N")
              "hemi_n"
              "hemi_s")
            "1")
          (set_tile
            (if (= (strcase KML:*Output*) "KML")
              "out_kml"
              "out_kmz")
            "1")
          (set_tile "use_z" (KML:BoolStr KML:*UseZ*))
          (set_tile "open_after" (KML:BoolStr KML:*OpenAfter*))

          (action_tile
            "accept"
            "(progn (setq KML:*Zone* (atoi (get_tile \"zone\")) KML:*Datum* (if (= (get_tile \"datum_nad83\") \"1\") \"NAD83\" \"WGS84\") KML:*Hemisphere* (if (= (get_tile \"hemi_n\") \"1\") \"N\" \"S\") KML:*Output* (if (= (get_tile \"out_kml\") \"1\") \"KML\" \"KMZ\") KML:*UseZ* (= (get_tile \"use_z\") \"1\") KML:*OpenAfter* (= (get_tile \"open_after\") \"1\")) (done_dialog 1))")
          (action_tile "cancel" "(done_dialog 0)")

          (setq result (start_dialog))
          (unload_dialog id)

          (if (= result 1)
            (if (and (>= KML:*Zone* 1) (<= KML:*Zone* 60))
              T
              (progn
                (alert "UTM Zone must be between 1 and 60.")
                nil))
            nil)))))
)

(defun KML:EnsureExt (path ext / low suffix)
  (setq low (strcase path)
        suffix (strcase (strcat "." ext)))
  (if (and (>= (strlen low) (strlen suffix))
           (= (substr low
                      (+ 1 (- (strlen low) (strlen suffix))))
              suffix))
    path
    (strcat path "." ext))
)

(defun KML:DefaultName ()
  (if (= (getvar "DWGNAME") "")
    "MAGIC_Export"
    (vl-filename-base (getvar "DWGNAME")))
)

(defun c:DWG2KML
  (/ ss records ext outPath tempKml ok filter)

  (if (KML:Dialog)
    (progn
      (prompt
        "\nSelect LINE / POLYLINE / POINT / BLOCK / TEXT objects to export: ")

      (setq filter
        '((0 . "LINE,LWPOLYLINE,POLYLINE,POINT,INSERT,TEXT,MTEXT")))

      (setq ss (ssget filter))

      (if (null ss)
        (prompt "\nDWG2KML: no supported objects selected.")
        (progn
          (setq records (KML:CollectRecords ss))

          (if (null records)
            (prompt "\nDWG2KML: selection contained no exportable geometry.")
            (progn
              (setq ext
                (if (= (strcase KML:*Output*) "KMZ")
                  "kmz"
                  "kml"))

              (setq outPath
                (getfiled
                  (strcat "Save " (strcase ext))
                  (strcat (KML:DefaultName) "." ext)
                  ext
                  1))

              (if outPath
                (progn
                  (setq outPath (KML:EnsureExt outPath ext))

                  (if (= ext "kml")
                    (setq ok (KML:WriteKML outPath records))
                    (progn
                      (setq tempKml
                        (strcat
                          (getvar "TEMPPREFIX")
                          "MAGIC_DWG2KML_doc.kml"))
                      (if (findfile tempKml)
                        (vl-file-delete tempKml))

                      (setq ok
                        (and
                          (KML:WriteKML tempKml records)
                          (KML:MakeKMZ tempKml outPath)))

                      (if (findfile tempKml)
                        (vl-file-delete tempKml))))

                  (if ok
                    (progn
                      (prompt
                        (strcat
                          "\nDWG2KML complete: "
                          outPath))
                      (if KML:*OpenAfter*
                        (startapp outPath)))
                    (alert
                      "DWG2KML could not create the requested output.\nFor KMZ, confirm Windows PowerShell is available."))))))))))
  (princ)
)

(defun c:KML ()
  (c:DWG2KML)
)

(princ "\nMAGIC DWG2KML V1.0 loaded. Commands: DWG2KML / KML")
(princ)