Google KML Dosyasını Netcad’e Aktarma Makrosu (Convert Google KML File to Netcad Macro)

' www.sabangul.com.tr Web Sayfasından İndirilmiştir
' Şaban GÜL , Harita Mühendisi
' Her Türlü Hata, İstek ve Öneriler İçin 
' sagulnet@gmail.com
' adresine durumu anlatan bir e-posta gönderiniz.

Sub Main
with Netcad
Dim file,fso ,dict,line
Dim f,row, noksa, deger, BD ,k1,k2,k3
Dim DOSYAA
 Dim  objFolder
Const ForReading = 1, ForWriting = 2, ForAppending = 8

'------------------------------------------------------------------------------------------
'Şaban GÜL Tarafından Üretilmiştir. Telif hakkı gereği bu satırı ve alttaki satırları silmeyiniz.
'Bu Makro SagulCAD ile üretilmiştir. Daha fazla bilgi için www.sagul.net adresini ziyaret ediniz.
'İstediğiniz yenilikleri, tespit ettiğiniz hataları bize ileti gönderiniz. E-posta: sagulnet@gmail.com.
'Bu makro sadece Netcad üzerinden çalışır. 
'Makroyu çalıştırmak için Netcad Menüsünden Araçlar >> Uygulama Geliştirme >> Makro Çalıştır menüsünden makroyu çalıştırabilirsiniz.
'sagul.net/SagulCAD adresinden daha fazla bilgi edinebilirsiniz.

'------------------------------------------------------------------------------------------

'''''' BU KODLARI GÖREBİLİYORSANIZ ÇEŞİTLİ YÖNTEMLER İLE
' BU KODLARA ULAŞTINIZ. BU KODLARIN AÇILMASI, KOPYALANMASI
' FARKLI KİŞİLERE VERİLMESİ YASAK OLUP TELİF HAKKINDA
' TABİİDİR. BU KODLARI KULLANMANIZ HUKUKİ SONUÇLAR DOĞURUR
' BU KODLARI AÇARAK ORTAYA ÇIKABİLECEK VERİ İHLALLERİNİN
' TÜM SORUMLULUĞU TARAFINIZA AİTTİR
' sabangul67@gmail.com e-posta adresine durumu anlatan
' bir eposta gönderiniz ve bu kodları bilgisayarınızdan siliniz
' aksi halde ortaya çıkabilecek tüm sorumluluğu kabul etmiş
' sayılırsınız

'Emeğe saygı göstermenizi ve lisanlı ürün kullanmanızı rica ederiz

'------------------------------------------------------------------------------------------
'--------------------------------LİSANS KONTROLÜ BAŞLANGICI -------------------------------
'------------------------------------------------------------------------------------------

'///////////// SERİAL NUMARASI
dim strComputer,objWMIService,str,colItems ,objItem
strComputer = "."
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")
str = ""
Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_LogicalDisk Where DeviceID = 'C:'")
For Each objItem In colItems
   str = objItem.VolumeSerialNumber
Next

dim d1,d2,d3,d4
dim m1,m2,m3,m4

d1=instr(date,".")
m1=mid(date,1,d1-1)
m2=mid(date,d1+1,len(date)-8)
m3=right(date,4)

if mid(m2,1,1)=0 then m2=mid(m2,2,1)
Dim ds
Set ds = CreateObject("Scripting.FileSystemObject")

