Muharrem DOĞANCI: Ekim 2023

30 Ekim 2023 Pazartesi

InDesign ile Çoklu QR Oluşturma Denemesi

Burada, https://www.youtube.com/watch?v=t7xV1DXNM8Y adresindeki, InDesign ile çoklu QR kod eklemekle ilgili içerik denenmiştir.

InDesign 2020, 2024 sürümlerinde deneme yapılmıştır. 2024 sürümünde herhangi bir iyileştirme saptanamamıştır. Videodaki sürüm 2024'tür.

🟠 VCARD kodu en çok 3 sütunu desteklemiştir.
🟠 Excel sadece Windows işletim sistemlerinde çalışır.
✅ Türkçe karakterlerden ö, Ö, ç, Ç, ü, Ü görüntülenebilmiştir.
❌ Türkçe karakterlerden ğ, Ğ, ı, İ, ş, Ş görüntülenememiştir.

📜 Excel VBA:


Dim i As Long
Dim j As Long
Dim k As Long
Dim lr As Long
Dim lc As Long
Dim Uzunluk As Long

Dim Arr1 As Variant
Dim Arr2 As Variant
Dim Arr2_QR As Variant
Dim Arr3() As String
Dim SutunBilgileri As Variant
Dim TekrarliVeriler() As String

Dim Harfler As String
Dim SatirAtla As String
Dim Tmp1 As String
Dim DosyaYol As String

Dim Yineleme As Boolean

Private Sub QR_Olustur_btn_Click()
Coklu_QR_Listesi_Olustur
End Sub

Sub Coklu_QR_Listesi_Olustur()

lc = Liste.Cells(1, Columns.Count).End(xlToLeft).Column
SatirAtla = "\n"
Harfler = "ABCDEFGHIJKLMNOPQRSTUWXYZ0123456789"
Yineleme = False

Liste.UsedRange.Interior.Color = xlNone

If InStr(1, UCase(Liste.Cells(1, lc)), "QR") > 0 Then
    Liste.Columns(lc).Delete
    lc = Liste.Cells(1, Columns.Count).End(xlToLeft).Column
End If

lr = Liste.Cells(Rows.Count, 1).End(xlUp).Row

If lr = 0 Or lc = 0 Then
    MsgBox "Dosyada veri yok", vbCritical
    Exit Sub
End If

ReDim SutunBilgileri(1 To 1, 1 To lc)
ReDim Arr1(1 To (lr - 1), 1 To lc)
ReDim Arr2(1 To (lr - 1), 1 To 1)
ReDim Arr2_QR(1 To (lr - 1), 1 To 1)

For i = 1 To lc
    Uzunluk = Len(Liste.Cells(1, i))
    
    If Uzunluk > 4 Then
        Uzunluk = 5
    End If
    
    For j = 1 To Uzunluk
        If InStr(1, Harfler, UCase(Mid(Liste.Cells(1, i), j, 1))) > 0 Then
            SutunBilgileri(1, i) = SutunBilgileri(1, i) & UCase(Mid(Liste.Cells(1, i), j, 1))
        End If
    Next j
Next i

Arr1 = Liste.Range("A2").Resize((lr - 1), lc)

For i = LBound(Arr1, 1) To UBound(Arr1, 1)
    For j = LBound(Arr1, 2) To UBound(Arr1, 2)
        Arr2(i, 1) = Arr2(i, 1) & Arr1(i, j) & ";"
    Next j
    
    Arr2(i, 1) = Arr2(i, 1) & "BEGIN:VCARD" & SatirAtla & "VERSION:2.1" & SatirAtla
    Arr2_QR(i, 1) = Arr2_QR(i, 1) & "BEGIN:VCARD" & SatirAtla & "VERSION:2.1" & SatirAtla

    For j = LBound(Arr1, 2) To UBound(Arr1, 2)
        Arr2(i, 1) = Arr2(i, 1) & SutunBilgileri(1, j) & ":" & Arr1(i, j) & SatirAtla
        Arr2_QR(i, 1) = Arr2_QR(i, 1) & SutunBilgileri(1, j) & ":" & Arr1(i, j) & SatirAtla
    Next j

    Arr2(i, 1) = Arr2(i, 1) & "END:VCARD"
    Arr2_QR(i, 1) = Arr2_QR(i, 1) & "END:VCARD"
