Muharrem DOĞANCI: Word Dosyasından Bölüm Sonu (Quiz) Sorularını VBA, CSV ile PHPMyAdmin'e Yüklemek

11 Nisan 2023 Salı

Word Dosyasından Bölüm Sonu (Quiz) Sorularını VBA, CSV ile PHPMyAdmin'e Yüklemek

Aşırı görsel içeren soru yapılarında toplu yükleme en uygun yöntemdir.

Otomatik listeleri manuel metne dönüştürmek için:

Sub Otomatik_Liste_Donustur()

Dim i As Long

Application.ScreenUpdating = False
If ActiveDocument.Lists.Count = 0 Then 'Eğer otomatik liste sayısı 0 ise,
    MsgBox "Dokümanda otomatik liste yok.", vbInformation
End If
'Öncelikle, otomatik madde işaretçilerini bulup, çakışmayı engellemek için değişiklik yapalım.

Do While ActiveDocument.Lists.Count > 0
    ActiveDocument.Lists(1).Range.ListFormat.ConvertNumbersToText
    
    Selection.Find.ClearFormatting 'Arama değer kısmında, önceki aramadan kalmış ayar varsa biçimlendirmeyi sil.
    Selection.Find.Replacement.ClearFormatting 'Yeni değer kısmında, önceki aramadan kalmış ayar varsa biçimlendirmeyi sil.
    With Selection.Find 'Seçim içinde değişiklik için arama başlat.
        .Text = "^9" 'Tab, sekme boşluğunu bul.
        .Replacement.Text = " " 'Klavyedeki boşluğa çevir.
        .Forward = True
        .Wrap = wdFindStop 'Aramaya baştan başlansın mı? İletişim kutusunu ekrana getirme, zaten seçim içinde değişiklik istiyorum.
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True 'Joker arama aktif olmalı.
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    i = i + 1
    If ActiveDocument.Lists.Count = 0 Then 'Eğer otomatik liste sayısı 0 ise,
        MsgBox "Toplam " & i & " adet otomatik madde donusturuldu."
        Exit Do 'Döngüden çık.
    End If
Loop

Selection.Find.Text = ""
Selection.Find.ClearFormatting
Selection.Find.Replacement.Text = ""
Selection.Find.Replacement.ClearFormatting

Selection.Collapse 'Seçimi serbest bırak.
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
End Sub

Gereksiz paragrafları ve boşlukları temizlemek için:
⚠️ UYARI: belgenizde sekme (tab) boşluklarından oluşan bölümler varsa, kod uyarı verecektir. Bu tür boşluklarınız varsa o kısımları düzenledikten sonra boşluk silme işlemini uygulayınız. Aksi halde metinlerinizin hizaları bozulur.

Sub Bosluk_Sil()

Dim IslemOncesiSayfaSayisi As Long
Dim IslemSonrasiSayfaSayisi As Long
Dim BosTablo As Table

IslemOncesiSayfaSayisi = ActiveDocument.ComputeStatistics(wdStatisticPages)

Call Arama_Temizle

With Selection.Find
    .Text = "^9^9"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    .MatchCase = False
    .Execute
    If .Found = True Then
        Selection.Range.Select
        MsgBox "Belgede TAB ile olusturulmus tablo olabilir," & vbNewLine & _
            "dosyayi duzenledikten sonra isleme devam ediniz.", vbInformation
        Selection.Find.Text = ""
        Exit Sub
    End If
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^9"
    .Replacement.Text = " "
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^s"
    .Replacement.Text = " "
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = " [ ]@([! ])"
    .Replacement.Text = " \1"
    .MatchWildcards = True
    .Wrap = wdFindStop
    .Format = False
    .Forward = True
    .Execute Replace:=wdReplaceAll
End With

Call Arama_Temizle

For Each BosTablo In ActiveDocument.Tables
    BosTablo.Select
        If Len(Selection.Range.Text) <= 4 Then
            BosTablo.Delete
        End If
Next BosTablo

Call Arama_Temizle

With Selection.Find
    .Text = "^b"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^l"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^m"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^n"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = " ^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^p "
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

With Selection.Find
    .Text = "^p^p"
    .Replacement.Text = "^p"
    .Forward = True
    .Format = False
    .MatchWildcards = False
    Do While .Execute
        .Execute Replace:=wdReplaceAll
    Loop
End With

Call Arama_Temizle

IslemSonrasiSayfaSayisi = ActiveDocument.ComputeStatistics(wdStatisticPages)

MsgBox "Islem öncesi sayfa sayisi: " & IslemOncesiSayfaSayisi & vbNewLine & _
    "Islem sonrasi sayfa sayisi: " & IslemSonrasiSayfaSayisi & vbNewLine & _
    "Fark: " & IslemOncesiSayfaSayisi - IslemSonrasiSayfaSayisi, vbInformation