dim serial
serial = mid(str,1,8)
serial = Replace(serial,"A",6)
serial = Replace(serial,"B",6)
serial = Replace(serial,"C",6)
serial = Replace(serial,"D",6)
serial = Replace(serial,"E",6)
serial = Replace(serial,"F",6)
serial = Replace(serial,"G",6)
serial = Replace(serial,"H",6)
serial = Replace(serial,"I",6)
serial = Replace(serial,"J",6)
serial = Replace(serial,"K",6)
serial = Replace(serial,"L",6)
serial = Replace(serial,"M",6)
serial = Replace(serial,"N",6)
serial = Replace(serial,"O",6)
serial = Replace(serial,"P",6)
serial = Replace(serial,"R",6)
serial = Replace(serial,"S",6)
serial = Replace(serial,"T",6)
serial = Replace(serial,"U",6)
serial = Replace(serial,"V",6)
serial = Replace(serial,"Y",6)
serial = Replace(serial,"Z",6)
serial = Replace(serial,"Q",6)
serial = Replace(serial,"W",6)
serial = Replace(serial,"X",6)
serial = Replace(serial,".",6)
serial = Replace(serial,"#",6)
serial = Replace(serial,"Ö",6)
serial = Replace(serial,"Ç",6)
serial = Replace(serial,"Ş",6)
serial = Replace(serial,"Ğ",6)
serial = Replace(serial,"ÜA",6)
serial = Replace(serial,"/A",6)
serial = Replace(serial,"+",6)

Dim ser1,ser2,ser3,ser4
ser1=mid(serial,1,2)+1-1
ser2=mid(serial,3,2)+1-1
ser3=mid(serial,5,2)+1-1
ser4=mid(serial,7,2) +1-1

dim netcadx,netcady,netcadz
Set netcadx = CreateObject("System.Collections.ArrayList")
Set netcady = CreateObject("System.Collections.ArrayList")
Set netcadz = CreateObject("System.Collections.ArrayList")
netcadx.Add 1962934272000
netcady.Add "Şaban GÜL"
netcadz.Add "31.12.2020"

netcadx.Add 9206637843465216
netcady.Add "Elif Yaren GÜL3"
netcadz.Add "31.12.2020"

netcadx.Add 181193932800000000
netcady.Add "Elif Yaren GÜL2"
netcadz.Add "31.12.2020"

netcadx.Add 15795179400
netcady.Add "Turan Taşınmaz Geliştirme A.Ş.xxxx"
netcadz.Add "31.12.2020"

netcadx.Add 884669423616
netcady.Add "Kıvırcık Osman"
netcadz.Add "31.12.2020"

netcadx.Add 3332267237376
netcady.Add "Siirtli Hüseyin AĞA"
netcadz.Add "31.12.2020"

dim filename1 , listFile1 ,  listLines1 , line1 , listecim1
dim fso1,fso2,fso3
Set fso1=CreateObject("Scripting.FileSystemObject")
filename1 =  "C:\SAGULCAD\AYARLAR\1.0"
listFile1 = fso1.OpenTextFile(filename1).ReadAll
listLines1 = Split(listFile1, vbCrLf)
Set listecim1 = CreateObject("System.Collections.ArrayList")
For Each line1 In listLines1
 listecim1.Add  line1
Next

dim filename2 , listFile2 ,  listLines2 , line2 , listecim2
Set fso2=CreateObject("Scripting.FileSystemObject")
filename2 =  "C:\SAGULCAD\AYARLAR\2.0"
listFile2 = fso2.OpenTextFile(filename2).ReadAll
listLines2 = Split(listFile2, vbCrLf)
Set listecim2 = CreateObject("System.Collections.ArrayList")
For Each line2 In listLines2
 listecim2.Add  line2
Next

dim filename3 , listFile3 ,  listLines3 , line3 , listecim3
Set fso3=CreateObject("Scripting.FileSystemObject")
filename3 =  "C:\SAGULCAD\AYARLAR\3.0"
listFile3 = fso3.OpenTextFile(filename3).ReadAll
listLines3 = Split(listFile3, vbCrLf)
Set listecim3 = CreateObject("System.Collections.ArrayList")
For Each line3 In listLines3
 listecim3.Add  line3
Next

dim korona
for korona=0 to listecim1.count-1
    netcadx.Add listecim1(korona)
    netcady.Add listecim2(korona)
    netcadz.Add listecim3(korona)
