Yayınladığım tüm makaleler

VBA kod renklendirici (Code Highlighter)

VBA kod renklendirici (Code Highlighter)

Merhaba, bu uygulamamızda sizlerle birlikle VBA kodları içeren bir metin dosyasındaki kodları okuyarak bu kodun içerisinde bulunan ve programlama dili için ayrılmış kelimeler olarak isimlendirilen kelimeleri ayıklayarak onları renklendirip tüm içeriği bir web sayfasına aktaracağız.

  1. Her daim olduğu gibi evvela yeni bir belge açıyor ve makro güvenlik düzeyini düşük olarak ayarlıyoruz.  Nasıl yapılacağını hatırlamak için yine  her zaman olduğu gibi bu bağlantıyı kullanabilirsiniz.
  2. Sonrasında aşağıda verilen ekran çıktısını belgenize uyguluyorsunuz.  Web sayfası ve css dosyasının kaydedileceği sürücüyü belirlemek için ComboBox yani açılan kutu muhtelif sair işlemler için de 3 adet CommandButton nesnesi eklemeniz gerekiyor. Nesnelerin name ve Caption özellikleri aşağıda verilmiştir. Açılan kutunun değerleri ise belge açılırken kod ile yükletilecektir. Ayrıca çalışmamızda iki adet de çizim araç çubuğu yardımıyla ya da Ekle mönüsü yardımıyla ekleyebileceğiniz metin kutusu bulunmaktadır. Kesinlikle ifade etmeliyim ki bunlar birer TextBox değildir.

  1. Bu çalışmayı çalıştırırken dikkat edilmesi gereken en önemli nokta Windows7 ve üzeri kullanıcılarının dosya kayıt yeri olarak C: sürücüsünü seçmemeleri gerektiğidir. Çünkü Windows7 C: sürücüsü kök dizinde dosya yapmaya izin vermeyecek ve çalışmanız hata verecektir. Diğer bir ifade ile Win7 kullanıcıları ya C: sürücüsü dışında bir sürücü seçmeliler ya da MS Word uygulaması yönetici olarak çalıştırmalıdırlar. Şu gerzek windows ne gariptir, söz de siz izin vermeden dosya sistemi üzerinde yeni bir dosya yapmaya izin vermiyor niye yıllardır milleti virüs taramalarla tırmalattırdın o zaman? Kullanıcıya sadece kendi klasörü üzerinde işlem yapmaya izin verip dosya sistemi üzerindeki değişiklikleri bir şifreye bağlamak bu kadar zor muydu? Linux yıllardır yapıyor, milyar dolarlık şirket bunu yapamıyor. Neden? Cevap basit bizi kaz gibi yolup kuş gibi hafifletmek için...Her neyse
  2. Son olarak her zaman olduğu gibi aşağıda verilen kodları ALT+F11 ile görüntülenen VBA kod düzenleyicisinde yazıyor ve belgemizi kaydedip kapatıyoruz sonra yeniden açıyor ve deneme yapıyoruz. Sizlere verdiğim kaynak dosyada ihtiyacanız olan her şey var. Elbette sizde VBA kodları içeren farklı bir dosya ile denemelerinizi yapabilirsiniz. Burada sizlere aktardığım bu çalışma 2013-2014 eğitim öğretim yılında çalıştığım okulda öğrencilerimize atelye uygulaması olarak yaptırılmıştır. Elbette gözden geçirlmesi gereken hataları vardır, onları düzeltmek de artık size kalıyor.

Kaynak kodlar:


'Tanimlanmayan degiskenlerin kullanilmasina izin verme
Option Explicit
Dim metinDosyasi As String
Dim ozelKelimeler() As Variant

Private Sub btnCikis_Click()
'1. Acik belgeyi kaydetmeden cik
    Application.Quit wdDoNotSaveChanges
'2. Acik belgeyi kaydet ve  cik
'    Application.Quit wdSaveChanges
End Sub
Private Sub btnKaynakDosyaSec_Click()
Dim dosyaPenceresi As FileDialog, secilenDosya As Variant
Set dosyaPenceresi = ThisDocument.Application.FileDialog(msoFileDialogOpen)
With dosyaPenceresi
    'filterleri temizle
    .Filters.Clear
    'filtre ekle
    .Filters.Add "Metin dosyalari", "*.txt", 1
    .Filters.Add "Tüm dosyalar", "*.*", 2
    'taman dugmesine basilmissa
    If .Show = -1 Then
        'secilen her bir dosya icin ayni islemi yap
        For Each secilenDosya In .SelectedItems
            ThisDocument.Shapes(1).TextFrame.TextRange.Text = secilenDosya
            metinDosyasi = mutlakDosyaYolu(CStr(secilenDosya))
        Next
    End If
