vb-oboegaki blog　ＶＢ開発者の覚書

ＶＳ2008でCrystalReportにバーコード画像を表示する場合の覚書
'デンソーウェーブのバーコードライブラリを使用している
'VS2005でも同様に使用できると思われる
'======================================================
'印刷用のルーチン
'======================================================
Sub PRLOOP(ByVal S99 As String, ByVal S00 As String, ByVal S11 As String)
Dim crExportOptions As CrystalDecisions.Shared.ExportOptions
Dim crDiskFileDestinationOptions As CrystalDecisions.Shared.DiskFileDestinationOptions
Dim fm As New PrintBase
Dim SQLC As New SqlClient.SqlConnection
Dim TR, DEF_P, S, S0, S9, PR_PATH, Fname, PPJ, D_NM, NOW_PRT As String
Dim i%
Dim DsP As New DataSet
With fm
'レポートファイルの実際の場所の特定
'実行時のディレクトリ以下の「ＲＰＴ」ディレクトリに格納
'
On Error GoTo 0
PPJ = AppName
i = InStr(AppName, ".")
If i > 0 Then
PPJ = Mid(PPJ, 1, i - 1)
End If
S = AppPath
i = InStr(UCase(S), UCase("\BIN\"))
If i > 0 Then
'DEBUG
S = Mid(AppPath, 1, i - 0) & "RPT\"
Else
S = AppPath & "\RPT\"
End If
'i = InStr(UCase(S), UCase(CStr(PPJ)))
'If i > 0 Then
'S = Mid(S, 1, i - 1) & PPJ & "\RPT\"
'End If
If Microsoft.VisualBasic.Right(S, 1) <> "\" Then S = S & "\"

PR_PATH = S
Fname = ""
D_NM = ""
S9 = ""
Fname = S & "QRTEST.rpt"
D_NM = "TESTDATA"

fm.Cr1.Load(Fname)
's = Cr1.FilePath

On Error Resume Next
S = ""
On Error GoTo 0
Dim tb2 As New DataTable
DsP.Tables.Add(tb2)
clmSet("PNO", DsP, "System.String")
　　　　　'イメージはＢｙｔｅ配列で格納
clmSet("PIMAGE", DsP, "System.Byte[]")
clmSet("HNO", DsP, "System.String")
　　　　　'印刷用テーブルにカラムをセット
fm.CR0.ReportSource = fm.Cr1
'------
For i = 1 To 5
Dim rr As DataRow = tb2.NewRow
S0 = nFormat(i, "000")
rr("PNO") = S0
　　　　　　　'ＱＲコードは改行も受け付ける
S = S0 & "//0900-234" & vbCrLf
S = S & "漢字テスト" & vbCrLf
S = S & "品名ＯＫ" & Format(Now, "yyyy/MM/dd") & vbCrLf
rr("HNO") = S
Dim BB As New Bitmap(300, 300)


Dim memstream As MemoryStream = New MemoryStream

Call QRDISP(S, BB)
PictureBox1.Image = BB
Dim byteData As Byte()
BB.Save(memstream, Imaging.ImageFormat.Bmp)
byteData = memstream.ToArray

rr("PIMAGE") = byteData
DsP.Tables(0).Rows.Add(rr)
memstream.Close()
Next

'
If DsP.Tables(0).Rows.Count > 0 Then

Dim sds As New DataSet

Dim clm As New DataColumn
'===============================================
DsP.Tables(0).TableName = D_NM
.Cr1.Database.Tables(D_NM).SetDataSource(DsP.Tables(D_NM))
'===============================================


.CR0.Text = "一覧表"

.CR0.RefreshReport()

.Width = Me.Width
.Height = Me.Height
.Top = Me.Top
.Left = Me.Left
.CR0.DisplayGroupTree = False
.CR0.ShowGroupTreeButton = False
.CR0.Left = 0
.CR0.Top = 0
.CR0.DisplayBackgroundEdge = True
TR = ""
S = Prt_GET_REG("NO04", TR)
'デフォルトプリンターの確認
DEF_P = Get_Def_Printer()
If S = "" Then
.Cr1.PrintOptions.PrinterName = DEF_P
Else
.Cr1.PrintOptions.PrinterName = S
Call Set_Printer(S)
End If
NOW_PRT = .Cr1.PrintOptions.PrinterName
.Cr1.PrintOptions.PaperSize = CrystalDecisions.[Shared].PaperSize.PaperA4
.Cr1.PrintOptions.PaperOrientation = CrystalDecisions.[Shared].PaperOrientation.Landscape '= CrystalDecisions.[Shared].PaperOrientation.Landscape
.CR0.Width = fm.Width - 0
.CR0.Height = fm.Height '- Me.STAT.Height
.CR0.Visible = True
.CR0.ShowCloseButton = True
.Text = "一覧表表示印刷"
.Top = Me.Top
.Left = Me.Left
.WindowState = FormWindowState.Maximized

Me.Visible = False
.ShowDialog(Me)
Me.Visible = True
'もしデフォルトプリンターに変更があれば元に戻す。
If NOW_PRT <> DEF_P Then
On Error Resume Next
Call Set_Printer(DEF_P)
On Error GoTo 0
End If
Else
MsgBox("該当するデータはありません。")
End If

End With

End Sub
'==========================================================
'DataSetにカラムを追加するサブルーチン
'==========================================================
Sub clmSet(ByVal nm As String, ByVal Dsp As DataSet, ByVal Tp As String)
Dim clm As New DataColumn
clm.ColumnName = nm
clm.DataType = Type.GetType(Tp)
If InStr(UCase(Tp), "STRING") > 0 Then
clm.DefaultValue = ""
Else
clm.DefaultValue = DBNull.Value
End If
Dsp.Tables(0).Columns.Add(clm)

End Sub
'=======================================================
'QRコードをビットマップに表示するルーチン
'=======================================================
Sub QRDISP(ByVal QR_S As String, ByVal PP As Bitmap)
Dim bc1 As System.DotNetBarcode = New System.DotNetBarcode
Dim g As Graphics = Graphics.FromImage(PP)
g.Clear(Color.White)

bc1.Type = System.DotNetBarcode.Types.QRCode
bc1.PrintCheckDigitChar = True
bc1.WriteBar(QR_S, 0, 0, PP.Width, PP.Height, g)
End Sub