next

dim elifyarengul
dim eyg
eyg=0
for elifyarengul=0 to netcadx.count-1
dim sssserial
 sssserial=  netcadx(elifyarengul)+1-1
if ser1*ser2*ser2*ser3*ser3*ser4*ser4 = sssserial  then
eyg=1
dim  xxfsot,xxft
Set xxfsot = CreateObject("Scripting.FileSystemObject")
Set xxft = xxfsot.OpenTextFile("C:\SAGULCAD\AYARLAR\lic.lic", ForWriting, True)
xxft.WriteLine (netcady(elifyarengul))
xxft.WriteLine (netcadz(elifyarengul))
xxft.close

dim  xxxfsot,xxxft
Set xxxfsot = CreateObject("Scripting.FileSystemObject")
Set xxxft = xxxfsot.OpenTextFile("C:\SAGULCAD\AYARLAR\mes.lic", ForWriting, True)
xxxft.WriteLine (netcadx(elifyarengul)-123456789)
xxxft.close
end if
next

if eyg=1 then
else
 ser1= ser1*ser1 +67
 ser2 = ser2+ser2+43
 ser3=ser3*ser3+47
 ser4=ser4+ser4+72

if len(ser1) =4 then ser1= ser1 & "S"
if len(ser1) =3 then ser1=ser1 & "SG"
if len(ser1) =2 then ser1=ser1 & "SGL"
if len(ser1) =1 then ser1=ser1 & "ABCD"

if len(ser2) =4 then ser2= ser2 & "G"
if len(ser2) =3 then ser2=ser2 & "EY"
if len(ser2) =2 then ser2=ser2 & "GUL"
if len(ser2) =1 then ser2=ser2 & "YARN"

if len(ser3) =4 then ser3= ser3 & "R"
if len(ser3) =3 then ser3=ser3 & "SR"
if len(ser3) =2 then ser3=ser3 & "SRE"
if len(ser3) =1 then ser3=ser3 & "GULS"

if len(ser4) =5 then ser4= ser4 & "E"
if len(ser4) =4 then ser4= ser4 & "EY"
if len(ser4) =3 then ser4=ser4 & "EYG"
if len(ser4) =2 then ser4=ser4 & "ELIF"
if len(ser4) =1 then ser4=ser4 & "RUHAN"

dim addd,sg5
msgbox "Lisanssız Kullanıcı: Az sonra gösterilecek kodu sabangul67@gmail.com e-posta adresine göndererek lisans kodunu alabilirsiniz"
addd= inputbox ("Seri Numarası:","sabangul67@gmail.com adresine bu kodu gönderiniz", ser1 & "-" & ser2  & "-" & ser3& "-" & ser4 )
exit sub
end if

'///////////// SERİAL NUMARASI

'------------------------------------------------------------------------------------------
'--------------------------------LİSANS KONTROLÜ BİTİŞİ------------------------------------
'------------------------------------------------------------------------------------------

