Excelden GIS Sınıfın Aktarılması(Netcad Makro)

Makro Hakkında:

Excel’de xls formatlı dosyanızda 1. sütuna parsel numarası,2.sütuna GIS SINIFI yazınız. Parsel numaralarının netcad projeniz ile aynı olmasına dikkat ediniz. Böylece excele yazdığınız GIS SINIFLARI netcad projenizdeki alanlara yazdırılır.

• Makroda Üzerinde Çalıştığımız Gelişmeler:
  • Şu anlık üzerinde çalıştığımız bir gelişme bulunmamaktadır. Kullanıcılardan gelen istekler ve editörlerimizin çalışmaları ile olası gelişmeler yayımlanacaktır. Bizi takip ediniz.
• Etiketler: Basit düzey makro, Netcad, Makro, Pratik Netcad, Netcad Araçları, Netcad tabaka, netcad seçim, Pratik Netcad, Netcadde nasıl yapılır,netcad menü, netcad araç, nvb, ücretsiz makro, harita makro,

Uyarılar:

• Exceldeki sütun adları ile kullanıcı formundaki sütun adlarının aynı olmasına dikkat ediniz.
• Bu makro ile en fazla 50bin satır excel satırı okunabilir.
• Exceldeki parsel no ile projedeki parsel no eşleşmesi durumunda Önceki GIS SINIFI silinir ve bu işlem geri alınmaz
• Excel dosyasındaki parsel no sütunundaki tüm parseller projenizde taranacak. Bu durumda
  • Bir parselden aynı isimli birden fazla olması durumunda GIS SINIFI hatası olacağını unutmayınız
  • GIS SINIFI sütununda sayı olmayan karakter kullanmayınız. Yazdığınız GIS sınıfının netcad bağlantı yöneticisinde olması gerektiğini unutmayınız
  • Excel ile netcad projesinde eşleşmeyen alanlarda GIS SINIFI değiştirme yapılmayacaktır. Eski GIS SINIFI aynı kalacaktır.
• Netcad makrolarında hiçbir metni veya karakteri değiştirmeyiniz. Aksi halde makro işlevsiz hale gelebilir veya hatalı işlev ile karşılaşabilirsiniz.

İndirme Linkleri:

İndirme Linki-1: Google Drive ( Harita Akademi )

Makro Açık Kaynak Kodu:

\'\' www.sabangul.com.tr Web Sayfasından İndirilmiştir
\' Şaban GÜL , Harita Mühendisi
\' Her Türlü Hata, İstek ve Öneriler İçin 
\' haritaakademi@gmail.com veya sagulnet@gmail.com
\' adresine durumu anlatan bir e-posta gönderiniz.
Sub Main
 with netcad
