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

CrystalReportで画像を表示する方法のＶＢ6版　覚書
'===========================================
'ローカルのアクセステーブルに印刷用のファイルを登録し
'CrystalReportで表示する
'このバーコードはフリーのMiBarcode.EXEのＤＤＥ機能を利用して
'印刷している
'=======================================
Option Explicit
'アクセスのＯＬＥオブジェクト型のデータに登録する場合
'アクセスで表示する場合は、ＢＩＴMAPをそのまま、Ｂｙｔｅ
'変数に変換して登録すればよいが、クリスタルレポートでは
'先頭にダミーバイトを挿入する必要がある。
'そのためのおまじない変数宣言
Dim CHUNK_B(98) As Byte
'BITMAPをＢｙｔｅ変数に格納するための宣言
Dim CH_BG() As Byte

'==============================================
'データをローカルのアクセスＤＢに登録するルーチン
'==============================================
Private Sub OK_B_Click()
Dim i%, j%, FH%
Dim S, XDIR, strDummy As String
Dim xdb As New ADODB.Connection
Dim ds As New ADODB.Recordset
Dim TEMP As Object
XDIR = App.Path
'実行環境ディレクトリ以下のＤＡＴＡディレクトリにデータベース
'を保存
S = ""
S = S & "Provider=Microsoft.Jet.OLEDB.4.0;"
S = S & "Data Source=" & App.Path & "\data\WORK.mdb;"
S = S & "Persist Security Info=False"
xdb.ConnectionString = S
xdb.Open

'クリスタルレポート上では、商品とＰＩＭAGEの２つのテーブルを
'使用して表示させる。
'商品データの登録
S = "select * from 商品"
S = S & " where PNO=" & Xtext(SH_PNO.Text)
ds.Open S, xdb, adOpenDynamic, adLockPessimistic
On Error Resume Next
ds.MoveFirst
If Err.Number = 0 And Not ds.EOF Then
Else
ds.AddNew
End If
On Error GoTo 0
ds("PNO").Value = SH_PNO.Text
ds("名称").Value = SH_名称.Text
ds("品番").Value = SH_品番.Text
ds("型番").Value = SH_型番.Text
ds.Update
ds.Close
'----
'ＤＤＥをサポートしたバーコード表示ルーチンを使用して
'フォーム上に張り付けたＰｉｃｔｕｒｅ1にバーコードを表示させる
'ルーチン
Call OLE_DISP

SavePicture Picture1.Image, XDIR & "\QRBAR.BMP"
DoEvents
'
S = "select * from PIMAGE"
S = S & " where PNO=" & Xtext(SH_PNO.Text)
ds.Open S, xdb, adOpenDynamic, adLockPessimistic
On Error Resume Next
ds.MoveFirst
If Err.Number = 0 And Not ds.EOF Then
Else
ds.AddNew
End If
On Error GoTo 0
ds("PNO").Value = SH_PNO.Text
On Error GoTo 0
'ビットマップをバイナリでオープンして、Ｂｙｔｅ配列に読み込む
FH = FreeFile
Open XDIR & "\QRBAR.bmp" For Binary As #FH
ReDim CH_BG(LOF(FH))
Get #FH, , CH_BG
Close #FH
'画像データはＯＬＥオブジェクト型で設定
'クリスタルレポート用に、ダミー配列を登録
ds("PIMAGE").AppendChunk (CHUNK_B)
'実際のＢＩＴＭＡＰデータを登録
ds("PIMAGE").AppendChunk (CH_BG)

ds.Update
ds.Close
xdb.Close

End Sub
'=======================================================
'DDE機能を使用して、PicturerにバーコードＢｉｔMapを張り付ける
'=======================================================
Sub OLE_DISP()
Dim MiBar As New Mibarcd.Auto
With MiBar
.Show (0)
.Code = "" & SH_PNO.Text & "::" & SH_名称.Text & "::" & SH_型番.Text & "::" & SH_品番.Text & ";"
.CodeType = 12 'QR2"QR2"
.QRVersion = 8
.QRErrLevel = 1 '"M"
.HMargin = 5
.BarScale = 2
.CopyType = 1
.Execute
Picture1.Picture = Clipboard.GetData
End With
End Sub