| |
こんにちは。
何度も申し訳ないです。
先ほどのエラーは以下の追加箇所と変更箇所（**で囲ってあります）で
解決しました。
ただ、実行してもエラーは出ないのですがファイルサイズはいつまでたっても
０のままで砂時計になります。
やはり元の形式（アクセスに取り込むファイル）がjpegで
このプログラムはbmp形式だからでしょうか。
とりあえず途中報告です。
データが重いだけかもしれませんのでもう少し様子を見ます。
Function DWriteChunk(fieldname As String, _
tablename As String, _
filename As String, _
Optional criteria As String, _
Optional ByVal offset As Long, _
Optional ByVal numbytes As Long) As String
On Error GoTo ErrorHandler
' 定数/変数宣言部
Const ERR_INVARID_DATA_TYPE = 3259
Dim rs As DAO.Recordset
Dim strSQL As String
Dim varChunk As Variant
Dim abytChunk() As Byte
Dim FileNo As Integer
Dim strConnect As String
Dim db As DAO.Database
***********************************************************
*****************追記箇所**********************************
***********************************************************
'-- ODBC 接続文字列の指定
strConnect = "ODBC;Driver={SQL Server};Server=sgw9920sv4;" & _
"Database=資産管理SQL;UID=hoken;PWD=hoken;"
'-- 接続文字列を使用して SQL Server に接続する
Set db = DBEngine.OpenDatabase("", False, False, strConnect)
***********************************************************
*****************追記箇所終了******************************
***********************************************************
' 変数を初期化します。
FileNo = FreeFile
strSQL = "Select " & fieldname & " From " & tablename
If (LenB(criteria) <> 0) Then strSQL = strSQL & " Where " & criteria
strSQL = strSQL & ";"
' ファイルとレコードセットを開きます。
Open filename For Binary As #FileNo
***********************************************************
*****************変更箇所**********************************
***********************************************************
' Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
Set rs = db.OpenRecordset(strSQL, dbOpenSnapshot)
***********************************************************
*****************追記箇所終了******************************
***********************************************************
' データ型をチェックします。
Select Case rs(0).Type
Case dbLongBinary, dbMemo
' OK
Case Else
Err.Raise ERR_INVARID_DATA_TYPE
End Select
' データをファイルに書き込みます。
With rs
If (numbytes = 0) Then numbytes = .Fields(fieldname).FieldSize
varChunk = .Fields(fieldname).GetChunk(offset, numbytes)
abytChunk = varChunk
Put #FileNo, , abytChunk
End With
ExitProcedure:
On Error Resume Next
Close #FileNo
rs.Close: Set rs = Nothing
Exit Function
ErrorHandler:
DWriteChunk = Err.Number & ":" & vbCrLf & Err.Description
Resume ExitProcedure
End Function
Private Sub コマンド26_Click()
Const BMP_OFFSET = 87
Dim strResp As String
strResp = DWriteChunk( _
"写真", _
"T_購入_写真", _
"C:\" & "テスト.bmp", _
"[管理No.]=0000000001-001", _
BMP_OFFSET)
If (LenB(strResp) = 0) Then strResp = "完了"
MsgBox strResp
End Sub
|
|
o
- 06/3/16(木) 15:54 -