End With
Set dosyaPenceresi = Nothing
End Sub
Private Function mutlakDosyaYolu(kaynak As String) As String
'*****************************************************************************************************
'Kodlayan                   : Bilal SERT
'Amac                        : Dosya adindan istenmeyen karakterleri temizlemek
'Tarih/saat                 : 26.12.2013 / 10:55
'Giriş / Çıkış               : kaynak (dosya adını ve yolunu gosterir degisken) / yok
'Değiştiren                 :
'Tarih/Saat                :
'Amaç                       :
'*****************************************************************************************************
Dim sayac As Integer, sonuc As String
sonuc = ""
For sayac = 1 To Len(kaynak)
    If Asc(Mid(kaynak, sayac, 1)) <> 13 And Asc(Mid(kaynak, sayac, 1)) <> 7 Then
        sonuc = sonuc & Mid(kaynak, sayac, 1)
    End If
Next
mutlakDosyaYolu = sonuc
End Function
Private Sub btnOku_Click()
Dim dosSis, dosya, webSayfasi As Object, sayac, durum, kontrolBitti As Boolean
Dim satir, htmlSatiri, hedefHTML, hedefCSS As String, kelimeler() As String 'kelimeler dizisi
Dim kelime, eleman As Variant
Const ForReading = 1, TristateFalse = 0
If metinDosyasi <> "" Then
hedefHTML = ComboSuruculer.Text & Trim("\exported.html")
hedefCSS = ComboSuruculer.Text & Trim("\codeView.css")
'İkinci paragraftan son paragrafa kadar olan bolum siliniyor
With ThisDocument
    If .Paragraphs.Count > 3 Then
        .Range(.Paragraphs(4).Range.Start, .Paragraphs(.Paragraphs.Count).Range.End).Delete
    End If
    'Yeni bir paragraf ekleniyor
    .Paragraphs.Add
End With
'Metin dosyasina erismek icin dosya sistemi olusturuluyor
Set dosSis = CreateObject("Scripting.FileSystemObject")
'CSS dosyasi olusturuluyor
If dosSis.FileExists(hedefCSS) Then
    dosSis.DeleteFile hedefCSS, True 'silmeye zorluyoruz
End If
On Local Error GoTo hata
Set webSayfasi = dosSis.CreateTextFile(hedefCSS, True)
With webSayfasi
 .writeLine ("    .rezerve{")
 .writeLine ("        color:#0066FF;")
 .writeLine ("    }")
 .writeLine ("    .aciklama{")
 .writeLine ("        color:#006600;")
 .writeLine ("    }")
 .writeLine ("    .standart{")
 .writeLine ("         color:#333333;")
 .writeLine ("    }")
 .writeLine ("    .codeBlogu{")
 .writeLine ("        background-color:#F8F5FF;")
 .writeLine ("        border:1px dashed #999999;")
 .writeLine ("        width:95%;")
 .writeLine ("        height:60%;")
 .writeLine ("        overflow:scroll;")
 .writeLine ("    }")
 .Close
End With
Set webSayfasi = Nothing
'Kaynak metin dosyasi aciliyor.
On Local Error GoTo hata
Set dosya = dosSis.OpenTextFile(metinDosyasi, ForReading, TristateFalse)
'HTML aktarim yapilacak dosya olusturuluyor
If dosSis.FileExists(hedefHTML) Then
    dosSis.DeleteFile hedefHTML, True 'silmeye zorluyoruz
