* E Posta Adresiniz:
* Kodu Girin:

İleti Yazar
12.12.2014 23:52
79640    
ProhibiT

[80] Yetkili

Online Durumu

1469 ileti
İnşaat Mühendisi
Ankara

Daha önce paylaştığımız Havalandırma Kanalı Metrajı yapmak için kullanılan KaMe'nin benzeri mantıkla çalışan, Boru Metrajı yapmak için kullanılmak üzere BoMe isimli fonksiyon yazdım. KaMe lispinde olduğu gibi bu konunun da çok uzayacağını tahmin ettiğim için, bağımsız başlık altında paylaşmak istedim.



Kod:

;|===========================================================================|
| Boru Metrajını yapmak için M. Şahin Güvercin tarafından hazırlanmıştır.   |
|                                  www.cizimokulu.com 12.05.2014            |
|===========================================================================|;
(defun C:BoMe(/ Boy Cap cp gbr Kbr KPNo kuk L MPo myerr Nk1 Nk2 olderr Rw YYuk)
  (defun myerr (errmsg)
    (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg)))
    (command "._undo" "_e")
    (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
    (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
    (setq *error* olderr) (princ))
  (setq olderr *error* *error* myerr) (*push-error-using-command*)
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (setq cp "")
  (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32
    45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm"))
  (setq kuk (initget "Mm Cm mT """)
        gbr (getkword (strcat "\nÇizim Birimi [Mm/Cm/mT] <" egbr "> :")))
  (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm"))
  (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale"))))
  (setq kuk  (initget)
        YYuk (getreal (strcat "\nYazi yüksekligi <" (rtos eYuk) "> :")))
  (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1))
  (setq KPNo (getint (strcat "\nPoz Numarası <" (itoa eKPN) "> :")))
  (if (not KPNo) (setq KPNo eKPN))
  (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 1)
  (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-invoke-method Shts "Add"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          NwBook (vlax-invoke-method Books "Add")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-get-property Shts "Item" 1)))
  (setq ExCLLs (vlax-get-property Sht1 "Cells"))
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-false)
  (vlax-put-property ExApp "DecimalSeparator" ".")
  (vla-put-visible ExApp :vlax-true)
  (mapcar '(lambda (p1 p2)
             (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2))
         '((1 1 1 1) (1 2 1 2) (1 3 1 3)) '("Poz No." "Çap" "Boy"))
  (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range"
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 3)))
                       'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108))
  (while (setq Nk1 (getpoint "\nBoru Başlangıç Noktasını seçiniz..."))
    (setq Nk2 (getpoint Nk1  "\n    Boru Bitiş Noktasını seçiniz...")
          Boy (distance Nk1 Nk2)
          MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2))
    (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk)
                   (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo)))
    (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk))))
    (princ "\nBoru Çap Yazısını seçiniz...")
    (while (not (setq Cap (ssget "+.:s" (list (cons 0 "*TEXT")))))
      (princ "\n Sectiginiz obje bir Text veya MText olmalıdır!"))
    (cond ((= gbr "Mm") (setq Boy (/ Boy 1000)))
          ((= gbr "Cm") (setq Boy (/ Boy 100)))
          ((= gbr "m") (setq Boy Boy))
          (T nil))
    (setq Rw (1+ Rw) Cap (cdr (assoc 1 (entget (ssname Cap 0)))))
    (if (vl-string-position 45 Cap)
      (setq Cap (substr Cap (+ 2 (vl-string-position 45 Cap)))))
    (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2))
            '(1 2 3) (list (itoa KPNo) Cap (rtos Boy 2 2)))
    (princ (strcat "\n* Poz No:" (itoa KPNo) ", Çap:" Cap
      ", Boy:" (rtos Boy 2 2))) (setq KPNo (1+ KPNo)))
  (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property rn 'MergeCells :vlax-true)
  (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122
    105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch)))))
  (vlax-put-property rn 'ShrinkToFit :vlax-true)
  (setq rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0"))
  (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1"))
  (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit)
  (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit)
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-true)
  (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
  (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
  (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))

Kodları buradan alarak Lisp dosyasına çevirerek kullanmakta zorluk çeken arkadaşlarımız 174410-bome-1.rar linkinden hazır dosyayı indirebilirler.

Herkese kolay gelsin...

admin (05.04.2018 17:01 GMT)

Where there is a will, there is a way... Beğenmek için anlamak lazım...

13.12.2014 07:04
79642    
sensey06

[2] Girişimci

Online Durumu

2 ileti
İklimendirme soğutma teknikeri
ankara

Ellerine sağlık hocam....

Herkes hak ettiği hayatı yaşar....

13.12.2014 12:01
79649    
mttlp

[8] Kıdemli Uzman

Online Durumu

109 ileti
Teknik Ressam
ankara

Eline sağlık hocam

en sevdiğim komut copy

13.12.2014 23:36
79666    
kaan0624

[40] Gold üye

Online Durumu

34 ileti
inşaat teknikeri
ankara

hocam elinize sağlık gerçekten çok beğendim.bu program şöylede olsa böylede olsa gibi şeyler söyleyip sizin canınızı sıkmak istemiyorum hocam.kitabınızdan çok faydalanıyorum yavaş yavaş öğrendiğimi hissediyorum.yalnız ufak bir sorum var düzenleme bakımından bu programda çap boy değilde en boy şeklinde birşey yapabilirmiyim.şimdiden çok teşekkür ederim hocam

14.12.2014 22:55
79677    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

Ellerinize sağlık hocam
Bir önerim olacak affınıza sığınarak
linneer ölçimler yerine çok dönüşlü ölçümleri yapma olanağı da verebilrir msiniz
ya da çoklu seçimler yapıp sonradan çapı değştirdiğimde seçimleri toplayıp yazavbilir mi
?
poliline gibi ....

20.12.2014 20:32
79805    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

20.12.2014 20:32
79806    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

20.12.2014 20:32
79807    
onderylmz

[3] Kıdemli Girişimci

Online Durumu

32 ileti
Mak.Yük.Müh.
ANKARA

bu lisp çoklu nokta seçimi haline getirilebilir mi ? Lütfen Yardım ...

29.10.2016 21:11
84076    
elk21

[40] Gold üye

Online Durumu

21 ileti
elektrik teknikeri
diyarbakır

yaw özür dilerim ama bir türlü çalıştıramadım

14.01.2018 21:28
85921    
eruk

[2] Girişimci

Online Durumu

1 ileti

Kardes,
Bendeniz Hollanda'dan katilmaktayim...

Acemiyim.... toyum...comezim.. lamerim...
Bome programiniz borulari tek tek seciyor..

Simdi bunu tum borulari secme imkani yapma varmidir.

He de gardas...da su acemiyi sevindir.

24.05.2018 13:39
86340    
ebkeskin

[2] Girişimci

Online Durumu

1 ileti

hangi komutla çalışıyor onu yazmamışsınız?

29.09.2018 10:42
86698    
tekgul

[2] Girişimci

Online Durumu

1 ileti
tekniker
ankara

Alıntı
ProhibiT :
Daha önce paylaştığımız Havalandırma Kanalı Metrajı yapmak için kullanılan KaMe'nin benzeri mantıkla çalışan, Boru Metrajı yapmak için kullanılmak üzere BoMe isimli fonksiyon yazdım. KaMe lispinde olduğu gibi bu konunun da çok uzayacağını tahmin ettiğim için, bağımsız başlık altında paylaşmak istedim.



Kod:

;|===========================================================================|
| Boru Metrajını yapmak için M. Şahin Güvercin tarafından hazırlanmıştır.   |
|                                  www.cizimokulu.com 12.05.2014            |
|===========================================================================|;
(defun C:BoMe(/ Boy Cap cp gbr Kbr KPNo kuk L MPo myerr Nk1 Nk2 olderr Rw YYuk)
  (defun myerr (errmsg)
    (if (/= errmsg "\nFunction cancelled") (prompt (strcat "\n" errmsg)))
    (command "._undo" "_e")
    (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
    (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
    (setq *error* olderr) (princ))
  (setq olderr *error* *error* myerr) (*push-error-using-command*)
  (setvar "cmdecho" 0) (command "undo" "group") (vl-load-com) (setq cp "")
  (foreach ch '(77 46 32 83 97 104 105 110 32 71 252 118 101 114 99 105 110 32
    45 32) (setq cp (strcat cp (chr ch)))) (if (not egbr) (setq egbr "Cm"))
  (setq kuk (initget "Mm Cm mT """)
        gbr (getkword (strcat "\nÇizim Birimi [Mm/Cm/mT] <" egbr "> :")))
  (if (not gbr) (setq gbr egbr)) (if (not eKbr) (setq eKbr "Mm"))
  (if (not eYuk) (setq eYuk (* (getvar "dimtxt") (getvar "dimscale"))))
  (setq kuk  (initget)
        YYuk (getreal (strcat "\nYazi yüksekligi <" (rtos eYuk) "> :")))
  (if (not YYuk) (setq YYuk eYuk)) (if (not eKPN) (setq eKPN 1))
  (setq KPNo (getint (strcat "\nPoz Numarası <" (itoa eKPN) "> :")))
  (if (not KPNo) (setq KPNo eKPN))
  (setq ExApp (vlax-get-or-create-object "Excel.Application") Rw 1)
  (if (setq NwBook (vlax-get-property ExApp "ActiveWorkbook"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-invoke-method Shts "Add"))
    (setq Books  (vlax-get-property ExApp "WorkBooks")
          NwBook (vlax-invoke-method Books "Add")
          Shts   (vlax-get-property NwBook "Sheets")
          Sht1   (vlax-get-property Shts "Item" 1)))
  (setq ExCLLs (vlax-get-property Sht1 "Cells"))
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-false)
  (vlax-put-property ExApp "DecimalSeparator" ".")
  (vla-put-visible ExApp :vlax-true)
  (mapcar '(lambda (p1 p2)
             (vlax-put-property ExCLLs 'Item (nth 0 p1) (nth 1 p1) p2))
         '((1 1 1 1) (1 2 1 2) (1 3 1 3)) '("Poz No." "Çap" "Boy"))
  (vlax-put-property (vlax-get-property (vlax-get-property ExCLLs "Range"
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
        (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 3)))
                       'CeLLs) 'HorizontalAlignment (vlax-make-variant -4108))
  (while (setq Nk1 (getpoint "\nBoru Başlangıç Noktasını seçiniz..."))
    (setq Nk2 (getpoint Nk1  "\n    Boru Bitiş Noktasını seçiniz...")
          Boy (distance Nk1 Nk2)
          MPo (mapcar '(lambda (n1 n2) (/ (+ n1 n2) 2.0)) Nk1 Nk2))
    (entmake (list (cons 0 "TEXT") (cons 10 MPo) (cons 40 YYuk)
                   (cons 1 (itoa KPNo)) (cons 50 0) (cons 72 4) (cons 11 MPo)))
    (entmake (list (cons 0 "CIRCLE") (cons 10 MPo) (cons 40 (* 1.15 YYuk))))
    (princ "\nBoru Çap Yazısını seçiniz...")
    (while (not (setq Cap (ssget "+.:s" (list (cons 0 "*TEXT")))))
      (princ "\n Sectiginiz obje bir Text veya MText olmalıdır!"))
    (cond ((= gbr "Mm") (setq Boy (/ Boy 1000)))
          ((= gbr "Cm") (setq Boy (/ Boy 100)))
          ((= gbr "m") (setq Boy Boy))
          (T nil))
    (setq Rw (1+ Rw) Cap (cdr (assoc 1 (entget (ssname Cap 0)))))
    (if (vl-string-position 45 Cap)
      (setq Cap (substr Cap (+ 2 (vl-string-position 45 Cap)))))
    (mapcar '(lambda (p1 p2) (vlax-put-property ExCLLs 'Item rw p1 p2))
            '(1 2 3) (list (itoa KPNo) Cap (rtos Boy 2 2)))
    (princ (strcat "\n* Poz No:" (itoa KPNo) ", Çap:" Cap
      ", Boy:" (rtos Boy 2 2))) (setq KPNo (1+ KPNo)))
  (setq Rw (1+ Rw) rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property rn 'MergeCells :vlax-true)
  (vlax-put-property ExCLLs 'Item Rw 1 (foreach ch '(119 119 119 46 99 105 122
    105 109 111 107 117 108 117 46 99 111 109) (setq cp (strcat cp (chr ch)))))
  (vlax-put-property rn 'ShrinkToFit :vlax-true)
  (setq rn (vlax-get-property ExCLLs "Range"
             (vlax-variant-value (vlax-get-property ExCLLs 'Item 1 1))
             (vlax-variant-value (vlax-get-property ExCLLs 'Item Rw 3))))
  (vlax-put-property (vlax-get-property rn 'Borders) 'color (vlax-make-variant "0.0"))
  (vlax-put-property (vlax-get-property rn 'Borders) 'LineStyle (vlax-make-variant "1"))
  (vlax-invoke-method (vlax-get-property rn 'Columns) 'AutoFit)
  (vlax-invoke-method (vlax-get-property rn 'Rows) 'AutoFit)
  (vlax-put-property ExApp "UseSystemSeparators" :vlax-true)
  (mapcar 'vlax-release-object (list rn ExCLLs Sht1 Shts NwBook Books ExApp))
  (setq ExApp nil) (gc) (gc) (setq egbr gbr eKbr Kbr eYuk YYuk eKPN KPNo)
  (command "_.undo" "end") (setq *error* olderr) (*pop-error-mode*) (prin1))

Kodları buradan alarak Lisp dosyasına çevirerek kullanmakta zorluk çeken arkadaşlarımız 174410-bome-1.rar linkinden hazır dosyayı indirebilirler.

Herkese kolay gelsin...

07.01.2019 06:28
86954    
xxlancelotxx

[2] Girişimci

Online Durumu

1 ileti
Muhendis
Moscow

Link ölmüş galiba, yeniden paylasabilir misiniz?

30.01.2019 13:37
87048    
kombicin

[2] Girişimci

Online Durumu

1 ileti
makina müh.
ankara

Slm...Boru metrajı lispinde seçimi tek tek değilde birden fazla (dönüş ve ayrım noktalarını ayırmadan) nokta seçerek ve çapı elle manuel girerek yapma imkanı var mıdır? Yardımcı olursanız sevinirim....

16.02.2019 09:14
87114    
ersenn

[2] Girişimci

Online Durumu

1 ileti

Hocam ellerinize sağlık
çok işime yaradı .

23.03.2019 13:49
87260    
brusk4773

[2] Girişimci

Online Durumu

1 ileti

hocam boru metraj lispi için şifre istiyor şifre yazabilir misiniz?

teşekkürler

> 1 <
Copyright © 2004-2019 | Tüm Hakları Saklıdır | 164 | Site haritası | İstatistikler | Hakkımızda | Kadromuz | Gizlilik | Reklam | İletişim