Excel'de Google API QR Kod Boyutu Nasıl Ayarlanır?

aykuto11

Decapat
Katılım
7 Haziran 2020
Mesajlar
44
Merhaba asagidaki kodu kullanarak Excel'de QR kod yapiyorum ama kenarlarinda cok bosluk kalıyor. Bunu nasıl tam sıfır gelecek sekilde ayarlayabilirim?

Kod:
Option Explicit.
'other technical specifications about google chart API:
'QR Codes | Infographics | Google Developers.

Function URL_QRCode_SERIES( _
 ByVal PictureName As String, _
 ByVal QR_Value As String, _
 Optional ByVal PictureSize As Long = 150, _
 Optional ByVal DisplayText As String = "", _
 Optional ByVal Updateable As Boolean = True) As Variant.

Dim oPic As Shape, oRng As Excel.Range
Dim vLeft As Variant, vTop As Variant.
Dim sURL As String.

Const sRootURL As String = "https://chart.googleapis.com/chart?"
Const sSizeParameter As String = "chs="
Const sTypeChart As String = "cht=qr"
Const sDataParameter As String = "chl="
Const sJoinCHR As String = "&"

If Updateable = False Then.
 URL_QRCode_SERIES = "outdated"
 Exit Function.
End If.

Set oRng = Application.Caller.Offset(, 1)
On Error Resume Next.
Set oPic = oRng.Parent.Shapes(PictureName)
If Err Then.
 Err.Clear
 vLeft = oRng.Left + 4
 vTop = oRng.Top
Else.
 vLeft = oPic.Left
 vTop = oPic.Top
 PictureSize = Int(oPic.Width)
 oPic.Delete
End If.
On Error GoTo 0

If Len(QR_Value) = 0 Then.
 URL_QRCode_SERIES = CVErr(xlErrValue)
 Exit Function.
End If.

sURL = sRootURL & _
 sSizeParameter & PictureSize & "x" & PictureSize & sJoinCHR & _
 sTypeChart & sJoinCHR & _
 sDataParameter & UTF8_URL_Encode(VBA.Replace(QR_Value, " ", "+"))

Set oPic = oRng.Parent.Shapes.AddPicture(sURL, True, True, vLeft, vTop, PictureSize, PictureSize)
oPic.Name = PictureName.
URL_QRCode_SERIES = DisplayText.
End Function.

Function UTF8_URL_Encode(ByVal sStr As String)
 'http://www.nonhostile.com/howto-convert-byte-array-utf8-string-vb6.asp
 Dim i As Long.
 Dim a As Long.
 Dim res As String.
 Dim code As String.

 res = ""
 For i = 1 To Len(sStr)
 a = AscW(Mid(sStr, i, 1))
 If a < 128 Then.
 code = Mid(sStr, i, 1)
 ElseIf ((a > 127) And (a < 2048)) Then.
 code = URLEncodeByte(((a \ 64) Or 192))
 code = code & URLEncodeByte(((a And 63) Or 128))
 Else.
 code = URLEncodeByte(((a \ 144) Or 234))
 code = code & URLEncodeByte((((a \ 64) And 63) Or 128))
 code = code & URLEncodeByte(((a And 63) Or 128))
 End If.
 res = res & code.
 Next i
 UTF8_URL_Encode = res.
End Function.

Private Function URLEncodeByte(val As Integer) As String.
 Dim res As String.
 res = "%" & Right("0" & Hex(val), 2)
 URLEncodeByte = res.
End Function
 

Dosya Ekleri

  • 20221218_171500.jpg
    20221218_171500.jpg
    164 KB · Görüntüleme: 19

Geri
Yukarı