Next i

For i = LBound(Arr2, 1) To UBound(Arr2, 1)
    For j = 1 To UBound(Arr2, 1)
        If i <> j Then
            If Arr2(i, 1) = Arr2(j, 1) Then
                k = k + 1
                ReDim Preserve TekrarliVeriler(1 To k)
                TekrarliVeriler(k) = j + 1 & ". satirda veri yinelenmis! " & Arr2(j, 1)
                Arr2(i, 1) = ""
                Liste.Range("A" & i + 1).Resize(1, lc + 1).Interior.Color = RGB(255, 175, 175)
                Liste.Range("A" & j + 1).Resize(1, lc + 1).Interior.Color = RGB(255, 175, 175)
                Yineleme = True
                Exit For
            End If
        End If
    Next j
Next i

Liste.Cells(1, lc + 1) = "#QR"
Liste.Range(Liste.Cells(2, lc + 1).Address).Resize(UBound(Arr2, 1), 1) = Arr2_QR

j = 0
For i = LBound(Arr2, 1) To UBound(Arr2, 1)
    If Arr2(i, 1) <> "" Then
        j = j + 1
        ReDim Preserve Arr3(1 To j)
        Arr3(j) = Arr2(i, 1)
    End If
Next i

On Error Resume Next
DosyaYol = ThisWorkbook.Path & Application.PathSeparator & Trim(Replace(ThisWorkbook.Name, ".xlsb", "")) & ".csv"
Kill DosyaYol
If Dir(DosyaYol) <> "" Then
    MsgBox "CSV dosyasi silinemedi." & vbNewLine _
    & "Verilerin yeniden yazdirilmasi icin CSV dosyasini kapatiniz."
End If
On Error GoTo 0

Set ADO = CreateObject("ADODB.Stream")
ADO.Charset = "utf-16le"
ADO.Open
For j = LBound(SutunBilgileri, 2) To UBound(SutunBilgileri, 2)
    Tmp1 = Tmp1 & SutunBilgileri(1, j) & ";"
Next j
Tmp1 = Tmp1 & "#QR"
ADO.WriteText Tmp1
ADO.WriteText vbNewLine
For i = LBound(Arr3) To UBound(Arr3)
    ADO.WriteText Arr3(i)
    ADO.WriteText vbNewLine
Next i
ADO.SaveToFile ThisWorkbook.Path & Application.PathSeparator & Trim(Replace(ThisWorkbook.Name, ".xlsb", "")) & ".csv", 2
ADO.Close

If Yineleme = True Then
    Set ADO = CreateObject("ADODB.Stream")
    ADO.Charset = "utf-16le"
    ADO.Open
    For i = LBound(TekrarliVeriler) To UBound(TekrarliVeriler)
        ADO.WriteText TekrarliVeriler(i)
        ADO.WriteText vbNewLine
    Next i
    ADO.SaveToFile ThisWorkbook.Path & Application.PathSeparator & Trim(Replace(ThisWorkbook.Name, ".xlsb", "")) & "_Yinelenmis_Veriler.txt", 2
    ADO.Close
    Yineleme = False
End If

Erase Arr1
Erase Arr2
Erase Arr2_QR
Erase Arr3
Erase SutunBilgileri
Erase TekrarliVeriler
Tmp1 = ""
DosyaYol = ""

End Sub

'Kaynak: ChatGPT v3.5 _
Derleme: Muharrem DOGANCI, 30.10.2023 Pazartesi

🔊 https://www.youtube.com/watch?v=lIAYAGP5JoA

29 Ekim 2023 Pazar

Youtube'ın Reklam Zorunluluğu

29.10.2023 Pazar tarihinde Youtube'ın reklamları zorunlu tuttuğu görüldü. Aradan kısa bir süre geçtikten sonra "karşı hamle" geldi. Şimdilik ücretsiz kullanıcılar için önemli bir sorun görünmüyor.

Muharrem DOĞANCI

Bu Blogda Ara

30 Ekim 2023 Pazartesi

InDesign ile Çoklu QR Oluşturma Denemesi

29 Ekim 2023 Pazar

Youtube'ın Reklam Zorunluluğu

22 Ekim 2023 Pazar

Küçük Jet