Netcad kod kaydet / txt ayraç – csvli

\' Şaban GÜL Tarafından Üretilmiştir
\' Daha Fazlası İçin: www.sabangul.com
\' Hata, İstek ve Öneriler İçin: sabangul67@gmail.com
\' Makro: Obje ve Proje Bilgilerini Sade TXT’ye Aktarma

Option Explicit

Function FixDecimal(value, digits)
  Dim result
  result = FormatNumber(value, digits, -1, 0, 0)
  result = Replace(result, \",\", \"\")
  FixDecimal = result
End Function

Sub Main
  Dim secim, obj, ploy
  Dim fso, f
  Dim dosya_yolu, proje_adi, proje_yolu
  Dim tarih, saat
  Dim tabaka, layer
  Dim i, j, k
  Dim dialog

  Set fso = CreateObject(\"Scripting.FileSystemObject\")
  dosya_yolu = \"C:\\Kamupratik\\BEYANNAME\\Rapor.txt\"

  Set dialog = Netcad.NewBDialog(\"Rapor Kaydetme [sabangul.com]\")
  dialog.PutPrompt \"TXT dosya yolunu girin. Daha Fazlası: www.sabangul.com\"
  dialog.GetString \"dosya_yolu\", \"Dosya Yolu:\", dosya_yolu, 100

  If Not dialog.ShowModal Then
    MsgBox \"İptal edildi.\", vbCritical, \"Hata [sabangul.com]\"
    Exit Sub
  End If

  dosya_yolu = dialog.ValueByName(\"dosya_yolu\")

  If Not fso.FolderExists(fso.GetParentFolderName(dosya_yolu)) Then
    On Error Resume Next
    fso.CreateFolder fso.GetParentFolderName(dosya_yolu)
    If Err.Number <> 0 Then
      MsgBox \"Klasör oluşturulamadı: \" & dosya_yolu & vbCrLf & \"Hata: \" & Err.Description, vbCritical, \"Hata [sabangul.com]\"
      Exit Sub
    End If
    On Error GoTo 0
  End If

  Set f = fso.OpenTextFile(dosya_yolu, 2, True)

  tarih = FormatDateTime(Date, vbShortDate)
  saat = FormatDateTime(Time, vbShortTime)
  proje_adi = Netcad.GetParam(250)
  proje_yolu = Netcad.GetParam(251)
  f.WriteLine \"Proje Bilgileri\"
  f.WriteLine \"Rapor Tarihi,\" & tarih & \" \" & saat
  f.WriteLine \"Proje Adı,\" & proje_adi
  f.WriteLine \"Proje Yolu,\" & proje_yolu

  With Netcad
    Set layer = NcLayerManager
    Set secim = .NewSelectionSet
    If secim.Select(\"Objeleri seçin. Bitirmek için sağ tıklayın.\", Array(7, 2, 1, 5, 3, 6, 4, 8, 9, 10, 11)) Then
      Dim tipler, basliklar, yazilan
      tipler = Array(7, 2, 1, 5, 3, 6, 4, 8, 9, 10, 11, -1)
      basliklar = Array( _
        \"###COKLUDOGRU###\", \"###CIZGI###\", \"###NOKTA###\", \"###YAZI###\", _
        \"###DAIRE###\", \"###SEMBOL###\", \"###YAY###\", \"###SPIRAL###\", _
        \"###IZOHIPS###\", \"###KUTU###\", \"###PAFTA###\", \"###BILINMEYEN###\" _
      )
      Set yazilan = CreateObject(\"Scripting.Dictionary\")

      For i = 0 To secim.NE - 1
        Set obj = .NewObject
        j = secim.GetSelectedObject(i, obj)

        If obj.tabaka >= 0 And obj.tabaka < .NumLayers Then
          tabaka = layer.Layer(obj.tabaka).Name
        Else
          tabaka = \"Bilinmeyen Tabaka\"
        End If

        Dim tip_idx
        Select Case obj.Tag
          Case 7: tip_idx = 0
          Case 2: tip_idx = 1
          Case 1: tip_idx = 2
          Case 5: tip_idx = 3
          Case 3: tip_idx = 4
          Case 6: tip_idx = 5
          Case 4: tip_idx = 6
          Case 8: tip_idx = 7
          Case 9: tip_idx = 8
          Case 10: tip_idx = 9
          Case 11: tip_idx = 10
          Case Else: tip_idx = 11
        End Select

        If Not yazilan.Exists(tip_idx) Then
          f.WriteLine basliklar(tip_idx)
          Select Case tipler(tip_idx)
            Case 7
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Adı,Kalınlık,Çizgi Tipi,Çevresi (m),Tapu Alanı (m²),Hesap Alanı (m²)\"
            Case 2
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Adı,Kalınlık,Çizgi Tipi,Uzunluğu (m),Başlangıç X,Başlangıç Y,Bitiş X,Bitiş Y\"
            Case 1
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Adı,Nokta Kodu,X Koordinatı,Y Koordinatı,Z Koordinatı\"
            Case 5
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Yazı Metni,X Koordinatı,Y Koordinatı,Açı (Grad),Genişlik Çarpanı,Yazı Boyu,Dayanma,Özellikler\"
            Case 3
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Merkez X,Merkez Y,Merkez Z,Yarıçap,Alan (m²)\"
            Case Else
              f.WriteLine \"Index,Tabaka,GIS Sınıfı,GIS Kodu,Obje Türü\"
          End Select
          yazilan.Add tip_idx, True
        End If

        Dim satir
        satir = j & \",\" & tabaka & \",\" & obj.cls & \",\" & Left(obj.objname, 50)

        Select Case obj.Tag
          Case 7
            Set ploy = obj.GetObjectAsPline()
            satir = satir & \",\" & Left(obj.pname, 50) & \",\" & obj.w & \",\" & obj.lt & \",\" & _
                    FixDecimal(obj.length(0), 3) & \",\" & FixDecimal(obj.tarea, 3) & \",\" & FixDecimal(obj.area, 3)
            f.WriteLine satir
            f.Write \"Köşe Noktaları\"
            For k = 0 To ploy.num - 1
              If k > 0 Then f.Write \"#\"
              f.Write FixDecimal(ploy.cor(k).y, 3) & \"$\" & FixDecimal(ploy.cor(k).x, 3)
            Next
            f.WriteLine \"\"
            Set ploy = Nothing
          Case 2
            satir = satir & \",\" & Left(obj.pname, 50) & \",\" & obj.w & \",\" & obj.lt & \",\" & _
                    FixDecimal(obj.length(0), 3) & \",\" & FixDecimal(obj.p1.x, 3) & \",\" & _
                    FixDecimal(obj.p1.y, 3) & \",\" & FixDecimal(obj.p2.x, 3) & \",\" & FixDecimal(obj.p2.y, 3)
            f.WriteLine satir
          Case 1
            satir = satir & \",\" & Left(obj.pname, 50) & \",\" & obj.pcode & \",\" & _
                    FixDecimal(obj.p1.x, 3) & \",\" & FixDecimal(obj.p1.y, 3) & \",\" & FixDecimal(obj.p1.z, 3)
            f.WriteLine satir
          Case 5
            satir = satir & \",\" & Left(obj.s, 50) & \",\" & FixDecimal(obj.p1.x, 3) & \",\" & _
                    FixDecimal(obj.p1.y, 3) & \",\" & FixDecimal(obj.angle, 3) & \",\" & _
                    FixDecimal(obj.wsc, 3) & \",\" & FixDecimal(obj.sc, 3) & \",\" & _
                    obj.just & \",\" & obj.flags
            f.WriteLine satir
          Case 3
            satir = satir & \",\" & FixDecimal(obj.p1.x, 3) & \",\" & FixDecimal(obj.p1.y, 3) & \",\" & _
                    FixDecimal(obj.p1.z, 3) & \",\" & FixDecimal(obj.rad, 3) & \",\" & _
                    FixDecimal(3.1415926535 * obj.rad * obj.rad, 3)
            f.WriteLine satir
          Case Else
            satir = satir & \",\" & \"Bilinmeyen (\" & obj.Tag & \")\"
            f.WriteLine satir
        End Select
      Next
      MsgBox \"Rapor \'\" & dosya_yolu & \"\' kaydedildi.\", vbInformation, \"Başarılı [sabangul.com]\"
    Else
      MsgBox \"Obje seçilmedi. İptal edildi.\", vbExclamation, \"Hata [sabangul.com]\"
    End If
    Set secim = Nothing
    Set obj = Nothing
  End With

  f.Close
  Set fso = Nothing
  Set f = Nothing
  Set dialog = Nothing
  Set layer = Nothing
  Set ploy = Nothing
End Sub