Set fso = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder("C:\")
 If Not FSO.FolderExists("C:\SAGULNET") Then
 objFolder.SubFolders.Add "SAGULNET"
 End If

Set fso = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder("C:\SAGULNET")
 If Not FSO.FolderExists("C:\SAGULNET\netcad_modul") Then
 objFolder.SubFolders.Add "netcad_modul"
 End If

Set fso = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder("C:\SAGULNET\netcad_modul")
 If Not FSO.FolderExists("C:\SAGULNET\netcad_modul\Makro") Then
 objFolder.SubFolders.Add "Makro"
 End If

Set fso = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder("C:\SAGULNET\netcad_modul")
 If Not FSO.FolderExists("C:\SAGULNET\netcad_modul\NCZYEDEK") Then
 objFolder.SubFolders.Add "NCZYEDEK"
 End If

Set fso = CreateObject("Scripting.FileSystemObject")
 Set objFolder = FSO.GetFolder("C:\SAGULNET\netcad_modul\Makro")
 If Not FSO.FolderExists("C:\SAGULNET\netcad_modul\Makro\Tanimlar") Then
 objFolder.SubFolders.Add "Tanimlar"
 End If

 dim BDX
set BDX = Netcad.NewBDialog("Dosya Kayıt Formu ,[Sagul.NET, Şaban GÜL]")
BDX.GetFileName "sabangul2","Google Kml Dosyasının Kaydedileceği Dosya Kayıt Yeri Seçin","","NCZ Dosyası|.ncz|Tum Dosyalar|.*","ncz"
BDX.Getcheck "kaydet","Oluşan objeler ile birlikte NCZ Dosyasını kaydet",0
 BDX.PutPrompt "Dosya seçilmezse C:\SagulNET\netcad_modul\NCZYEDEK klasörüne otomatik oluşur"

 dim kayityeri,kaydedilsin
 kayityeri=""
 if BDX.showmodal then
 kayityeri = BDX.ValueByName("sabangul2")
 kaydedilsin= BDX.ValueByName("kaydet")
 ENd if

 dim kayitras
 kayitras= "C:\SagulNET\netcad_modul\NCZYEDEK\sagul_"& replace(replace(now,":","_")," ","-") & ".ncz"
if kayityeri="" then kayityeri=kayitras

dim   sglxfsot,sglxft
  Set sglxfsot = CreateObject("Scripting.FileSystemObject")
 Set sglxft = sglxfsot.OpenTextFile(kayityeri, ForWriting, True)
sglxft.WriteLine ("")
 sglxft.close

   .LoadFile kayityeri  , fs_bnetcad

set BD = Netcad.NewBDialog("Google Kml Dosyası Yükleme")
 BD.GetFileName "item1","Google Kml Dosyası:","","Kml Dosyalari|*.kml|Tum Dosyalar|*.*","kml"
 if BD.showmodal then
 DOSYAA = BD.ValueByName("item1")
 k1= BD.ValueByName("item2")
 k2= BD.ValueByName("item3")
 k3= BD.ValueByName("item4")
 else
 exit sub
 end if

if dosyaa="" then exit sub

 Set fso = CreateObject("Scripting.FileSystemObject")
  Set file = fso.OpenTextFile(DOSYAA, 1)
Set dict = CreateObject("Scripting.Dictionary")
Set file = fso.OpenTextFile (DOSYAA, 1)
row = 0
Do Until file.AtEndOfStream
  line = file.Readline
  dict.Add row, line
  row = row + 1
Loop
file.Close

dim hayro
hayro=""
For Each line in dict.Items
 hayro =hayro & line
Next

hayro=replace(hayro,"<Placemark>","½")
hayro=replace(hayro,vbtab,"")
hayro=replace(hayro,"</Placemark>","")
hayro=replace(hayro,"</Folder></Document></kml>","")
hayro=replace(hayro,"</LinearRing></outerBoundaryIs>","")
Dim MyString, MyArray, Msg
MyString = hayro
MyArray = Split(MyString, "½", -1, 1)

dim ss,a,x
ss=0
for each x in MyArray 
    ss=ss+ 1
next

dim k
dim sglw,koor,ddx,coor
dim ayir,dd,adayir,dd2
dim objetur,objead

for k=1 to ss-1
sglw= MyArray(k)
koor= replace(sglw,"</coordinates>","<coordinates>")
koor= replace(koor,"<coordinates>","½")
ddx=Split(koor, "½", -1,0)
coor= ddx(1)

adayir=replace(sglw,"</name>","½")
dd2=Split(adayir, "½", -1,0)
objead= dd2(0)
objead= replace(objead,"<name>","")

ayir=replace(sglw,"</coordinates>","½")
dd=Split(ayir, "½", -1,0)

objetur= dd(1)
objetur= replace(objetur, "</","")
objetur= replace(objetur, ">","")

dim hayr,c1,c2
set c1 = .newc(0,0,0)
set c2 = .newc(0,0,0)
dim ey,ssx
ey=Split(coor, " ", -1,0)
ssx=0
for each x in ey
    ssx=ssx+ 1
next
dim noktasay
noktasay=ssx-1

if objetur="Point" then
hayr=Split(coor, ",", -1,0)
c1.y=hayr(0)
c1.x=hayr(1)
.AddObject .MakePoint(c1, objead,"SAGUL" ,0)
end if

if objetur="LineString" then
if noktasay=2 then objetur="Line"
if noktasay>2 then objetur="LineString"
end if

dim alanolustur,ssxd ,zong,hayrs
if objetur="Polygon" then
set alanolustur = nothing
set alanolustur = .newpoly
hayr=replace(coor," ","½")
hayr=Split(hayr, "½", -1,0)
ssxd=0
for each x in hayr
    ssxd=ssxd+ 1
next
noksa=ssxd-1
for zong=0 to noksa-1
deger=hayr(zong)
hayrs=Split(deger, ",", -1,0)
alanolustur.addcoor(.newc(hayrs(0),hayrs(1),hayrs(2)))
next
.AddObject .MakePline(objead, polyclosed+polyfilled+16, "5000", .createlayer("alan",7),0, 0, alanolustur)
end if

if  objetur="LineString" then
set alanolustur = nothing
set alanolustur = .newpoly
hayr=replace(coor," ","½")
hayr=Split(hayr, "½", -1,0)
ssxd=0
for each x in hayr
    ssxd=ssxd+ 1
next
noksa=ssxd-1
for zong=0 to noksa-1
deger=hayr(zong)
hayrs=Split(deger, ",", -1,0)
alanolustur.addcoor(.newc(hayrs(0),hayrs(1),hayrs(2)))
next
.AddObject .MakePline(objead, polyfilled, "5000", .createlayer("alan",7),0, 0, alanolustur)
end if

if  objetur="Line" then
hayr=replace(coor," ",",")
hayr=Split(hayr, ",", -1,0)
c1.y=hayr(0)
c1.x=hayr(1)
c2.y=hayr(3)
c2.x=hayr(4)
.AddObject .Makeline(c1,c2,0,0,0)
end if

next

dim pc
set pc = Netcad.NewProjection
 pc.ProjectionType =1
 pc.Datum = 0
 pc.SetToCurrentProject false

if kaydedilsin=1 then
       .SaveToFile(kayityeri)
 end if

.findworld
End with
exit sub

if k1=0 then k1=1
if k1=1 then k1=3
if k1=2 then k1=2
if k2=0 then k2=0
if k2=0 then k2=4
if k2=0 then k2=1
if k1=0 then k2=0

 pc.ProjectionType =k2
 pc.Datum = k1
 pc.Zone = k3
 pc.SetToCurrentProject True

set pc = Netcad.NewProjection
''Dikkat : Datum listesine aşağıdaki adresten ulaşabilirsiniz.
           '  https://sabangul.com.tr/nc-pro-datum
'' Projeksiyon Ayarı
'' Burada projeksiyon için bir kod giriniz
'' Örnek: UTM 3 için 3 giriniz. UTM 6 için 2 giriniz. Coğrafi için 1 giriniz.
 pc.ProjectionType =3
'' Datum Ayarı
'' Burada datum için bir kod giriniz
'' Örnek: ITRF için 1, ED50 için 4 , WGS için 0 giriniz.
pc.Datum = 1
 '' Dilim Ayarı
'' Burada dilim için bir kod giriniz
'' Örnek: Ankara için 33 girin, Siirt için 42 girin.
 pc.Zone = 42
 pc.SetToCurrentProject true     ' projenin dönüşmesini engellemek için konuldu
End Sub