Çözüldü Qr Code Oluşturma

[1ndependent]

Arkadaşlar merhaba.
Aşağıdaki kodlar ile excell de qr kod oluşturabiliyoruz. Ancak # yada / gibi karakterleri metin içerisinde oluşturmaya çalıştığımda hata veriyor. Bunu nasıl düzeltebiliriz?
Dosyanın örneğinide ekliyorum.

Sub InsertQR()
Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
Dim Size: Size = 250 'dalam Pixels
Dim QR, Name, val
Dim Invalid: Invalid = "\/:*?" & """" & "<>|"
For Each val In Selection
Name = val.Value
For intChar = 1 To Len(Name)
If InStr(Invalid, LCase(Mid(Name, intChar, 1))) > 0 Then
MsgBox "The file: " & vbCrLf & """" & Name & """" & vbCrLf & vbCrLf & " is invalid!"
Exit Sub
End If
Next
QR = "http://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl=" & Name
xHttp.Open "GET", QR, False
xHttp.Send
With bStrm
.Type = 1 '//binary
.Open
.write xHttp.responseBody
.savetofile ThisWorkbook.Path & Application.PathSeparator & Name & ".png", 2 '//overwrite
.Close
End With
Next
End Sub

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki satırları silin

MsgBox "The file: " & vbCrLf & """" & Name & """" & vbCrLf & vbCrLf & " is invalid!"
Exit Sub

Aşağıdaki satırları ekleyin

Name = WorksheetFunction.Substitute(Name, Mid(Name, intChar, 1), "_")

Hata, kayıt edilen png dosyasının isminden kaynaklanıyor. Bir dosyanın adı "\/:*?" & """" & "<>|" karakterlerinden birini içeremez.
Yaptığım düzeltmede "\/:*?" & """" & "<>|" karakterlerinden her hangi biri varsa onu "_" karakteri ile değiştirecek şekilde ayarladım.

 

[1ndependent]

Teşekkür ederim. Bu detayı atlamışım.

Ancak şöyle bir şey yapabilmemiz mümkün mü? Oluşturacağım Qr kod Örneğin; 25H8-111222-001#1/1 olması gerekiyor ama dosya ismi 25H8-111222-001 olarak kalmasında bir sakınca yok.

 

[Muzaffer Ali]

O zaman geçersiz karakterlerin kontrol edildiği kodların yeri değiştirilmeli.
Aşağıdaki kodları kullanabilirsiniz.

Sub InsertQR()
    Dim xHttp: Set xHttp = CreateObject("Microsoft.XMLHTTP")
    Dim bStrm: Set bStrm = CreateObject("Adodb.Stream")
    Dim Size: Size = 250 'dalam Pixels
    Dim QR, Name, val
    Dim Invalid: Invalid = "\/:*?" & """" & "<>|"
    For Each val In Selection
        Name = val.Value
        QR = "http://chart.googleapis.com/chart?chs=" & Size & "x" & Size & "&cht=qr&chl=" & Name
        xHttp.Open "GET", QR, False
        xHttp.Send
        For intChar = 1 To Len(Name)
            If InStr(Invalid, LCase(Mid(Name, intChar, 1))) > 0 Then
                Name = WorksheetFunction.Substitute(Name, Mid(Name, intChar, 1), "_")
            End If
        Next
        With bStrm
            .Type = 1 '//binary
            .Open
            .write xHttp.responseBody
            .savetofile ThisWorkbook.Path & Application.PathSeparator & Name & ".png", 2 '//overwrite
            .Close
        End With
    Next
End Sub

 

[1ndependent]

Şuan yine invalid hatası alıyorum. Sizin vermiş olduğunuz kodlar ile denediğimde.

 

[Muzaffer Ali]

Son kodları düzenledim. Şimdi yeniden deneyin.

 

[1ndependent]

Çok teşekkür ederim. Şuan her şey tamam