KML Dosyasına Dönüştürme Makrosu (Convert to KML File 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.
' DİKKAT'
'GIS BAĞLANTI ANAHTARI SİLİNİR YERİNE HESAP ALANI YAZILIR!!!

Sub Main
  with Netcad

 Dim kmladres
kmladres="C:\SAGULCAD\netcadkml\sagul_kml_"& replace(replace(replace(now,":","_")," ","-"),".","_") &".kml"
 dim voice
 Set voice = CreateObject("SAPI.SpVoice")


 .SetParam PNC_PLINENAME, 1
 .SetParam PNC_PLINEHATCHS, 0
 .SetParam PNC_PNTNAMES, 1

Const ForReading = 1, ForWriting = 2, ForAppending = 8
 Dim fso, objFolder,f

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

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

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


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

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


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



dim dosyaoku,frs ,eyups
 Set fso = CreateObject("Scripting.FileSystemObject")
 Set frs = fso.OpenTextFile("C:\SAGULCAD\netcad_modul\Makro\Tanimlar\kmloku.sagul", ForReading, True)




Do While Not frs.AtEndOfStream
 dosyaoku= Split(frs.ReadLine,",")
 Loop



  on error resume next

dim xfsot,xft
 if InStr(dosyaoku(0), ",") <> 0 then
 MsgBox "İlk Kurulum Hatası Oluştu. Sizin İçin Otomatik Düzelteceğiz",64,"Dikkat"
  MsgBox "Düzeltme İşlemi Tamam. Lütfen Makroyu yeniden başlatınız",64,"Dikkat"
 Set xfsot = CreateObject("Scripting.FileSystemObject")
 Set xft = xfsot.OpenTextFile("C:\SAGULCAD\netcad_modul\Makro\Tanimlar\kmloku.sagul", ForWriting, True)

xft.WriteLine ( 2 & "," & 2 & "," & 1 & "," & 1 & "," & "C:\"  )
 xft.close
 exit sub
 end if



frs.Close

 dim oto
 oto= "C:\SAGULCAD\netcad_modul\NCZYEDEK\COGRAFI_sagul_"& replace(replace(replace(now,":","_")," ","-"),".","_") & ".ncz"
 .SaveToFile oto
 .LoadFile oto  , fs_bnetcad


    With Netcad
    dim iiii,coklu1ii
        For iiii = 0 to .numobject - 1
            Set coklu1ii = .getobject(iiii)
            if coklu1ii.tag = opline then
                  coklu1ii.objname = coklu1ii.area
                  .putobject iiii, coklu1ii
            end if
        Next
    End With

 
voice.Rate = 2
voice.Volume = 100
voice.speed=0.5
Say = "lutfen Back-lee-in"
If (Len(Say) > 0) Then
    voice.Speak Say
End If 

with netcad
'' 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.
dim pc
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 =1
'' 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 = 0
 '' Dilim Ayarı
'' Burada dilim için bir kod giriniz
'' Örnek: Ankara için 33 girin, Siirt için 42 girin.
 pc.SetToCurrentProject true  ' projenin dönüşmesini engellemek için konuldu
 end with

'.SetToCurrentProject(ConvertObjects)

voice.Speak Say
.NetcadCommand "PROJECT CLEAN 1,1,1,1,1,1"
voice.Speak Say
  Dim secimkumesi,obje,i,z,dic
  set secimkumesi = .newselectionset
  set obje=.newobject


dim tabsay
dim k
tabsay=NCLayerManager.NumLayer




netcad.netcadcommand "REGEN"
Say = "Google Earth a aktarilacak obje sechen"
voice.Speak Say
  if secimkumesi.select("Google Earth'e Aktarılacak Dosya Seçiniz ( Şaban GÜL , www.sagul.net )",array(opline,oline,otext,opoint)) then


dim list
Set list = CreateObject("System.Collections.ArrayList")
list.Add "<kml xmlns=" & """" & "http://earth.google.com/kml/2.0" & """" & ">"
list.Add "<Document>"

dim ks
 dim tabrenk
  Dim rengi

  list.Add "- <Style id=½default5½>"
list.Add "- <IconStyle>"
list.Add "  <color>00999999</color>"
list.Add "  </IconStyle>"
list.Add "- <LabelStyle>"
list.Add "  <color>00999999</color>"
list.Add "  </LabelStyle>"
list.Add "- <LineStyle>"
list.Add "  <color>ff000000</color>"
list.Add "  </LineStyle>"
list.Add "- <PolyStyle>"
list.Add "  <color>ab0055ff</color>"
list.Add "  </PolyStyle>"
list.Add "- <Pair>"
list.Add "  <key>normal</key>"
list.Add "  <styleUrl>#style0</styleUrl>"
list.Add "  </Pair>"
list.Add "- <Pair>"
list.Add "  <key>highlight</key>"
list.Add "  <styleUrl>#style</styleUrl>"
list.Add "  </Pair>"
list.Add "  </Style>"
list.Add "- <StyleMap id=½default50½>"
list.Add "- <Pair>"
list.Add "  <key>normal</key>"
list.Add "  <styleUrl>#default51</styleUrl>"
list.Add "  </Pair>"
list.Add "- <Pair>"
list.Add "  <key>highlight</key>"
list.Add "  <styleUrl>#default5</styleUrl>"
list.Add "  </Pair>"
list.Add "  </StyleMap>"
list.Add "- <Style id=½default51½>"
list.Add "- <IconStyle>"
list.Add "  <color>00999999</color>"
list.Add "  </IconStyle>"
list.Add "- <LabelStyle>"
list.Add "  <color>00999999</color>"
list.Add "  </LabelStyle>"
list.Add "- <LineStyle>"
list.Add "  <color>ff000000</color>"
list.Add "  </LineStyle>"
list.Add "- <PolyStyle>"
list.Add "  <color>ab0055ff</color>"
list.Add "  </PolyStyle>"
list.Add "- <Pair>"
list.Add "  <key>normal</key>"
list.Add "  <styleUrl>#style0</styleUrl>"
list.Add "  </Pair>"
list.Add "- <Pair>"
list.Add "  <key>highlight</key>"
list.Add "  <styleUrl>#style</styleUrl>"
list.Add "  </Pair>"
list.Add "  </Style>"






list.Add "<Folder>"
list.Add "<name>Sagulnet GE</name>"
list.Add "<ScreenOverlay>"
list.Add "<name>www.sagul.net</name>"
list.Add "<visibility>1</visibility>"
list.Add "<Icon>"
list.Add "<href>https://sagul.net/wp-content/uploads/2019/01/sagulnet.png</href>"
list.Add "</Icon>"
list.Add "<overlayXY x=½0½ y=½1½ xunits=½fraction½ yunits=½fraction½/>"
list.Add "<screenXY x=½0½ y=½1½ xunits=½fraction½ yunits=½fraction½/>"
list.Add "<size x=½0½ y=½0½ xunits=½pixels½ yunits=½pixels½/>"
list.Add "</ScreenOverlay>"



for k=0 to tabsay-1

tabrenk=  NCLayerManager.layer(k).colorBGR

rengi = Hex(tabrenk)

list.add "<Folder><name>" & NCLayerManager.Layer(k).name & "</name>"
dim kk
kk=0

        for i=0 to secimkumesi.NE-1
            z=secimkumesi.getselectedobject(i,obje)
            if obje.tabaka=k then
                    if obje.tag=opline then
                    kk=kk+1
                    list.add "<Placemark>"
                    list.add "<name>"& obje.pname & "</name>"
                    list.add "<description>"
                    dim tbksi

                    with ncLayermanager

                    tbksi=NCLayerManager.layer(obje.tabaka).name
                     end with


list.Add "<![CDATA[ "
list.Add "<table style=½height: 26px; width: 267px; border-color: #C0C0C0;½ border=½1½ cellspacing=½0½ cellpadding=½0½>"
list.Add "<tbody>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Parsel No</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&obje.pname&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Tabaka</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&tbksi&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Renk Kodu</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&obje.renk&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Gis Sinifi</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&obje.cls&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Tapu Alani</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&round(obje.tarea,2)&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Hesap Alani</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&round(obje.objname,2)&"</td>"
list.Add "</tr>"
list.Add "<tr style=½height: 23px;½>"
list.Add "<td style=½width: 95px; height: 23px;½> Alan Farki</td>"
list.Add "<td style=½width: 158px; height: 23px;½> "&round(obje.tarea-obje.objname,2)&"</td>"
list.Add "</tr>"
list.Add "</tbody>"
list.Add "</table>"
list.Add ""
list.Add "<img src=½https://sagul.net/wp-content/uploads/2019/01/sagulnet.png½>"
list.Add "  ]]>"







                    list.add "</description>"
                    list.add "<styleUrl>#default50</styleUrl>"
                    list.add "<visibility>1</visibility>"

                    'list.add "<Style><LineStyle><color>" & rengi & "</color></LineStyle><PolyStyle><color>"& rengi & "</color></PolyStyle></Style>"
                    list.add "<Polygon>"
                    list.add "<tessellate>1</tessellate>"
                    list.add "<extrude>1</extrude>"
                    list.add "<outerBoundaryIs>"
                    list.add "<LinearRing>"
                    list.add "<coordinates>"
                    dim saban,say,pline
                    say=""
                    set pline=obje.getObjectAsPline()
                    for saban=0 to pline.Num-1
                     say= say & pline.Cor(saban).y  & "," & pline.Cor(saban).x & ",0 "
                    next
                    say=mid(say,1,len(say)-1)
                    list.add say
                    list.add "</coordinates>"
                    list.add "</LinearRing>"
                    list.add "</outerBoundaryIs>"
                    list.add "</Polygon>"
                    list.add "</Placemark>"
                    end if

                    if obje.tag=oline then
                    kk=kk+1

                    list.add "<Placemark>"
                    list.add "<name>sagul_cizgi</name>"
                    list.add "<description>"&" Çizgi Uzunluğu Hesabı Bu Sürümde Yoktur. Güncellemelerde Gelecektir." &"</description>"
                    list.add "<styleUrl>#inline</styleUrl>"
                    list.add "<LineString>"
                    list.add "<tessellate>1</tessellate>"
                    list.add "<coordinates>" & obje.p1.y & "," & obje.p1.x & ",0 " &obje.p2.y & "," & obje.p2.x & ",0" & "</coordinates>"
                    list.add "</LineString>"
                    list.add "</Placemark>"

                    end if

                    if obje.tag=otext then
                    list.add "<Placemark>"
                    list.add "<name>"& obje.s &

"</name>"
                    list.add "<description>" & obje.s & "</description>"
                    list.add "<styleUrl></styleUrl>"
                    list.add "<Point>"
                    list.add "<gx:drawOrder>1</gx:drawOrder>"
                    list.add "<coordinates>"&obje.p1.y & "," & obje.p1.x & ",0</coordinates>"
                    list.add "</Point>"
                    list.add "</Placemark>"
                    kk=kk+1
                    end if

                    if obje.tag=opoint then
                    list.add "<Placemark>"
                    list.add "<name>"& obje.pname &"</name>"
                    list.add "<description>" & obje.pname & "</description>"
                    list.add "<styleUrl>#msn_open-diamond</styleUrl>"
                    list.add "<Point>"
                    list.add "<gx:drawOrder>1</gx:drawOrder>"
                    list.add "<coordinates>"&obje.p1.y & "," & obje.p1.x & ",0</coordinates>"
                    list.add "</Point>"
                    list.add "</Placemark>"
                    kk=kk+1
                    end if
            end if
        next
if kk=0 then list(list.count-1)=""
if kk>0 then list.add "</Folder>"
            ' .putobject z,obje
Next

list.Add "</Folder>"
list.Add "</Document>"
list.Add "</kml>"
End if



Dim fsot, ft
Set fsot = CreateObject("ADODB.Stream")
fsot.CharSet = "utf-8"
fsot.Type = 2
'Set fsot = CreateObject("Scripting.FileSystemObject") 'sistem objesi oluştur

'Set fsot = CreateObject("VBScript.Regexp")
'fsot.Pattern = "[^a-z0-9\ç\ğ\i\ı\ö\ş\ü\Ğ\Ü\İ\Ş\Ç\Ö\ ]"
'fsot.Charset = "ISO-8859-1"
'fsot.Charset = "utf-8"
'fsot.Global = True
'Set ft = fsot.OpenTextFile(kmladres, ForWriting, True) ' dosya kaydetme işlemi
'ft.Charset = "utf-8"
'ft.Pattern = "[^a-z0-9\ç\ğ\i\ı\ö\ş\ü\Ğ\Ü\İ\Ş\Ç\Ö\ ]"
 Set fsot = CreateObject("ADODB.Stream")
fsot.Open
fsot.Type     = 2 'text
fsot.Position = 0
fsot.Charset  = "utf-8"


dim sagul,yazdirsgl
for sagul=0 to list.count-1
yazdirsgl=replace(list(sagul),"½","""")
fsot.WriteText yazdirsgl
'ft.WriteLine yazdirsgl
next
list.clear
fsot.SaveToFile kmladres, 2
fsot.close
end with

 with Netcad
.NetcadCommand "CLOSE ACTIVEPROJECT"

end with
Say = "tamam"
    voice.Speak Say
dim strProgramPath,objShell
'msgbox "İşlem Başarıyla Tamamlandı"



dim objxx
Set objxx = CreateObject("Scripting.FileSystemObject") 'Calls the File System Object
objxx.DeleteFile(oto) 'Deletes the file throught the DeleteFile function


voice.Rate = 0.5
voice.Volume = 100
voice.speed=0.5
Say = "sagul nokta nettt"
If (Len(Say) > 0) Then
    voice.Speak Say
End If 
if secimkumesi.NE=0 then
exit sub
end if


strProgramPath = kmladres
set objShell = createobject("Wscript.Shell")
objShell.Run strProgramPath




End Sub