Alan Adını Parçala ve Ortasını Al

' Opline Alan Adından İlk ve Son Ayraç Arasını Alma Makrosu
' Açıklama: Kullanıcıdan seçilen opline (alan) objelerinin pname özelliğinde, kullanıcı tarafından belirtilen bir karakter (örn. /) iki veya daha fazla kez geçiyorsa, ilk ayraç ve öncesini, son ayraç ve sonrasını siler, sadece ortadaki kısmı bırakır. Örneğin, pname = "101/1/A" ise, ilk / ve öncesi (101), son / ve sonrası (A) silinir, pname = "1" olur. Tek ayraç veya ayraç yoksa işlem yapılmaz. Ayraç karakteri C:\sabangul\NCMAKRO\AYAR\ayrac.txt dosyasına kaydedilir ve sonraki çalıştırmalarda buradan okunur.
' Yazar: Şaban Gül
' Tarih: 18 Mayıs 2025

Option Explicit

Sub Main
    Dim i, j, o, SEL, u, ayrac, fso, dosya, dosyaYolu
    Const AYAR_DIZINI = "C:\sabangul\NCMAKRO\AYAR"
    Const AYAR_DOSYASI = "ayrac.txt"
    dosyaYolu = AYAR_DIZINI & "\" & AYAR_DOSYASI

    With Netcad
        ' Dosya sistemi nesnesi oluştur
        Set fso = CreateObject("Scripting.FileSystemObject")

        ' Ayar dosyasını oku
        ayrac = "/"
        If fso.FileExists(dosyaYolu) Then
            Set dosya = fso.OpenTextFile(dosyaYolu, 1) ' 1 = okuma
            If Not dosya.AtEndOfStream Then
                ayrac = dosya.ReadLine
            End If
            dosya.Close
        End If

        ' Kullanıcıdan ayracı al (varsayılan: dosya veya /)
        ayrac = InputBox("Hangi karakterle ayırıp ortasını alalım? (örn. /)", "Karakter Seçimi", ayrac)
        If ayrac = "" Then Exit Sub ' Boş veya iptal edilirse çık

        ' Ayar dosyasını güncelle
        If Not fso.FolderExists(AYAR_DIZINI) Then
            fso.CreateFolder AYAR_DIZINI
        End If
        Set dosya = fso.CreateTextFile(dosyaYolu, True) ' True = üzerine yaz
        dosya.WriteLine ayrac
        dosya.Close

        Set SEL = .NewSelectionSet
        Set o = .NewObject
        If SEL.Select("Alan objelerini seçiniz", Array(opline)) Then
            For i = 0 To SEL.NE - 1
                j = SEL.GetSelectedObject(i, o)
                AdDuzelt o, ayrac
                .PutObject j, o
            Next
            SEL.RedrawAndRewind
            Set u = .GetCurrentWindow
            .SetCurrentWindow u, 1
        End If
        Set u = Nothing
        Set SEL = Nothing
        Set o = Nothing
        Set fso = Nothing
        Set dosya = Nothing
    End With
End Sub

Sub AdDuzelt(o, ayrac)
    If o.Tag = opline Then ' Sadece opline objeleri için çalış
        Dim parcalar, yeniAd, i
        parcalar = Split(o.pname, ayrac)
        If UBound(parcalar) >= 2 Then ' İki veya daha fazla ayraç varsa
            yeniAd = ""
            For i = 1 To UBound(parcalar) - 1
                If i > 1 Then yeniAd = yeniAd & ayrac
                yeniAd = yeniAd & parcalar(i)
            Next
            o.pname = yeniAd
        End If
    End If
End Sub