现在，二维码应用的越来越普遍了。很多时候，我们都需要生成二维码。而在Office家族中，我们可以通过VBA里的barcodectrl控件来生成条码和二维码。但是遇到中文字符的情况下，barcodectrl控件生成的效果就不理想了。
经过搜索，发现是因为excel中使用的编码解码后不支持中文，所以，阁主转向了zxing的怀抱。zxing是一个基于java语言的开源二维码/条码生成和识别库。已经有大牛将其封装为.net可用的形式zxing.net 版。阁主基于zxing.net库编写了一个excel生成二维码的加载项。
Imports Microsoft.Office.Tools.Ribbon
Imports ZXing.BarcodeFormat
Imports ZXing.QrCode.Internal.QRCode
Imports System.Drawing
Imports System.ComponentModel
Imports ZXing.QrCode.Internal
Public Class Ribbon1
Private Sub Ribbon1_Load(ByVal sender As System.Object, ByVal e As RibbonUIEventArgs) Handles MyBase.Load
DropDown1.SelectedItemIndex = My.Settings.Level
EditBox1.Text = My.Settings.size
For i As Integer = 0 To 40
Dim rf As RibbonFactory = Me.Factory
Dim tmpitem As RibbonDropDownItem = rf.CreateRibbonDropDownItem
tmpitem.Label = CStr(i)
ComboBox1.Items.Add(tmpitem)
Next
ComboBox1.Text = My.Settings.version
CheckBox1.Checked = My.Settings.changeSize
If CheckBox1.Checked Then
EditBox1.Enabled = True
Else
EditBox1.Enabled = False
End If
End Sub
Private Sub Button1_Click(sender As Object, e As RibbonControlEventArgs) Handles Button1.Click
Dim app As Global.Microsoft.Office.Interop.Excel.Application
Dim hitset As IDictionary(Of ZXing.EncodeHintType, Object) = New Dictionary(Of ZXing.EncodeHintType, Object)
hitset.Add(ZXing.EncodeHintType.CHARACTER_SET, "utf-8")
hitset.Add(ZXing.EncodeHintType.DISABLE_ECI, getDisableEci)
hitset.Add(ZXing.EncodeHintType.ERROR_CORRECTION, getErrorCurrentLevel)
hitset.Add(key:=ZXing.EncodeHintType.MARGIN, value:=0)
If ComboBox1.Text <> "0" Then hitset.Add(key:=ZXing.EncodeHintType.QR_VERSION, value:=CInt(ComboBox1.Text))
app = Globals.ThisAddIn.Application
Dim img As New ZXing.QrCode.QRCodeWriter
Dim bitmat As ZXing.Common.BitMatrix
Dim bw As New ZXing.BarcodeWriter
Dim bitmap1 As Bitmap
Dim str As String
Try
Dim frm As New Form1
frm.ShowDialog()
str = frm.TextBox1.Text
If String.IsNullOrEmpty(str) Then
app = Nothing
img = Nothing
bw = Nothing
frm.Dispose()
Exit Sub
End If
Catch ex As Exception
app = Nothing
img = Nothing
bw = Nothing
Exit Sub
End Try
Dim s2 As Integer()
Try
bitmat = img.encode（str, format:=ZXing.BarcodeFormat.QR_CODE, width:=My.Settings.size, height:=My.Settings.size, hints:=hitset)
Dim actsh As Global.Microsoft.Office.Interop.Excel.Worksheet = Globals.ThisAddIn.Application.ActiveSheet
s2 = bitmat.getEnclosingRectangle
Dim btmp As New Bitmap(s2(2) + 4, s2(3) + 4)
For i As Integer = -2 To s2(2) + 1
For j As Integer = -2 To s2(3) + 1
If i >= 0 And i < s2(2) And j >= 0 And j < s2(3) Then
If bitmat.Item(i + s2(0), j + s2(1)) Then
btmp.SetPixel(i + 2, j + 2, color:=Color.Black)
Else
btmp.SetPixel(i + 2, j + 2, color:=Color.White)
End If
Else
Try
btmp.SetPixel(i + 2, j + 2, color:=Color.White)
Catch exx As Exception
MsgBox(exx.Message & i & j)
End Try
End If
Next
Next
#If DEBUG Then
#End If
'bitmap1 = bw.Write(bitmat)
If My.Settings.changeSize Then
bitmap1 = New Bitmap(btmp, Math.Max(My.Settings.size, s2(2) + 4), Math.Max(My.Settings.size, s2(3)) + 4)
Else
bitmap1 = btmp
End If
System.Windows.Forms.Clipboard.SetDataObject(bitmap1, True)
actsh.Paste(app.ActiveCell, bitmap1)
app = Nothing
img = Nothing
bw = Nothing
Catch ex As Exception
MsgBox(ex.Message)
app = Nothing
img = Nothing
bw = Nothing
End Try
End Sub
Private Sub DropDown1_SelectionChanged(sender As Object, e As RibbonControlEventArgs) Handles DropDown1.SelectionChanged
My.Settings.Level = DropDown1.SelectedItemIndex
My.Settings.Save()
#If DEBUG Then
My.Settings.Reload()
MsgBox(My.Settings.Level)
#End If
End Sub
Private Sub DropDown1_ItemsLoading(sender As Object, e As RibbonControlEventArgs) Handles DropDown1.ItemsLoading
End Sub
Private Function getDisableEci() As Boolean
getDisableEci = My.Settings.disable_eci
End Function
Private Function getErrorCurrentLevel() As ZXing.QrCode.Internal.ErrorCorrectionLevel
Select Case My.Settings.Level
Case 0
getErrorCurrentLevel = ErrorCorrectionLevel.L
Case 1
getErrorCurrentLevel = ErrorCorrectionLevel.M
Case 2
getErrorCurrentLevel = ErrorCorrectionLevel.Q
Case 3
getErrorCurrentLevel = ErrorCorrectionLevel.H
Case Else
getErrorCurrentLevel = ErrorCorrectionLevel.H
End Select
End Function
Private Sub EditBox1_TextChanged(sender As Object, e As RibbonControlEventArgs) Handles EditBox1.TextChanged
Dim i As Integer, chr As Char(), j As String
j = ""
chr = EditBox1.Text.ToCharArray()
For i = LBound(chr) To UBound(chr)
If IsNumeric(chr(i)) Then
j = j & chr(i)
End If
Next
If String.IsNullOrEmpty(j) Then
EditBox1.Text = My.Settings.size
Else
EditBox1.Text = Math.Max(Math.Min(1024, CInt(j)), 21)
My.Settings.size = Math.Max(Math.Min(1024, CInt(j)), 21)
My.Settings.Save()
End If
End Sub
Private Sub ComboBox1_TextChanged(sender As Object, e As RibbonControlEventArgs) Handles ComboBox1.TextChanged
If IsNumeric(ComboBox1.Text) Then
If CInt(ComboBox1.Text) >= 1 And CInt(ComboBox1.Text) <= 40 Then
ComboBox1.Text = CInt(ComboBox1.Text)
Else
ComboBox1.Text = My.Settings.version
End If
End If
End Sub
Private Sub CheckBox1_Click(sender As Object, e As RibbonControlEventArgs) Handles CheckBox1.Click
If CheckBox1.Checked Then
EditBox1.Enabled = True
Else
EditBox1.Enabled = False
End If
My.Settings.changeSize = CheckBox1.Checked
My.Settings.Save()
End Sub
End Class
Public Class Form1
Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
TextBox1.Text = Globals.ThisAddIn.Application.ActiveCell.Text
End Sub
Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
MyBase.Hide()
End Sub
End Class
链接: https://pan.baidu.com/s/1TzaWjwKlHAjYEDKOcgS-fw 提取码: q2xu
本站小水管：excelQRcode_1.0.0.5
定义
形容词showing stylish excellence.
名词a set or category of things having some property or attribute in common and differentiated from others by kind, type, or quality.
动词assign or regard as belonging to a particular category.
同义词
形容词classy; decent; gracious; respectable; noble
名词category; grade; rating; classification; group; grouping
动词classify; categorize; group; grade; order; sort; codify; bracket; designate; label; pigeonhole
