एक्सेल वीबीए

Question

का उपयोग कर 2 डी (पीडीएफ 417 या क्यूआर) बारकोड उत्पन्न करना मैक्रोज़ का उपयोग कर एक्सेल सेल में 2 डी बारकोड (पीडीएफ 417 या क्यूआर कोड) उत्पन्न करना चाहता हूं। बस यह सोचने के लिए भुगतान पुस्तकालयों के लिए कोई मुफ्त विकल्प है?

मुझे पता है certain tools नौकरी कर सकता है लेकिन यह हमारे लिए अपेक्षाकृत महंगा है।

Answer 1

VBA मॉड्यूल barcode-vba-macro-only (टिप्पणी में सेबेस्तियन फेरी ने उल्लेख किया) 2013

में एमआईटी लाइसेंस के तहत जिरी गेब्रियल द्वारा बनाई गई एक शुद्ध VBA -1 डी/2 डी कोड जनरेटर कोड को समझने के लिए पूरी तरह से सरल नहीं है, लेकिन उपरोक्त संस्करण में चेक से अंग्रेजी तक कई टिप्पणियों का अनुवाद किया गया है।

वर्कशीट में इसका उपयोग करने के लिए, बस मॉड्यूल में अपने वीबीए में barcody.bas कॉपी या आयात करें।

=EncodeBarcode(CELL("SHEET"),CELL("ADDRESS"),A2,51,1,0,2) 

उपयोग इस प्रकार है::