End If
On Local Error GoTo hata
Set webSayfasi = dosSis.CreateTextFile(hedefHTML, True)
webSayfasi.writeLine ("< html> ")
webSayfasi.writeLine ("< head>< title> " & Format(Now, "dd/mm/yyyy-hh:mm:ss") & "::. ")
webSayfasi.writeLine ("< link href=" & Chr(34) & "codeView.css" & Chr(34) & "rel=" & Chr(34) & _
"stylesheet" & Chr(34) & "type=" & Chr(34) & "text/css" & Chr(34) & "/>")
webSayfasi.writeLine ("")
webSayfasi.writeLine ("< body>")
webSayfasi.writeLine ("< p class='codeBlogu'>")
With dosya
    Do While .AtEndOfStream <> True
        satir = .ReadLine: kontrolBitti = False
        'bu noktada lexical analysing islemi yapilacak
        If Left(satir, 1) = "'" Then
            webSayfasi.writeLine ("< span class='aciklama'>" & satir & "  
")
        Else 
            kelimeler = Split(satir, " ")
            htmlSatiri = ""
            For Each kelime In kelimeler
                If kelime = " " Then
                    'bosluk olup olmadigi sorgulaniyor
                    htmlSatiri = htmlSatiri & " "
                Else
                    If Not kontrolBitti Then
                        'rezerve edilmis kelime olup olmadigi sorugulaniyor
                        durum = False
                        For Each eleman In ozelKelimeler
                            If LCase(eleman) = LCase(kelime) Then
                                durum = True
                                Exit For
                            End If
                        Next
                        If durum Then
                            htmlSatiri = htmlSatiri & "< span class='rezerve'>" & kelime & " "
                        Else
                            If Left(kelime, 1) = "'" Then
                                htmlSatiri = htmlSatiri & "< span class='aciklama'>" & kelime & " "
                                kontrolBitti = True
                            Else
                                htmlSatiri = htmlSatiri & "< span class='standart'>" & kelime & " "
                            End If
                        End If 'ozel kelime kontrol
                    Else
                        htmlSatiri = htmlSatiri & kelime & " "
                    End If 'aciklama satirina dusuldu
                End If 'bosluk kontrol
            Next
            If kontrolBitti Then
                 webSayfasi.writeLine (htmlSatiri & "
")
            Else
                webSayfasi.writeLine (htmlSatiri & "< br />")
            End If
        End If 'aciklama kontrol
    Loop
    .Close
End With
webSayfasi.writeLine ("")
webSayfasi.writeLine ("")
webSayfasi.writeLine ("")
webSayfasi.Close
Set dosSis = Nothing
Set dosya = dosya
Set webSayfasi = Nothing
On Local Error GoTo hata
Shell "c:\windows\explorer.exe" & " " & ComboSuruculer.Text & Trim("\"), vbMaximizedFocus
Else
    MsgBox "Lütfen renklendirmek istediğiniz kodların bulunduğu dosyayı seçin", vbInformation + vbOKOnly, "Dikkat !"
End If
Exit Sub
hata:
    MsgBox "Dikkata hata oluştu " & vbCrLf & Err.Description, vbCritical + vbOKOnly, "Dikkat"
End Sub
Private Sub suruculeriListele()
'*****************************************************************************************************
'Kodlayan                   : Bilal SERT
'Amac                        : Sisteme bağl olan sürücüleri listemek
'Tarih/saat                 : 06.07.2014 17:17
'Giriş / Çıkış               : yok / yok
'Değiştiren                 :
'Tarih/Saat                :
'Amaç                       :
'*****************************************************************************************************
Dim dosSis, suruculer, surucu As Object
Set dosSis = CreateObject("Scripting.FileSystemObject")
Set suruculer = dosSis.Drives
    ComboSuruculer.Clear
    For Each surucu In suruculer
        On Error Resume Next
        ComboSuruculer.AddItem surucu.DriveLetter & Trim(":") ' & surucu.VolumeName
    Next
    If ComboSuruculer.ListCount <> 0 Then
        ComboSuruculer.ListIndex = 0
    End If
Set dosSis = Nothing
Set surucu = Nothing
Set suruculer = Nothing
End Sub

Private Sub Document_Open()
Dim eleman As Variant
    ozelKelimeler = Array("const", "dim", "redim", "as", "integer", "Boolean", _
    "Long", "Double", "flooat", "decimal", "Array", "public", "private", "import", _
    "sub", "end", "function", "if", "else", "then", "switch", "case", "with", "while", _
    "loop", "do", "until", "class", "set", "nothing", "true", "false", "Object", "variant", _
    "for", "next", "in", "each")
    'test ediyoruz
    With ThisDocument
        If .Paragraphs.Count > 3 Then
            .Range(.Paragraphs(4).Range.Start, .Paragraphs(.Paragraphs.Count).Range.End).Delete
        End If
        'Yeni bir paragraf ekleniyor
        .Paragraphs.Add
    End With
    ThisDocument.Content.InsertAfter "VBA kod renklendirici tarafından algılanan özel kelimeler :" & vbCrLf
    For Each eleman In ozelKelimeler
        ThisDocument.Content.InsertAfter eleman & ", "
    Next
    With ThisDocument
    .Paragraphs.Add
    .Paragraphs(.Paragraphs.Count).Range.Font.ColorIndex = wdRed
    .Paragraphs(.Paragraphs.Count).Range.Text = _
    "Bu doküman Bilal SERT tarafından eğitim amaçlı olarak hazırlanmıştır. [iletişim: bilisim@bilalsert.com.tr]"
    End With
    'sisteme bağlı olan sürücüler listeleniyor
    suruculeriListele
    'uyari bilgileri görüntüleniyor
    ThisDocument.Shapes(1).TextFrame.TextRange.Text = ""
    ThisDocument.Shapes(2).TextFrame.TextRange.Text = "Lütfen sonuç verilerinin kaydedileceği sürücüyü seçin"
End Sub

Yardımcı olması dileğiyle