Qr kod oluşturma hk.

[kemal turan]

Merhaba,
İhtiyaç nedeni ile internet den bulduğum aşağıdaki kod ile excel de qr kod dosyası buldum
Forumda ihtiyaç duyan arkadaşlarımız ek dosyadaki kodu kendi çalışma kitaplarına uyarlayabilir.
İhtiyacım ustalarımızdan isteğim barcod boyu yüksek geliyor. Nasıl istediğimiz ebada düşürebiliriz.
Teşekkür ederim.

 

[kemal turan]

En Boy ölçüsünüde deneyerek aşağıdaki şekilde oluşturdum.

Function QRuret(qrcode_value As String) 'QRuret adında bir fonksiyon oluşturuyoruz

ebat = ActiveSheet.Range("p1")

    Dim URL As String
    Dim My_Cell As Range
    
    Set My_Cell = Application.Caller
    URL = "https://qrcode.tec-it.com/API/QRCode?data=" & qrcode_value & "&backcolor=%23ffffff&size=" & ebat ' api cagrıldı
    
    On Error Resume Next
      ActiveSheet.Pictures("My_QR_CODE_" & My_Cell.Address(False, False)).Delete
    On Error GoTo 0
    ActiveSheet.Pictures.Insert(URL).Select
    With Selection.ShapeRange(1)
     .Name = "My_QR_CODE_" & My_Cell.Address(False, False)
     .Left = My_Cell.Left + 5
     .Top = My_Cell.Top + 5
     .Width = 20
     .Height = 20
    End With
End Function

 

[Biolightant]

Merhaba,
Eklediğiniz dosyayı ben göremiyorum ama diğer mesajınızda ki Kodlara göre

'' Sayfada bir hücrede değişiklik olduğunda QR kodu üretilebilir
'' Bu işlem Worksheet_Change olayıyla otomatik olarak yapılabilir
'
'' Aşağıdaki olay, sayfada herhangi bir hücrede değişiklik olduğunda tetiklenir
'Private Sub Worksheet_Change(ByVal Target As Range)
'    ' Eğer değişen hücre A1 ise
'    If Target.Address = Range("A1").Address Then
'        ' A1 hücresindeki değeri kullanarak QR kodu üret
'        QRuret Range("A1").Value
'    End If
'End Sub

' QR kodu manuel olarak oluşturmak için bu alt yordamı kullanabilirsiniz
Sub MyQR()
    ' A1 hücresindeki değeri kullanarak QR kodu üret
    QRuret Range("A1").Value
End Sub

' QR kodu üretmek ve belirli bir hücreye yerleştirmek için bu alt yordam kullanılır
Sub QRuret(QRvalue As String)
    
    Dim URL As String ' QR kodunu oluşturmak için kullanılacak URL
    Dim QRhucre As Range ' QR kodunun yerleştirileceği hücre
    
    ' QR kodunun yerleştirileceği hücreyi P1 olarak ayarla
    Set QRhucre = ActiveSheet.Range("P1")
    
    ' QR kodu oluşturmak için kullanılacak web API'si URL'sini ayarla
    URL = "https://qrcode.tec-it.com/API/QRCode?data=" & QRvalue

    ' Alternatif QR kodu siteleri:
    ' URL = "http://api.qrserver.com/v1/create-qr-code/?data=" & QRvalue
    ' URL = "https://zxing.org/w/chart?chs=250x250&cht=qr&chl=" & QRvalue
    
    ' Eğer daha önce aynı hücrede bir QR kodu varsa, onu sil
    On Error Resume Next
      ActiveSheet.Pictures("QRuret" & QRhucre.Address(False, False)).Delete
    On Error GoTo 0
    
    ' Yeni QR kodunu belirtilen URL'den al ve sayfaya ekle
    ActiveSheet.Pictures.Insert(URL).Select
    
    ' Yeni QR kodunu yerleştir ve boyutunu ayarla
    With Selection.ShapeRange(1)
        .Name = "QRuret" & QRhucre.Address(False, False) ' QR koduna bir ad ver
        .Left = QRhucre.Left + 5 ' QR kodunu hücrenin içine yerleştir
        .Top = QRhucre.Top + 5
        .Width = QRhucre.Width - 10 ' QR kodunun genişliğini hücreye göre ayarla
        .Height = QRhucre.Height - 10 ' QR kodunun yüksekliğini hücreye göre ayarla
    End With
    
    ' Eğer QR kodunun yüksekliği hücreden büyükse, yüksekliği hücre boyutuna göre ayarla
    If Selection.ShapeRange(1).Height > QRhucre.Height - 10 Then
        Selection.ShapeRange(1).Height = QRhucre.Height - 10
    End If
    
    ' Eğer QR kodunun genişliği hücreden büyükse, genişliği hücre boyutuna göre ayarla
    If Selection.ShapeRange(1).Width > QRhucre.Width - 10 Then
        Selection.ShapeRange(1).Width = QRhucre.Width - 10
    End If
    
End Sub

 

[kemal turan]

Teşekkür ederim

 

[ccuneyt13]

Merhaba,
Eklediğiniz dosyayı ben göremiyorum ama diğer mesajınızda ki Kodlara göre

Merhaba,
Sn. Biolightant, Kemal Beyin dosyasını aşağıdaki linkten indirebilirsiniz.

QrUret.xlsm dosyasını indir - download

QrUret.xlsm dosyasını indir, download. Dosya.tc .Dosya Upload. Dosya Paylaş. Dosya Yükle

s2.dosya.tc

 

[Biolightant]

Merhaba,

linkten indirebilirsiniz

Teşekkür ederim.

 

[kemal turan]

merhaba Ustalarımız,
Aşağıdaki kod ile oluşturduğumuz qr kod görüntüsü referans hücrede veri silindiğinde qr kod imajı kaybolmuyor.
=EĞER(J10<>"";QRuret(J10);"") fonksiyonu hücresinde veri yok ise ilk başta oluşturmuyor.
Fakat bir kez veri girildiğinde oluşan imaj görüntü j10 hücresindeki veriyi sildiğimde kaybolmuyor.
Bunu sağlayabilirmiyiz.

Function QRuret(qrcode_value As String) 'QRuret adında bir fonksiyon oluşturuyoruz

ebat = ActiveSheet.Range("p1")

    Dim URL As String
    Dim My_Cell As Range
   
    Set My_Cell = Application.Caller
    URL = "https://qrcode.tec-it.com/API/QRCode?data=" & qrcode_value & "&backcolor=%23ffffff&size=" & ebat ' api cagrıldı
   
    On Error Resume Next
      ActiveSheet.Pictures("My_QR_CODE_" & My_Cell.Address(False, False)).Delete
    On Error GoTo 0
    ActiveSheet.Pictures.Insert(URL).Select
    With Selection.ShapeRange(1)
     .Name = "My_QR_CODE_" & My_Cell.Address(False, False)
     .Left = My_Cell.Left + 5
     .Top = My_Cell.Top + 3
     .Width = 25
     .Height = 20
    End With
End Function

 

[Biolightant]

Benden pas çözemedim
Başka arkadaşlar yardım edecektir.

 

[kemal turan]

Teşekkür ediyorum

 

[kemal turan]

merhaba
Aşağıda internet bağlantısı olmadan qr kodlarını kullandım. Örnek dosya ektedir.
sayfa kod bölümünde activate olayına "veri "B1" hücresinde " / "barcod fontu A1" için olayına aşağıdaki kodu her satır için uyguladım.
isteğim oluştu.
Bilgilerinize