1. CELL("SHEET) और CELL("ADDRESS") छोड़ दो के रूप में वे कर रहे हैं के बाद से यह सिर्फ कार्यपत्रक और सेल का पता करने के लिए संदर्भ दे रही है किसी कार्यपत्रक में, इस तरह समारोह में डाल आपके पास फॉर्मूला
   • ए 2 वह सेल है जिसमें आपके स्ट्रिंग को एन्कोड किया जाना है। मेरे मामले में यह सेल ए 2 है आप इसे करने के लिए उद्धरण के साथ "टेक्स्ट" पास कर सकते हैं। सेल होने से यह अधिक गतिशील बनाता है
   • 51 क्यूआर कोड का विकल्प है। अन्य विकल्प 1 = EAN8/13/UPCA/UPCE, 2 = पाँच interleaved, 3 = कोड 39 में से दो, 50 = डेटा मैट्रिक्स, 51 हैं = QRCode
     • 1 ग्राफिकल मोड के लिए है। बारकोड एक आकार वस्तु पर खींचा जाता है। फ़ॉन्ट मोड के लिए 0। मुझे लगता है कि आपको फ़ॉन्ट प्रकार स्थापित करने की आवश्यकता है। उतना उपयोगी नहीं है।
     • 0 विशेष बारकोड प्रकार के लिए पैरामीटर है। QR_Code के लिए, 0 = कम त्रुटि सुधार, 1 = मध्यम त्रुटि सुधार, 2 = क्वार्टाइल त्रुटि सुधार, 3 = उच्च त्रुटि सुधार।
     • 2 केवल 1 डी कोड पर लागू होता है। यह बफर जोन है। मुझे यकीन नहीं है कि यह वास्तव में क्या करता है लेकिन शायद 1 डी बार रिक्त स्थान के साथ कुछ करने के लिए? बस

       Public Sub RenderQRCode(workSheetName As String, cellLocation As String, textValue As String) 
           Dim s_param As String 
           Dim s_encoded As String 
           Dim xSheet As Worksheet 
           Dim QRShapeName As String 
           Dim QRLabelName As String 
       
           s_param = "mode=Q" 
           s_encoded = qr_gen(textValue, s_param) 
           Call DrawQRCode(s_encoded, workSheetName, cellLocation) 
       
           Set xSheet = Worksheets(workSheetName) 
           QRShapeName = "BC" & "$" & Left(cellLocation, 1) _ 
            & "$" & Right(cellLocation, Len(cellLocation) - 1) & "#GR" 
       
           QRLabelName = QRShapeName & "_Label" 
       
           With xSheet.Shapes(QRShapeName) 
            .Width = 30 
            .Height = 30 
           End With 
       
           On Error Resume Next 
           If Not (xSheet.Shapes(QRLabelName) Is Nothing) Then 
            xSheet.Shapes(QRLabelName).Delete 
           End If 
       
           xSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, _ 
            xSheet.Shapes(QRShapeName).Left+35, _ 
            xSheet.Shapes(QRShapeName).Top, _       
            Len(textValue) * 6, 30) _ 
            .Name = QRLabelName 
       
       
           With xSheet.Shapes(QRLabelName) 
            .Line.Visible = msoFalse 
            .TextFrame2.TextRange.Font.Name = "Arial" 
            .TextFrame2.TextRange.Font.Size = 9 
            .TextFrame.Characters.Text = textValue 
            .TextFrame2.VerticalAnchor = msoAnchorMiddle 
           End With 
       End Sub 
       
       Sub DrawQRCode(xBC As String, workSheetName As String, rangeName As String, Optional xNam As String) 
       Dim xShape As Shape, xBkgr As Shape 
       Dim xSheet As Worksheet 
       Dim xRange As Range, xCell As Range 
       Dim xAddr As String 
       Dim xPosOldX As Double, xPosOldY As Double 
       Dim xSizeOldW As Double, xSizeOldH As Double 
       Dim x, y, m, dm, a As Double 
       Dim b%, n%, w%, p$, s$, h%, g% 
       
       Set xSheet = Worksheets(workSheetName) 
       Set xRange = Worksheets(workSheetName).Range(rangeName) 
       xAddr = xRange.Address 
       xPosOldX = xRange.Left 
       xPosOldY = xRange.Top 
       
       xSizeOldW = 0 
       xSizeOldH = 0 
       s = "BC" & xAddr & "#GR" 
       x = 0# 
       y = 0# 
       m = 2.5 
       dm = m * 2# 
       a = 0# 
       p = Trim(xBC) 
       b = Len(p) 
       For n = 1 To b 
           w = AscL(Mid(p, n, 1)) Mod 256 
           If (w >= 97 And w <= 112) Then 
           a = a + dm 
           ElseIf w = 10 Or n = b Then 
           If x < a Then x = a 
           y = y + dm 
           a = 0# 
           End If 
       Next n 
       If x <= 0# Then Exit Sub 
       On Error Resume Next 
       Set xShape = xSheet.Shapes(s) 
       On Error GoTo 0 
       If Not (xShape Is Nothing) Then 
           xPosOldX = xShape.Left 
           xPosOldY = xShape.Top 
           xSizeOldW = xShape.Width 
           xSizeOldH = xShape.Height 
           xShape.Delete 
       End If 
       On Error Resume Next 
       xSheet.Shapes("BC" & xAddr & "#BK").Delete 
       On Error GoTo 0 
       Set xBkgr = xSheet.Shapes.AddShape(msoShapeRectangle, 0, 0, x, y) 
       xBkgr.Line.Visible = msoFalse 
       xBkgr.Line.Weight = 0# 
       xBkgr.Line.ForeColor.RGB = RGB(255, 255, 255) 
       xBkgr.Fill.Solid 
       xBkgr.Fill.ForeColor.RGB = RGB(255, 255, 255) 
       xBkgr.Name = "BC" & xAddr & "#BK" 
       Set xShape = Nothing 
       x = 0# 
       y = 0# 
       g = 0 
       For n = 1 To b 
           w = AscL(Mid(p, n, 1)) Mod 256 
           If w = 10 Then 
           y = y + dm 
           x = 0# 
           ElseIf (w >= 97 And w <= 112) Then 
           w = w - 97 
           With xSheet.Shapes 
           Select Case w 
            Case 1: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape 
            Case 2: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape 
            Case 3: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape 
            Case 4: Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape 
            Case 5: Set xShape = .AddShape(msoShapeRectangle, x, y, m, dm): GoSub fmtxshape 
            Case 6: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape 
            Case 7: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x, y + m, m, m): GoSub fmtxshape 
            Case 8: Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape 
            Case 9: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape 
            Case 10: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, dm): GoSub fmtxshape 
            Case 11: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x + m, y + m, m, m): GoSub fmtxshape 
            Case 12: Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape 
            Case 13: Set xShape = .AddShape(msoShapeRectangle, x, y, m, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape 
            Case 14: Set xShape = .AddShape(msoShapeRectangle, x + m, y, m, m): GoSub fmtxshape 
              Set xShape = .AddShape(msoShapeRectangle, x, y + m, dm, m): GoSub fmtxshape 
            Case 15: Set xShape = .AddShape(msoShapeRectangle, x, y, dm, dm): GoSub fmtxshape 
           End Select 
           End With 
           x = x + dm 
           End If 
       Next n 
       On Error Resume Next 
       Set xShape = xSheet.Shapes(s) 
       On Error GoTo 0 
       If Not (xShape Is Nothing) Then 
           xShape.Left = xPosOldX 
           xShape.Top = xPosOldY 
           If xSizeOldW > 0 Then 
           xShape.Width = xSizeOldW 
           xShape.Height = xSizeOldH 
           End If 
       Else 
           If Not (xBkgr Is Nothing) Then xBkgr.Delete 
       End If 
       Exit Sub 
       fmtxshape: 
           xShape.Line.Visible = msoFalse 
           xShape.Line.Weight = 0# 
           xShape.Fill.Solid 
           xShape.Fill.ForeColor.RGB = RGB(0, 0, 0) 
           g = g + 1 
           xShape.Name = "BC" & xAddr & "#BR" & g 
           If g = 1 Then 
           xSheet.Shapes.Range(Array(xBkgr.Name, xShape.Name)).Group.Name = s 
           Else 
           xSheet.Shapes.Range(Array(s, xShape.Name)).Group.Name = s 
           End If 
           Return 
       
       End Sub 
       

       इस आवरण के साथ

       , अब आप कर सकते हैं:

मैं आवरण कार्यों यह नहीं बल्कि किसी कार्यपत्रक में एक सूत्र के रूप में उपयोग की तुलना में एक शुद्ध VBA समारोह कॉल करने के लिए जोड़ा वीबीए में इसे कॉल करके क्यूआरकोड प्रस्तुत करने के लिए कॉल करें:

Call RenderQRCode("Sheet1", "A13", "QR Value") 

बस वर्कशीट नाम, सेल इनपुट करें स्थान, और QR_value। आपके द्वारा निर्दिष्ट स्थान पर क्यूआर आकार खींचा जाएगा।

आप चारों ओर कोड के इस हिस्से के साथ QR

With xSheet.Shapes(QRShapeName) 
     .Width = 30 'change your size 
     .Height = 30 'change your size 
    End With 

Answer 2

मैं यह जानता हूँ का आकार बदलने के है काफी एक पुराने और अच्छी तरह से स्थापित पोस्ट खेल सकते हैं (हालांकि बहुत अच्छा मौजूदा जवाब नहीं किया गया है अभी तक स्वीकार किया गया है), लेकिन मैं एक वैकल्पिक विकल्प साझा करना चाहता हूं जिसे मैंने StackOverflow in Portuguese में एक ही पोस्ट के लिए तैयार किया है जो online API from QR Code Generator का उपयोग कर रहा है।

कोड है निम्नलिखित:

Sub GenQRCode(ByVal data As String, ByVal color As String, ByVal bgcolor As String, ByVal size As Integer) 
On Error Resume Next 

    For i = 1 To ActiveSheet.Pictures.Count 
     If ActiveSheet.Pictures(i).Name = "QRCode" Then 
      ActiveSheet.Pictures(i).Delete 
      Exit For 
     End If 
    Next i 

    sURL = "https://api.qrserver.com/v1/create-qr-code/?" + "size=" + Trim(Str(size)) + "x" + Trim(Str(size)) + "&color=" + color + "&bgcolor=" + bgcolor + "&data=" + data 
    Debug.Print sURL 

    Set pic = ActiveSheet.Pictures.Insert(sURL + sParameters) 
    Set cell = Range("D9") 

    With pic 
     .Name = "QRCode" 
     .Left = cell.Left 
     .Top = cell.Top 
    End With 

End Sub 

यह काम बस (री) द्वारा किया कोशिकाओं में मानकों से निर्मित URL से एक छवि बनाने हो जाता है। स्वाभाविक रूप से, उपयोगकर्ता को इंटरनेट से कनेक्ट होना चाहिए।

उदाहरण के लिए (वर्कशीट, ब्राज़ीलियाई पुर्तगाली में सामग्री के साथ, from 4Shared डाउनलोड किया जा सकता):