找回密码
 立即注册

QQ登录

只需一步,快速开始

扫一扫,访问微社区

查看: 654|回复: 1

[转贴]:推荐一个Visual Lisp Date 函数

[复制链接]
发表于 2003-9-22 07:09:15 | 显示全部楼层 |阅读模式

马上注册,结交更多好友,享用更多功能,让你轻松玩转社区。

您需要 登录 才可以下载或查看,没有账号?立即注册

×
  1. ;;by Bill Kramer for educational purposes only.
  2. ;; Functions:
  3. ;;  AcadCalendar    - Given Julian date from AutoCAD DATE variable,
  4. ;                    returns string MM/DD/YYYY.
  5. ;  AcadJulianDate  - Determines base value (Midnight) for AutoCAD
  6. ;                    DATE variable given the month, day, and year.
  7. ;  AstroCalendar   - Given astronomical Julian date, returns string
  8. ;                    with MM/DD/YYYY format.
  9. ;  AstroJulianDate - Given month, day, year returns Julian date as
  10. ;                    determined by the Naval Astronomical Observatory.
  11. ;  DayOfWeek       - Given month, day, year returns string with the
  12. ;                    day of the week.
  13. ;  DayOfYear       - Given month, day, year return integer number for
  14. ;                    day of the year.
  15. ;  isLeapYear      - Given year returns T if leap year, nil otherwise.
  16. ;; Astronomical Julian Date (number of days since noon, Jan 1, 4713 BC at
  17. ; Greenwich England),
  18. ; AutoCAD Julian date is based on the local time plus next Midnight.
  19. ;; Programs adapted from "Practical Astronomy with your Calculator" by
  20. ; Peter Duffett-Smith - ISBN 0521356997
  21. ;;=================================================
  22. ; AstroJulianDate - given date, calculate Julian Date
  23. ;   MM - integer Month number
  24. ;   DD - integer Day number
  25. ;   YY - integer Year number (complete year as in 2002)
  26. ;;   Returns real number.
  27. ;
  28. (defun AstroJulianDate (MM DD YY / A B C D)
  29.   (setq B 1)
  30.   (if (<= YY 1582)
  31.     (progn ;test for date <10/15/1582
  32.       (if (< YY 1582) (setq B 0)
  33.         (if (< MM 10) (setq B 0)
  34.           (if (< DD 15) (setq B 0))))))
  35.   ;
  36.   (if (or (= MM 1) (= MM 2))
  37.     (setq YY (1- YY)
  38.           MM (+ MM 12)))
  39.   (if (= B 1) ;Correction for date > 10/15/1582
  40.     (setq A (fix (/ YY 100.0))
  41.           B (+ (- 2.0 A) (fix (/ A 4.0)))))
  42.   (if (< YY 0)
  43.     (setq C (fix (- (* YY 365.25) 0.75)))
  44.     (setq C (fix (* YY 365.25))))
  45.   (setq D (fix (* 30.6001 (+ MM 1))))
  46.   (+ B C D DD 1720994.5))
  47. ;=================================================
  48. ;
  49. ; AutoCAD Julian Date - returns base day for ACAD (midnight),
  50. ; add fraction of day to match "DATE" system variable.
  51. ;
  52. ; Parameters same as AstroJulianDate.
  53. ;
  54. (defun AcadJulianDate (MM DD YY / T1)
  55.   (setq T1 (AstroJulianDate MM DD YY)
  56.         T1 (+ T1 0.5))
  57. )
  58. ;=================================================
  59. ;
  60. ; AstroCalendar - return string date given Julian date
  61. ;  JD - real Julian date
  62. ;
  63. ;  Returns string of form "MM/DD/YYYY"
  64. ;
  65. (defun AstroCalendar (JD / II F A B C D E G TT DD MM YY)
  66.   (setq II (fix (+ JD 0.5))
  67.         F (- JD II))
  68.   (if (> II 2299160.0)
  69.     (setq A (fix (/ (- II 1867216.25) 35624.25))
  70.           B (+ II 1 A (fix (/ A -4.0)))
  71.           )
  72.     (setq B II)
  73.     )
  74.   (setq C (+ B 1524.0)
  75.         D (fix (/ (- C 122.1) 365.25))
  76.         E (fix (* D 365.25))
  77.         G (fix (/ (- C E) 30.6001))
  78.         TT (+ C (- E) F (fix (* G -30.6001)))
  79.         DD (fix (+ TT 0.5))
  80.         )
  81.   (if (< G 13.5)
  82.     (setq MM (1- (fix G)))
  83.     (setq MM (- (fix G) 13))
  84.     )
  85.   (if (> MM 2)
  86.     (setq YY (- (fix D) 4716))
  87.     (setq YY (- (fix D) 4715)))
  88.   (strcat (itoa MM) "/" (itoa DD) "/" (itoa YY))
  89.   )
  90. ;=================================================
  91. ;
  92. ; AcadCalendar - same as AstroCalendar but uses
  93. ;                offset AutoCAD Julian Date
  94. ;
  95. (defun AcadCalendar (aJD)
  96.   (setq aJD (- (fix aJD) 0.5))
  97.   (AstroCalendar aJD)
  98.   )
  99. ;=================================================
  100. ;
  101. ; DayOfWeek - Determine day of week, return string
  102. ;
  103. ;  MM - integer month
  104. ;  DD - integer day
  105. ;  YY - integer full year
  106. ;
  107. (defun DayOfWeek (MM DD YY / T1)
  108.   (setq T1 (/ (+ (AstroJulianDate MM DD YY) 1.5) 7.0)
  109.         T1 (fix (+ 0.4 (* 7.0 (- T1 (fix T1))))))
  110.   (nth T1 '("Sunday"
  111.             "Monday"
  112.             "Tuesday"
  113.             "Wednesday"
  114.             "Thursday"
  115.             "Friday"
  116.             "Saturday"))
  117. )
  118. ;=================================================
  119. ;
  120. ; DayOfYear - Return integer count of days with
  121. ;             1 = Jan 1 of year since Jan 1.
  122. ;
  123. ;  MM - integer month
  124. ;  DD - integer day
  125. ;  YY - integer full year
  126. ;
  127. (defun DayOfYear (MM DD YY / iVal tD)
  128.   (setq iVal (if (isLeapYear YY) 62 63))
  129.   (if (> MM 2)
  130.       (setq MM (1+ MM)
  131.             tD (- (fix (* MM 30.6)) iVal)
  132.             )
  133.       (setq MM (1- MM)
  134.             tD (fix (/ (* MM iVal) 2.0))
  135.             )
  136.     )
  137.   (+ DD tD)
  138. )
  139. ;=================================================
  140. ;
  141. ; iaLeapYear - Return T if leap year, nil if not a leap year
  142. ;
  143. ;  YY - integer full year
  144. ;
  145. (defun isLeapYear (YY / TT)
  146.   (setq TT (/ YY 4.0))
  147.   (if (equal (- TT (fix TT)) 0.0 0.00001)
  148.     (progn
  149.       ;; Divisible by 4, test for 100 year exception
  150.       (setq TT (/ YY 100.0))
  151.       (if (equal (- TT (fix TT)) 0.0 0.00001)
  152.         (progn
  153.           ;; Divisible by 100, test for 400 year double exception
  154.           (setq TT (/ YY 400.0))
  155.           (if (equal (- TT (fix TT)) 0.0 0.00001)
  156.             T ;divisible by 400 is leap year
  157.             nil ;divisible by 100 is not leap year
  158.             )
  159.           )
  160.         T ;divisible by 4 but not 100, is leap year
  161.         )
  162.       )
  163.     nil) ;not divisible by 4, not a leap year
  164. )
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
发表于 2005-2-17 22:58:34 | 显示全部楼层
有何用处呀
论坛插件加载方法
发帖求助前要善用【论坛搜索】功能,那里可能会有你要找的答案;
如果你在论坛求助问题,并且已经从坛友或者管理的回复中解决了问题,请把帖子标题加上【已解决】;
如何回报帮助你解决问题的坛友,一个好办法就是给对方加【D豆】,加分不会扣除自己的积分,做一个热心并受欢迎的人!
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

QQ|申请友链|Archiver|手机版|小黑屋|辽公网安备|晓东CAD家园 ( 辽ICP备15016793号 )

GMT+8, 2024-5-1 07:59 , Processed in 0.375718 second(s), 33 queries , Gzip On.

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表