Excel VBA를 사용하여 2D (PDF417 또는 QR) 바코드 생성

Question

매크로를 사용하여 Excel 셀에 2 차원 바코드 (PDF417 또는 QR 코드)를 생성하고 싶습니다. 이 작업을 수행하기 위해 유료 라이브러리에 대한 무료 대안이 있습니까?

나는 certain tools이 일을 할 수는 있지만 우리에게는 상대적으로 비쌉니다.

Answer 1

VBA를 모듈 barcode-vba-macro-only (코멘트에 세바스티앙 페리 언급) 코드는 이해하기 완전히 간단하지 않다 2013 년

에 MIT 라이센스에 따라 지리산 가브리엘에 의해 생성 된 순수한 VBA 1D/2D 코드 생성기입니다, 그러나 위에 링크 된 버전에서 많은 코멘트가 체코 어에서 영어로 번역되었습니다.

워크 시트에서 사용하려면 barcody.bas을 복사하여 모듈의 VBA로 가져 오면됩니다.

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

사용법은 다음과 같다 : 그것은 그냥 워크 시트 셀 주소로 참조를주고 있기 때문에있는 그대로

1. 는 CELL("SHEET) 및 CELL("ADDRESS")을 남겨 워크 시트에서이 같은 기능에 넣어 당신은 수식
   • 입니다. A2는 인코딩 할 문자열이있는 셀입니다. 제 경우에는 셀 A2입니다. 따옴표를 사용하여 "텍스트"를 전달하면됩니다. 셀을 사용하면 더욱 역동적입니다.
   • 51은 QR 코드의 옵션입니다. 다른 옵션 = QRCode의
     • 1 그래픽 모드 1 = EAN8/13/UPCA/UPCE 2 = 다섯 인터리브, 코드 39 (3) = 두 50 = 데이터 매트릭스 (51)이다. 바코드는 Shape 객체에 그려집니다. 글꼴 모드는 0입니다. 글꼴 유형을 설치해야한다고 가정합니다. 유용하지 않습니다.
     • 0은 특정 바코드 유형의 매개 변수입니다. QR_Code의 경우 0 = 오류 수정, 1 = 중간 오류 수정, 2 = 4 분의 1 오류 수정, 3 = 높은 오류 수정.
     • 2는 1D 코드에만 적용됩니다. 그것은 완충 지대입니다. 정확히 정확히 무엇을할지는 모르겠지만 1D 막대 공간과 관련이있을 것입니다. 단순히 지금 당신이 할 수있는,이 래퍼로

       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") 

그냥 워크 시트 이름 인 cell을 입력하기 만하면 VBA에서이 코드를 호출하여 QRCode를 렌더링합니다. 위치 및 QR_value. QR 모양은 지정한 위치에 그려집니다.아주 좋은 기존의 대답은하지 않았다 비록

당신은 (나는 이것을 알고있는 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을 다운로드 할 수 있습니다) :