End Sub
Sub Arama_Temizle()

Selection.Collapse
Selection.Find.Text = ""
Selection.Find.ClearFormatting
Selection.Find.Replacement.Text = ""
Selection.Find.Replacement.ClearFormatting
Selection.HomeKey Unit:=wdStory

End Sub

Quiz ayıklamak için:
Makroda 1 ana kod bloğu, 5 adet ana koda bağlı alt fonksiyon vardır.

Dim FSO As FileSystemObject
Dim File As Object

Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim H1Sayisi As Long
Dim H2Sayisi As Long
Dim SoruID As Long
Dim UniteNo As Long
Dim SoruBasiKontrol As Long
Dim SoruSonuKontrol As Long
Dim Arr2Lr As Long
Dim Konum As Long
Dim Basla As Long
Dim Bitir As Long
Dim Basla2 As Long
Dim Bitir2 As Long

Dim Arr As Variant
Dim Arr2 As Variant
Dim AramaIfadeleri1 As Variant

Dim ArrLr As Boolean

Dim KaynakDosya As Document
Dim HedefDosya As Document

Dim Ayrac As String
Dim KaynakDizin As String
Dim DersID As String
Dim Etiketler As String
Dim Dizi() As String
Dim ArrCSV() As String
Dim Temp As String
Dim Temp2 As String
Dim Temp3 As String
Dim Temp4 As String
Dim HTMLIlk As String
Dim HTMLSon As String
Dim Soru As String
Dim ASikki As String
Dim BSikki As String
Dim CSikki As String
Dim DSikki As String
Dim ESikki As String
Dim DogruYanit As String

Dim DosyaSec As FileDialog

Dim BasTrh As Date
Dim BitTrh As Date

Sub Quiz_1_Ayikla()

Ayrac = Application.PathSeparator
Set FSO = New Scripting.FileSystemObject
Set DosyaSec = Application.FileDialog(msoFileDialogFilePicker)
With DosyaSec
    .AllowMultiSelect = False
    If .Show <> -1 Then
        Exit Sub
    End If
    KaynakDizin = .InitialFileName
    DersID = Split(DosyaSec.SelectedItems(1), Ayrac)(UBound(Split(DosyaSec.SelectedItems(1), Ayrac)))
    DersID = Split(DersID, ".")(0)
End With

SoruID = InputBox("PHP My Admin uzerinden girilen en son sorunun ID numarasindan +1 buyuklukte sayi giriniz")
If IsNumeric(SoruID) = False Then
    MsgBox "Lutfen bir tam sayi giriniz", vbInformation
    Exit Sub
End If

BasTrh = Now

Application.Visible = False
Application.ScreenUpdating = False

Set KaynakDosya = Application.Documents.Open(FileName:=DosyaSec.SelectedItems(1))

ReDim Arr(1 To 28, 1 To 2)
Call Quiz_2_Ara

If FSO.FolderExists(DosyaSec.InitialFileName & DersID) = False Then
    FSO.CreateFolder (DosyaSec.InitialFileName & DersID)
End If

For i = LBound(Arr) To UBound(Arr)
    If Temp = "" Then
        For j = 1 To 2
            If IsNumeric(Mid(Arr(i, 1), j, 1)) = True Then
                Temp = Temp & Mid(Arr(i, 1), j, 1)
            End If
        Next j
    End If
    
    If Len(Temp) > 0 Then
        UniteNo = CLng(Temp): Temp = ""
    End If
    
    If InStr(1, Arr(i, 1), "B" & Chr(246) & "l" & Chr(252) & "m Sorular" & Chr(253)) > 0 Then
        Set HedefDosya = Documents.Add(KaynakDosya.AttachedTemplate.FullName)
        If IsEmpty(Arr(i + 1, 2)) = False Then
            HedefDosya.Range.FormattedText = KaynakDosya.Range(Arr(i, 2), Arr(i + 1, 2)).FormattedText
        Else
            HedefDosya.Range.FormattedText = KaynakDosya.Range(Arr(i, 2), KaynakDosya.Range.End).FormattedText
            ArrLr = True
        End If
        
        Call Quiz_3_Isaretle
        
        With HedefDosya
            .WebOptions.Encoding = msoEncodingUTF8
            .SaveAs2 FileName:=DosyaSec.InitialFileName & DersID & Ayrac & _
                UniteNo & "_quiz_MS_HTML.html", Fileformat:=wdFormatFilteredHTML, _
                AddToRecentFiles:=False
            .Close False
        End With
    End If
    If ArrLr = True Then Exit For
Next i
ArrLr = False

KaynakDosya.Close False