Dim i
 dim j
 dim o
 dim SEL
 dim xls
 dim xlspath
 dim alan
 dim DEG
 dim CL
 dim bd
 DIM U,V,R,W
 dim ruhangul
 dim elifyaren
 DIM NO(50000,2)
 DEG = \"\"
 CL=0:U=0:R=0
 set xls = CreateObject(\"excel.application\")
set BD = Netcad.NewBDialog(\"GIS Sınıfının Excelden Alınması [Harita Akademi, Şaban GÜL]\")
 BD.GetFileName \"item1\",\"Aktarım Yapılacak Excel Dosyası Seçiniz:\",\"\",\"Excel Dosyalari|*.xls|Tum Dosyalar|*.*\",\"xls\"
 BD.Getcombo \"item2\",\"Parsel Numarası Hangi Sütunda Bulunuyor ? \",\"A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z\" ,0
 BD.Getcombo \"item3\",\"GIS Sınıfı Hangi Sütunda Bulunuyor ? \",\"A|B|C|D|E|F|G|H|I|J|K|L|M|N|O|P|Q|R|S|T|U|V|W|X|Y|Z\" ,1
if BD.showmodal then
 xlspath = BD.ValueByName(\"item1\")
 else
 exit sub
 end if
dim saban,ruhan
saban= BD.ValueByName(\"item2\")
 ruhan= BD.ValueByName(\"item3\")
saban=1
 ruhan=2
if BD.ValueByName(\"item2\")=\"A\" then saban=1
 if BD.ValueByName(\"item2\")=\"B\" then saban=2
 if BD.ValueByName(\"item2\")=\"C\" then saban=3
 if BD.ValueByName(\"item2\")=\"D\" then saban=4
 if BD.ValueByName(\"item2\")=\"E\" then saban=5
 if BD.ValueByName(\"item2\")=\"F\" then saban=6
 if BD.ValueByName(\"item2\")=\"G\" then saban=7
 if BD.ValueByName(\"item2\")=\"H\" then saban=8
 if BD.ValueByName(\"item2\")=\"I\" then saban=9
 if BD.ValueByName(\"item2\")=\"J\" then saban=10
 if BD.ValueByName(\"item2\")=\"K\" then saban=11
 if BD.ValueByName(\"item2\")=\"L\" then saban=12
 if BD.ValueByName(\"item2\")=\"M\" then saban=13
 if BD.ValueByName(\"item2\")=\"N\" then saban=14
 if BD.ValueByName(\"item2\")=\"O\" then saban=15
 if BD.ValueByName(\"item2\")=\"P\" then saban=16
 if BD.ValueByName(\"item2\")=\"Q\" then saban=17
 if BD.ValueByName(\"item2\")=\"R\" then saban=18
 if BD.ValueByName(\"item2\")=\"S\" then saban=19
 if BD.ValueByName(\"item2\")=\"T\" then saban=20
 if BD.ValueByName(\"item2\")=\"U\" then saban=21
 if BD.ValueByName(\"item2\")=\"V\" then saban=22
 if BD.ValueByName(\"item2\")=\"W\" then saban=23
 if BD.ValueByName(\"item2\")=\"X\" then saban=24
 if BD.ValueByName(\"item2\")=\"Y\" then saban=25
 if BD.ValueByName(\"item2\")=\"Z\" then saban=26
if BD.ValueByName(\"item3\")=\"A\" then ruhan=1
 if BD.ValueByName(\"item3\")=\"B\" then ruhan=2
 if BD.ValueByName(\"item3\")=\"C\" then ruhan=3
 if BD.ValueByName(\"item3\")=\"D\" then ruhan=4
 if BD.ValueByName(\"item3\")=\"E\" then ruhan=5
 if BD.ValueByName(\"item3\")=\"F\" then ruhan=6
 if BD.ValueByName(\"item3\")=\"G\" then ruhan=7
 if BD.ValueByName(\"item3\")=\"H\" then ruhan=8
 if BD.ValueByName(\"item3\")=\"I\" then ruhan=9
 if BD.ValueByName(\"item3\")=\"J\" then ruhan=10
 if BD.ValueByName(\"item3\")=\"K\" then ruhan=11
 if BD.ValueByName(\"item3\")=\"L\" then ruhan=12
 if BD.ValueByName(\"item3\")=\"M\" then ruhan=13
 if BD.ValueByName(\"item3\")=\"N\" then ruhan=14
 if BD.ValueByName(\"item3\")=\"O\" then ruhan=15
 if BD.ValueByName(\"item3\")=\"P\" then ruhan=16
 if BD.ValueByName(\"item3\")=\"Q\" then ruhan=17
 if BD.ValueByName(\"item3\")=\"R\" then ruhan=18
 if BD.ValueByName(\"item3\")=\"S\" then ruhan=19
 if BD.ValueByName(\"item3\")=\"T\" then ruhan=20
 if BD.ValueByName(\"item3\")=\"U\" then ruhan=21
 if BD.ValueByName(\"item3\")=\"V\" then ruhan=22
 if BD.ValueByName(\"item3\")=\"W\" then ruhan=23
 if BD.ValueByName(\"item3\")=\"X\" then ruhan=24
 if BD.ValueByName(\"item3\")=\"Y\" then ruhan=25
 if BD.ValueByName(\"item3\")=\"Z\" then ruhan=26
set BD = Nothing
 xls.workbooks.open(xlspath)
 xls.range(\"A1\").select
FOR U=1 TO 100000
 CL=CL+1
 NO(U,1)=\"*\" & XLS.CELLS(U,saban)
 NO(U,2)= XLS.CELLS(U,ruhan)
 IF NO(U,2)=\"\" THEN NO(U,2)=0
 IF NO(U,1)=\"*\" THEN U=100000
 NEXT
 xls.quit
set SEL = .NewSelectionSet
 set o = .NewObject
if SEL.SELECT(\"CokluDogru,Alan,Nokta ve Yazı Objelerini Seçiniz...\",array(opline,oline,opoint,otext)) then
for i = 0 to SEL.NE-1
 j = SEL.GetSelectedObject(i, o)
 alan = o.cls
 on error resume next
 FOR V=1 TO CL
 W=NO(V,1)
 if W =\"*\" & alan then
 o.cls = NO(V,2)
 .putobject j, o
 R=R+1
 \'MSGBOX alan & \" : \" & NO(V,1) & \" : \" & NO(V,2)
 V=U
 end if
 NEXT
next
 SEL.RedrawAndRewind
 end if
set SEL = nothing
 set o = nothing
 end with
MSGBOX R & \" adet Parselin GIS Sınıfı Değiştirildi.\"
end sub