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

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

매크로를 이용하여 엑셀 셀에 2d 바코드(PDF417 또는 QR코드)를 생성하고 싶습니다.유료 도서관을 무료로 이용할 수 있는 대안이 있는지 궁금합니다.

어떤 도구들이 그 일을 할 수 있다는 것은 알지만, 우리에게는 상대적으로 비용이 많이 듭니다.

VBA 모듈 바코드-vba-macro-only(댓글에서 Sébastien Ferry에 의해 언급됨)는 2013년 MIT 라이선스 하에 Jiri Gabriel에 의해 만들어진 순수한 VBA 1D/2D 코드 생성기입니다.

코드가 완전히 이해하기 쉽진 않지만 위에 링크된 버전에서는 많은 댓글들이 체코어에서 영어로 번역되었습니다.

워크시트에서 사용하려면 barcody.bas를 모듈의 VBA로 복사하거나 가져오면 됩니다.워크시트에서 다음과 같은 함수를 입력합니다.

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

용도는 다음과 같습니다.

1. 나가세요CELL("SHEET)그리고.CELL("ADDRESS")워크시트와 셀 주소를 참조하는 것이기 때문에 공식이 있습니다.
   • A2는 문자열을 인코딩할 셀입니다.저 같은 경우는 A2 셀입니다. 따옴표를 붙여 "Text"를 전달하시면 됩니다.세포를 가지면 더 역동적이 됩니다.
   • QR코드는 51번이 선택 가능합니다.기타 옵션으로는 1=EAN8/13/UPCA/UPCE, 2=5개의 인터리브 중 2개, 3=Code39, 50=Data Matrix, 51=QR코드가 있습니다.
     • 1은 그래픽 모드를 위한 것입니다.바코드가 Shape 객체에 그려집니다.글꼴 모드의 경우 0.글꼴 종류를 설치해야 할 것 같습니다.별로 쓸모가 없습니다.
     • 0은 특정 바코드 유형의 매개 변수입니다.QR_Code의 경우 0=Low Error Correction, 1=Medium Error Correction, 2=Quartile Error Correction, 3=High Error Correction.
     • 2는 1D 코드에만 적용됩니다.완충구역입니다.정확히 어떤 역할을 하는지는 모르겠지만 아마도 1D 바 공간과 관련이 있을까요?

워크시트에서 수식으로 사용하는 대신 순수 VBA 함수 호출로 만들기 위해 래퍼 함수를 추가했습니다.

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에서 다음을 호출하여 QR 코드를 렌더링하기만 하면 됩니다.

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

워크시트 이름, 셀 위치, QR_값만 입력하면 됩니다.지정하신 위치에 QR 모양이 그려집니다.

QR의 크기를 변경하기 위해 코드의 이 섹션을 가지고 놀 수 있습니다.

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

저는 이것이 꽤 오래되고 잘 정립된 게시물이라는 것을 알고 있지만(기존의 매우 좋은 답변은 아직 수락되지 않았지만), QR 코드 생성기의 무료 온라인 API를 사용하여 포르투갈어로 StackOverflow에 유사한 게시물을 준비한 대안을 공유하고자 합니다.

코드는 다음과 같습니다.

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에서 이미지를 간단히(재) 생성하여 작업을 수행할 수 있습니다.당연히 사용자는 인터넷에 연결되어 있어야 합니다.

예를 들어, 브라질 포르투갈어로 된 내용이 포함된 워크시트는 4Shared에서 다운로드할 수 있습니다.

언급URL : https://stackoverflow.com/questions/16143331/generating-2d-pdf417-or-qr-barcodes-using-excel-vba