For i = 1 To 14
    If FSO.FolderExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_dosyalar") = True Then
        IMGKlasor = DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_dosyalar"
        FSO.CreateFolder (DosyaSec.InitialFileName & DersID & Ayrac & i)
        FSO.CreateFolder (DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img")
        FSO.CopyFile IMGKlasor & Ayrac & "*.*", _
            DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img" & Ayrac
    ElseIf FSO.FolderExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_files") = True Then
        IMGKlasor = DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_files"
        FSO.CreateFolder (DosyaSec.InitialFileName & DersID & Ayrac & i)
        FSO.CreateFolder (DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img")
        FSO.CopyFile IMGKlasor & Ayrac & "*.*", _
            DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img" & Ayrac
    End If
    If FSO.FileExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML.html") = True Then
        Call Quiz_4_Sadelestir(DosyaSec.InitialFileName & DersID & Ayrac, _
                            i, _
                            DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML.html")
    End If
    If FSO.FolderExists(DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img" & Ayrac) = True Then
        For Each File In FSO.GetFolder(DosyaSec.InitialFileName & DersID & Ayrac & i & Ayrac & "img" & Ayrac).Files
            If InStr(1, File.Name, "quiz_" & i & "_") = 0 Then
                GorselAdi = File.Name
                GorselAdi = Replace(GorselAdi, "image", "quiz_" & i & "_")
                File.Name = GorselAdi
            End If
        Next File
    End If
    If FSO.FileExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML.html") = True Then
        FSO.DeleteFile DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML.html"
    End If
    If FSO.FolderExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_dosyalar") = True Then
        FSO.DeleteFolder DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_dosyalar"
    ElseIf FSO.FolderExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_files") = True Then
        FSO.DeleteFolder DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz_MS_HTML_files"
    End If
    If FSO.FileExists(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz.html") = True Then
        Call Quiz_5_CSV_Uret(DosyaSec.InitialFileName & DersID & Ayrac & i & "_quiz.html", i)
    End If
Next i

Set ADO = CreateObject("ADODB.Stream")
ADO.Charset = "utf-8"
ADO.Open
For i4 = LBound(ArrCSV) To UBound(ArrCSV)
    ADO.WriteText ArrCSV(i4)
    ADO.WriteText vbNewLine
Next i4
ADO.SaveToFile DosyaSec.InitialFileName & DersID & Ayrac & DersID & ".csv", 2
ADO.Close

Debug.Print "Son soru ID: "; SoruID

Application.Visible = True
Application.ScreenUpdating = True
ActiveWindow.ActivePane.View.Type = wdPrintView

BitTrh = Now
MsgBox Format(BitTrh - BasTrh, "hh:mm:ss") & " surede islem tamamlandi."

End Sub

Sub Quiz_2_Ara()
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find.ParagraphFormat
    .OutlineLevel = wdOutlineLevel1
End With
j = j + 1
With Selection.Find
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchWildcards = False
    .MatchSoundsLike = False
    .MatchAllWordForms = False
    Do While .Execute
        H1Sayisi = H1Sayisi + 1
        If H1Sayisi > 14 Then
            MsgBox H1Sayisi & " adet H1 baslik var, kaynak dosyayi kontrol edip islemi tekrar deneyiniz", vbInformation
            Application.Visible = True
            KaynakDosya.Activate
            Stop
        End If
        Arr(j, 1) = Trim(Selection.Range.Text)
        Arr(j, 2) = Selection.Range.Start
        j = j + 1
        Selection.MoveRight unit:=wdCharacter, Count:=1
        
        'BASLIK 2 - BOLUM SORULARI ARAMA BASLANGICI
        With Selection.Find.ParagraphFormat
            .OutlineLevel = wdOutlineLevel2
        End With
        With Selection.Find
            .Text = "B" & Chr(246) & "l" & Chr(252) & "m Sorular" & Chr(253)
            .Replacement.Text = ""
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
            .Execute
            H2Sayisi = H2Sayisi + 1
            If H2Sayisi > 14 Then
                MsgBox H2Sayisi & " adet 'Bolum Sorulari' var, kaynak dosyayi kontrol edip islemi tekrar deneyiniz", vbInformation
                Application.Visible = True
                KaynakDosya.Activate
                Stop
            End If
            Arr(j, 1) = Trim(Selection.Range.Text)
            Arr(j, 2) = Selection.Range.Start
            j = j + 1
            Selection.MoveRight unit:=wdCharacter, Count:=1
        End With
        Selection.Find.ClearFormatting
        'BASLIK 2 - BOLUM SORULARI ARAMA SONU

        Selection.Find.Text = ""
        With Selection.Find.ParagraphFormat
            .OutlineLevel = wdOutlineLevel1
        End With
    Loop
End With
Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting

End Sub

Sub Quiz_3_Isaretle()
HedefDosya.Activate

ReDim AramaIfadeleri1(1 To 10, 1 To 3)
AramaIfadeleri1(1, 1) = "a[).-]": AramaIfadeleri1(1, 2) = "¨aa": AramaIfadeleri1(1, 3) = "aa¨"
AramaIfadeleri1(2, 1) = "b[).-]": AramaIfadeleri1(2, 2) = "¨bb": AramaIfadeleri1(2, 3) = "bb¨"
AramaIfadeleri1(3, 1) = "c[).-]": AramaIfadeleri1(3, 2) = "¨cc": AramaIfadeleri1(3, 3) = "cc¨"
AramaIfadeleri1(4, 1) = "d[).-]": AramaIfadeleri1(4, 2) = "¨dd": AramaIfadeleri1(4, 3) = "dd¨"
AramaIfadeleri1(5, 1) = "e[).-]": AramaIfadeleri1(5, 2) = "¨ee": AramaIfadeleri1(5, 3) = "ee¨"
AramaIfadeleri1(6, 1) = "A[).-]": AramaIfadeleri1(6, 2) = "¨aa": AramaIfadeleri1(6, 3) = "aa¨"
AramaIfadeleri1(7, 1) = "B[).-]": AramaIfadeleri1(7, 2) = "¨bb": AramaIfadeleri1(7, 3) = "bb¨"
AramaIfadeleri1(8, 1) = "C[).-]": AramaIfadeleri1(8, 2) = "¨cc": AramaIfadeleri1(8, 3) = "cc¨"
AramaIfadeleri1(9, 1) = "D[).-]": AramaIfadeleri1(9, 2) = "¨dd": AramaIfadeleri1(9, 3) = "dd¨"
AramaIfadeleri1(10, 1) = "E[).-]": AramaIfadeleri1(10, 2) = "¨ee": AramaIfadeleri1(10, 3) = "ee¨"

Selection.HomeKey unit:=wdStory
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
    .Forward = True
    .MatchWildcards = True
    .Text = "[0-9]@[).-]"
    .Replacement.Text = "¨qq"
    .Wrap = wdFindStop
    Do While .Execute
        If Selection.Range.ParagraphFormat.OutlineLevel <> wdOutlineLevel1 And _
        Selection.Range.ParagraphFormat.OutlineLevel <> wdOutlineLevel2 Then
            If Left(Selection.Range.Paragraphs(1).Range.Text, Len(Selection.Text)) = Selection.Text Then
                .Execute Replace:=wdReplaceOne
                Selection.MoveRight unit:=wdCharacter, Count:=2
            End If
        End If
    Loop
End With

For j = LBound(AramaIfadeleri1) To UBound(AramaIfadeleri1)
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = True
        .Text = AramaIfadeleri1(j, 1)
        .Replacement.Text = AramaIfadeleri1(j, 2)
        Do While .Execute
            If Left(Trim(Selection.Paragraphs(1).Range.Text), Len(Selection.Text)) = Selection.Text Then
                .Execute Replace:=wdReplaceOne
                Selection.MoveRight unit:=wdCharacter, Count:=1
            End If
        Loop
    End With
Next j

k = 1
ReDim Arr2(1 To HedefDosya.Paragraphs.Count, 1 To 2)
For j = 1 To HedefDosya.Paragraphs.Count
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨qq" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨qq": k = k + 1
    End If
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨aa" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨aa": k = k + 1
    End If
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨bb" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨bb": k = k + 1
    End If
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨cc" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨cc": k = k + 1
    End If
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨dd" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨dd": k = k + 1
    End If
    If Left(Trim(HedefDosya.Paragraphs(j).Range.Text), 3) = "¨ee" Then
        Arr2(k, 1) = j: Arr2(k, 2) = "¨ee": k = k + 1
    End If
Next j
For j = LBound(Arr2) To UBound(Arr2)
    If IsEmpty(Arr2(j, 1)) = True Then Arr2Lr = j - 1: Exit For
Next j
For j = 1 To Arr2Lr
    If j < Arr2Lr Then
        If Arr2(j, 2) = "¨qq" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("qq¨")
        End If
        If Arr2(j, 2) = "¨aa" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("aa¨")
        End If
        If Arr2(j, 2) = "¨bb" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("bb¨")
        End If
        If Arr2(j, 2) = "¨cc" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("cc¨")
        End If
        If Arr2(j, 2) = "¨dd" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("dd¨")
        End If
        If Arr2(j, 2) = "¨ee" Then
            HedefDosya.Paragraphs(Arr2(j + 1, 1)).Range.InsertBefore ("ee¨")
        End If
    ElseIf j = Arr2Lr Then
        If Arr2(j, 2) = "¨qq" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("qq¨")
        End If
        If Arr2(j, 2) = "¨aa" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("aa¨")
        End If
        If Arr2(j, 2) = "¨bb" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("bb¨")
        End If
        If Arr2(j, 2) = "¨cc" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("cc¨")
        End If
        If Arr2(j, 2) = "¨dd" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("dd¨")
        End If
        If Arr2(j, 2) = "¨ee" Then
            HedefDosya.Paragraphs(Arr2(j, 1)).Range.InsertAfter ("ee¨")
        End If
    End If
Next j

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "¨¨"
    .Replacement.Text = "¨^p¨"
    .Execute Replace:=wdReplaceAll
End With

For j = 1 To 5
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = False
        .Text = AramaIfadeleri1(j, 2)
        .Replacement.Text = AramaIfadeleri1(j, 2) & "^p"
        .Execute Replace:=wdReplaceAll
    End With
Next j

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "¨qq"
    .Replacement.Text = "¨qq^p"
    .Execute Replace:=wdReplaceAll
End With

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "¨qq"
    .Replacement.Text = "^&"
    Do While .Execute
        Selection.Range.Paragraphs(1).Range.Select
        Selection.ClearFormatting
        Selection.MoveRight unit:=wdCharacter, Count:=1
    Loop
End With

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "qq¨"
    .Replacement.Text = "^&"
    Do While .Execute
        Selection.Range.Paragraphs(1).Range.Select
        Selection.ClearFormatting
        Selection.MoveRight unit:=wdCharacter, Count:=1
    Loop
End With

For j = 1 To 5
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = False
        .Text = AramaIfadeleri1(j, 2)
        .Replacement.Text = "^&"
        Do While .Execute
            Selection.Range.Paragraphs(1).Range.Select
            Selection.ClearFormatting
            Selection.MoveRight unit:=wdCharacter, Count:=1
        Loop
    End With
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = False
        .Text = AramaIfadeleri1(j, 3)
        .Replacement.Text = "^&"
        Do While .Execute
            Selection.Range.Paragraphs(1).Range.Select
            Selection.ClearFormatting
            Selection.MoveRight unit:=wdCharacter, Count:=1
        Loop
    End With
Next j

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "qq¨"
    .Replacement.Text = "^&"
    Do While .Execute
        Selection.Range.Paragraphs(1).Range.Select
        Selection.ClearFormatting
        Selection.MoveRight unit:=wdCharacter, Count:=2
    Loop
End With

For j = 1 To 5
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = False
        .Text = AramaIfadeleri1(j, 2)
        .Replacement.Text = "^&"
        Do While .Execute
            Selection.Range.Paragraphs(1).Range.Select
            Selection.ClearFormatting
            Selection.MoveRight unit:=wdCharacter, Count:=2
        Loop
    End With
Next j

For j = 1 To 5
    Selection.HomeKey unit:=wdStory
    With Selection.Find
        .Forward = True
        .MatchWildcards = False
        .Text = AramaIfadeleri1(j, 3)
        .Replacement.Text = "^&"
        Do While .Execute
            Selection.Range.Paragraphs(1).Range.Select
            Selection.ClearFormatting
            Selection.MoveRight unit:=wdCharacter, Count:=2
        Loop
    End With
Next j

Selection.HomeKey unit:=wdStory
With Selection.Find
    .Forward = True
    .MatchWildcards = False
    .Text = "^p "
    .Replacement.Text = "^p"
    Do While .Execute
        Selection.Range.Paragraphs(1).Range.Select
        Selection.ClearFormatting
        Selection.MoveRight unit:=wdCharacter, Count:=1
    Loop
End With

'SORU KOK SAYISI KONTROL BASLANGICI
Selection.HomeKey unit:=wdStory
With HedefDosya.Content.Find
    .Text = "¨qq"
    .Format = False
    .Wrap = wdFindStop
    Do While .Execute
        SoruBasiKontrol = SoruBasiKontrol + 1
    Loop
End With
With HedefDosya.Content.Find
    .Text = "qq¨"
    .Format = False
    .Wrap = wdFindStop
    Do While .Execute
        SoruSonuKontrol = SoruSonuKontrol + 1
    Loop
End With
If SoruBasiKontrol <> SoruSonuKontrol Then
    MsgBox "Bu unitede " & SoruBasiKontrol - SoruSonuKontrol & " adet klasik soru olabilir" & _
            vbNewLine & "Lutfen dosyayi kontrol ediniz." & vbNewLine & _
            "Klasik soru varsa soru koku sonuna " & Chr(34) & "qq¨" & Chr(34) & " ifadesini yaziniz"
    Stop
End If
SoruBasiKontrol = 0: SoruSonuKontrol = 0
'SORU KOK SAYISI KONTROL SONU

End Sub

Sub Quiz_4_Sadelestir(ByVal Klasor As String, _
                    ByVal UniteNo2 As Long, _
                    ByVal MS_HTML As String)
Etiketler = "<html|</html|<head|</head|" & _
    "<meta|<title|</title|" & _
    "<body|</body|<p|</p|<table|</table|<img|" & _
    "<tr|</tr|<td|</td|<b|</b|<i|</i|<u|</u|<s>|</s>|" & _
    "<ul|</ul|<ol|</ol|<li|</li|" & _
    "<sub|</sub|<sup|</sup"
Dizi = Split(Etiketler, "|")

Set ADO = CreateObject("ADODB.Stream")
ADO.Charset = "utf-8"
ADO.Open
ADO.LoadFromFile MS_HTML
HTMLIlk = ADO.ReadText
ADO.Close

Do While InStr(1, HTMLIlk, vbNewLine) > 0 Or _
    InStr(1, HTMLIlk, "  ") > 0 Or _
    InStr(1, HTMLIlk, Chr(160)) > 0
    HTMLIlk = Replace(HTMLIlk, vbNewLine, " ")
    HTMLIlk = Replace(HTMLIlk, Chr(160), Chr(32))
    HTMLIlk = Replace(HTMLIlk, "  ", " ")
Loop

HTMLSon = HTMLIlk

Konum = 1
Do While InStr(Konum, HTMLIlk, "<") > 0
    Basla = InStr(Konum, HTMLIlk, "<")
    Bitir = InStr(Basla, HTMLIlk, ">")
    Temp = Mid(HTMLIlk, Basla, (Bitir - Basla) + 1)
    'Debug.Print Konum & "-" & Basla & "-" & Bitir & "-" & Temp
    For k = 0 To UBound(Dizi)
        If InStr(1, Temp, Dizi(k)) > 0 Then
            If InStr(1, Temp, "<meta") > 0 Then
                If InStr(1, Temp, "charset=utf-8") > 0 Then
                    HTMLSon = Replace(HTMLSon, Temp, "<meta http-equiv=Content-Type content=" & Chr(34) & "text/html; charset=utf-8" & Chr(34) & ">")
                Else
                    HTMLSon = Replace(HTMLSon, Temp, "")
                End If
            End If
            If InStr(1, Temp, "<body") > 0 Then
                HTMLSon = Replace(HTMLSon, Temp, "<body>")
            End If
            If InStr(1, Temp, "<p") > 0 Then
                HTMLSon = Replace(HTMLSon, Temp, "<p>")
            End If
            If InStr(1, Temp, "<img") > 0 Then
                Temp2 = "<img border=" & Chr(34) & "0" & Chr(34) & " src=" & Chr(34) & "img/"
                If InStr(1, Temp, "_quiz_MS_HTML_dosyalar/") > 0 Then
                    Temp3 = Split(Temp, "_quiz_MS_HTML_dosyalar/")(1)
                Else
                    Temp3 = Split(Temp, "_quiz_MS_HTML_files/")(1)
                End If
                If InStr(1, Temp3, Chr(34)) > 0 Then
                    Temp2 = Temp2 & Temp3
                Else
                    Temp2 = Temp2 & Temp3 & Chr(34) & ">"
                End If
                Temp2 = Replace(Temp2, "image", "quiz")
                HTMLSon = Replace(HTMLSon, Temp, Temp2)
            End If
            If InStr(1, Temp, "<table") > 0 Then
                HTMLSon = Replace(HTMLSon, Temp, "<table>")
            End If
            If InStr(1, Temp, "<tr") > 0 Then
                HTMLSon = Replace(HTMLSon, Temp, "<tr>")
            End If
            If InStr(1, Temp, "<td") > 0 Then
                If InStr(1, Temp, "rowspan") > 0 Then
                    Temp2 = "<td rowspan=" & Chr(34)
                    Temp3 = Split(Temp, "rowspan=")(1)
                    If InStr(1, Temp3, " ") > 0 Then
                        Temp4 = Split(Temp3, " ")(0)
                    Else
                        Temp4 = Split(Temp3, ">")(0)
                    End If
                    Temp2 = Temp2 & Temp4 & Chr(34)
                    If InStr(1, Temp, "colspan") > 0 Then
                        Temp2 = Temp2 & " colspan=" & Chr(34)
                        Temp3 = Split(Temp, "colspan=")(1)
                        If InStr(1, Temp3, " ") > 0 Then
                            Temp4 = Split(Temp3, " ")(0)
                        Else
                            Temp4 = Split(Temp3, ">")(0)
                        End If
                        Temp2 = Temp2 & Temp4 & Chr(34)
                    End If
                    Temp2 = Temp2 & ">"
                    Temp2 = Replace(Temp2, Chr(34) & Chr(34), Chr(34))
                    HTMLSon = Replace(HTMLSon, Temp, Temp2)
                End If
                
                If InStr(1, Temp, "colspan") > 0 Then
                    Temp2 = "<td colspan=" & Chr(34)
                    Temp3 = Split(Temp, "colspan=")(1)
                    If InStr(1, Temp3, " ") > 0 Then
                        Temp4 = Split(Temp3, " ")(0)
                    Else
                        Temp4 = Split(Temp3, ">")(0)
                    End If
                    Temp2 = Temp2 & Temp4 & Chr(34)
                    If InStr(1, Temp, "rowspan") > 0 Then
                        Temp2 = Temp2 & " rowspan=" & Chr(34)
                        Temp3 = Split(Temp, "rowspan=")(1)
                        If InStr(1, Temp3, " ") > 0 Then
                            Temp4 = Split(Temp3, " ")(0)
                        Else
                            Temp4 = Split(Temp3, ">")(0)
                        End If
                        Temp2 = Temp2 & Temp4 & Chr(34)
                    End If
                    Temp2 = Temp2 & ">"
                    Temp2 = Replace(Temp2, Chr(34) & Chr(34), Chr(34))
                    HTMLSon = Replace(HTMLSon, Temp, Temp2)
                End If
                If InStr(1, Temp, "colspan") = 0 Then
                    If InStr(1, Temp, "rowspan") = 0 Then
                        HTMLSon = Replace(HTMLSon, Temp, "<td>")
                    End If
                End If
                If InStr(1, Temp, "rowspan") = 0 Then
                    If InStr(1, Temp, "colspan") = 0 Then
                        HTMLSon = Replace(HTMLSon, Temp, "<td>")
                    End If
                End If
            End If
            Exit For
        ElseIf k = UBound(Dizi) Then
            HTMLSon = Replace(HTMLSon, Temp, "")
        End If
    Next k
    Konum = Bitir + 1
    HTMLSon = Replace(HTMLSon, "<p> </p>", "")
    HTMLSon = Replace(HTMLSon, vbNewLine & vbNewLine, " ")
    HTMLSon = Replace(HTMLSon, "  ", " ")
    HTMLSon = Replace(HTMLSon, "> <", ">" & vbNewLine & "<")
Loop

HTMLSon = Replace(HTMLSon, "img/quiz", "img/quiz_" & UniteNo2 & "_")
Temp = "": Temp2 = "": Temp3 = "": Temp4 = ""

Set ADO = CreateObject("ADODB.Stream")
ADO.Charset = "utf-8"
ADO.Open
ADO.WriteText HTMLSon
ADO.SaveToFile Klasor & UniteNo2 & "_quiz.html", 2
ADO.Close

End Sub

Sub Quiz_5_CSV_Uret(ByVal QuizHTML As String, _
            ByVal UniteNo2 As Long)

Set ADO = CreateObject("ADODB.Stream")
ADO.Charset = "utf-8"
ADO.Open
ADO.LoadFromFile QuizHTML
HTMLDoc = ADO.ReadText
ADO.Close

Konum = 1
Do While InStr(Konum, HTMLDoc, "¨qq") > 0
    Basla = InStr(Konum, HTMLDoc, "¨qq")
    Bitir = InStr(Basla + 1, HTMLDoc, "¨qq")
    If Bitir = 0 Then Bitir = Len(HTMLDoc)
    Temp = Mid(HTMLDoc, Basla, (Bitir - Basla))
    Temp = Replace(Temp, vbNewLine, " ")
    Temp = Replace(Temp, "  ", " ")
    'SORU KOKU AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨qq") > 0 Then
        Basla2 = InStr(1, Temp, "¨qq")
        Bitir2 = InStr(Basla2 + 1, Temp, "qq¨")
        Soru = Mid(Temp, Basla2, (Bitir2 - Basla2))
        Soru = Replace(Soru, "¨qq", "")
        Soru = "<p>" & Soru & "</p>"
    End If
    'SORU KOKU AYIKLAMA SONU
    'VARSA A SIKKI AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨aa") > 0 Then
        Basla2 = InStr(1, Temp, "¨aa")
        Bitir2 = InStr(Basla2 + 1, Temp, "aa¨")
        ASikki = Mid(Temp, Basla2, (Bitir2 - Basla2))
        ASikki = Replace(ASikki, "¨aa", "")
        ASikki = "<p>" & ASikki & "</p>"
        If InStr(1, ASikki, "**") > 0 Then
            DogruYanit = "a": ASikki = Replace(ASikki, "**", "")
        End If
    End If
    'VARSA A SIKKI AYIKLAMA SONU
    'VARSA B SIKKI AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨bb") > 0 Then
        Basla2 = InStr(1, Temp, "¨bb")
        Bitir2 = InStr(Basla2 + 1, Temp, "bb¨")
        BSikki = Mid(Temp, Basla2, (Bitir2 - Basla2))
        BSikki = Replace(BSikki, "¨bb", "")
        BSikki = "<p>" & BSikki & "</p>"
        If InStr(1, BSikki, "**") > 0 Then
            DogruYanit = "b": BSikki = Replace(BSikki, "**", "")
        End If
    End If
    'VARSA B SIKKI AYIKLAMA SONU
    'VARSA C SIKKI AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨cc") > 0 Then
        Basla2 = InStr(1, Temp, "¨cc")
        Bitir2 = InStr(Basla2 + 1, Temp, "cc¨")
        CSikki = Mid(Temp, Basla2, (Bitir2 - Basla2))
        CSikki = Replace(CSikki, "¨cc", "")
        CSikki = "<p>" & CSikki & "</p>"
        If InStr(1, CSikki, "**") > 0 Then
            DogruYanit = "c": CSikki = Replace(CSikki, "**", "")
        End If
    End If
    'VARSA C SIKKI AYIKLAMA SONU
    'VARSA D SIKKI AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨dd") > 0 Then
        Basla2 = InStr(1, Temp, "¨dd")
        Bitir2 = InStr(Basla2 + 1, Temp, "dd¨")
        DSikki = Mid(Temp, Basla2, (Bitir2 - Basla2))
        DSikki = Replace(DSikki, "¨dd", "")
        DSikki = "<p>" & DSikki & "</p>"
        If InStr(1, DSikki, "**") > 0 Then
            DogruYanit = "d": DSikki = Replace(DSikki, "**", "")
        End If
    End If
    'VARSA D SIKKI AYIKLAMA SONU
    'VARSA E SIKKI AYIKLAMA BASLANGICI
    If InStr(1, Temp, "¨ee") > 0 Then
        Basla2 = InStr(1, Temp, "¨ee")
        Bitir2 = InStr(Basla2 + 1, Temp, "ee¨")
        ESikki = Mid(Temp, Basla2, (Bitir2 - Basla2))
        ESikki = Replace(ESikki, "¨ee", "")
        ESikki = "<p>" & ESikki & "</p>"
        If InStr(1, ESikki, "**") > 0 Then
            DogruYanit = "e": ESikki = Replace(ESikki, "**", "")
        End If
    End If
    'VARSA E SIKKI AYIKLAMA SONU
    Call Quiz_6_Soru_Ekle(UniteNo2) 'SORUYU ARRAY'E EKLEMEK ICIN DEGISKENLERI ALT ISLEME GONDER
    Konum = Bitir 'BIR SONRAKI (DONGU) SORU ICIN NUMARAYI ARTIR
Loop

End Sub

Sub Quiz_6_Soru_Ekle(ByVal UniteNo3 As Long)
m = m + 1
ReDim Preserve ArrCSV(1 To m)

ArrCSV(m) = ArrCSV(m) & Chr(34) & SoruID & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & DersID & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & UniteNo3 & Chr(34) & ","
If DogruYanit <> "" Then
    ArrCSV(m) = ArrCSV(m) & Chr(34) & Chr(199) & "oktan Se" & Chr(231) & "meli" & Chr(34) & ","
Else
    ArrCSV(m) = ArrCSV(m) & Chr(34) & "Klasik" & Chr(34) & ","
End If
ArrCSV(m) = ArrCSV(m) & Chr(34) & Soru & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & ASikki & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & BSikki & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & CSikki & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & DSikki & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & ESikki & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & DogruYanit & Chr(34) & ","
ArrCSV(m) = ArrCSV(m) & Chr(34) & Format(Now, "yyyy-mm-dd hh:mm:ss") & Chr(34)
ArrCSV(m) = Replace(ArrCSV(m), Chr(160), " ") '160: SABIT BOSLUK, 32: KLAVYEDEN CIKAN SPACE
ArrCSV(m) = Replace(ArrCSV(m), "p> ", "p>")
ArrCSV(m) = Replace(ArrCSV(m), " </p", "</p")
ArrCSV(m) = Replace(ArrCSV(m), "<p></p>", "")
ArrCSV(m) = Replace(ArrCSV(m), "> <", "><")
ArrCSV(m) = Replace(ArrCSV(m), Chr(34) & " <", Chr(34) & "<")
ArrCSV(m) = Replace(ArrCSV(m), "> " & Chr(34), ">" & Chr(34))
ArrCSV(m) = Replace(ArrCSV(m), "<p><b> </b></p>", "")
ArrCSV(m) = Replace(ArrCSV(m), "<p><b> </b></p>", "")
ArrCSV(m) = Replace(ArrCSV(m), "<b> </b>", "")
'Debug.Print ArrCSV(m)
Soru = ""
ASikki = "": BSikki = "": CSikki = "": DSikki = "": ESikki = ""
DogruYanit = ""
SoruID = SoruID + 1

End Sub
'Bir karakterin Chr kodunu almak için Asc("a") deyimini kullanin _
Kaynak: Chat GPT 3.5 _
Kod uyarlama: Muharrem DOGANCI

Muharrem DOĞANCI

Bu Blogda Ara

11 Nisan 2023 Salı

Word Dosyasından Bölüm Sonu (Quiz) Sorularını VBA, CSV ile PHPMyAdmin'e Yüklemek

Hiç yorum yok:

Yorum Gönder