| MSDE FunClub |
|
最終更新日 : 2000/10/23 |
| Microsoft Data Engine FunClub |
|
|
| SQLServer7.0/MSDE 完全トレーニングテキスト（下巻） | ||
|
【第１８章例題８】 内部形式ファイルを利用したimage型データ操作 |
||
| MSDE FunClub |
|
最終更新日 : 2000/10/23 |
| Microsoft Data Engine FunClub |
|
|
| SQLServer7.0/MSDE 完全トレーニングテキスト（下巻） | ||
|
【第１８章例題８】 内部形式ファイルを利用したimage型データ操作 |
||
CREATE TABLE FILEDB (
ID char(6) PRIMARY KEY , --レコード識別文字列６桁
FNAME varchar(128) , --ファイル名を記憶する
DAT image --ファイルの中身
)
'
'********************************************************************
'
' 【ファイル管理データベース】
'
' このプログラムは、ファイルの内容をimage型データとしてMSDE/SQLServer7.0
' で管理するものです
'
' （株）日本技術ソフト開発 堀川 明
' http://www.horikawa.ne.jp/msde/
'
'********************************************************************
'
Option Explicit
Const ServerName = "DB_Server_Name" '接続先データベースサーバーの名前
Const LoginName = "Login_Name" 'ログイン名
Const PassWord = "PassWord" 'パスワード
Const DBNAME = "DB_Name" 'データベースの名前
Const SQL7PATH = "D:\MSSQL7\BINN" 'MSDE/SQL7のコマンドが存在する場所
Const SQL7DRIVE = "D:" 'インストールしたドライブ名
Const WORKFN = "D:\Test\Work.tmp" '一時作業用ファイル名
'Windows-API関数宣言
Const PROCESS_ALL_ACCESS = 2035711
Const TRUE_API = 1
Const INFINITE = -1
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
'
'********************************************
' フォーム読み込み時の初期化処理
'********************************************
'
Private Sub Form_Load()
'アプリケーションのカレントディレクトリを設定する
ChDir SQL7DRIVE
ChDir SQL7PATH
'MsgBox CurDir
End Sub
'
'********************************************
' データベースを新規に作成します（初期化処理）
'********************************************
'
Private Sub CMDCreate_Click()
Dim sql$
If MsgBox("既存のDBを削除して、DBを新規に作成します。よろしいですか？", vbOKCancel + vbDefaultButton2, "DBの新規作成") = vbCancel Then
MsgBox "キャンセルしました", , "中止"
Exit Sub
End If
'DB新規作成のSQL文
sql$ = "IF EXISTS( SELECT name FROM master..sysdatabases WHERE( name = '" & DBNAME & "') )" & vbCrLf & _
" BEGIN " & vbCrLf & _
" DROP DATABASE " & DBNAME & vbCrLf & _
" END " & vbCrLf & _
"CREATE DATABASE " & DBNAME & vbCrLf
ExecQuery sql$
MsgBox DBNAME & "データベースを作成しました", , "DB作成"
End Sub
'
'********************************************
' テーブルの作成処理
'********************************************
'
Private Sub CMDTBL_Click()
Dim sql$
If MsgBox("既存のテーブルを削除して、テーブルを新規に作成します。よろしいですか？", vbOKCancel + vbDefaultButton2, "テーブルの新規作成") = vbCancel Then
MsgBox "キャンセルしました", , "中止"
Exit Sub
End If
'DB新規作成のSQL文
sql$ = "USE " & DBNAME & vbCrLf & _
"IF EXISTS( SELECT name FROM sysobjects WHERE( name = 'FILEDB' AND type = 'U ') )" & vbCrLf & _
" BEGIN " & vbCrLf & _
" DROP TABLE FILEDB " & vbCrLf & _
" END " & vbCrLf & _
"CREATE TABLE FILEDB ( " & vbCrLf & _
" ID char(6) PRIMARY KEY , " & vbCrLf & _
" FNAME varchar(128) , " & vbCrLf & _
" DAT image " & vbCrLf & _
")"
ExecQuery sql$
MsgBox DBNAME & "テーブルを作成しました", , "テーブルの作成"
End Sub
'
'********************************************
' ファイル名の選択
' コモンダイアログコントロール操作
'********************************************
'
Private Sub CMDFile_Click()
Dim fnm
CommonDialog1.Filter = "すべてのﾌｧｲﾙ(*.*)|*.*"
CommonDialog1.ShowOpen
Me!FNAME = CommonDialog1.FileName
End Sub
'
'********************************************
' テーブルにレコードを書き込む
'********************************************
'
Private Sub CMDUP_Click()
Dim dt&
'チェック
If Me!ID = "" Then Exit Sub
If Len(Me!ID) <> 6 Then Exit Sub '主キーは６文字
If Me!FNAME = "" Then Exit Sub
'ファイルが存在しないとダメ
On Error GoTo NO_FILE
dt = FileLen(Me!FNAME)
On Error GoTo 0
GoTo L100
NO_FILE:
On Error GoTo 0
MsgBox "ファイル名[" & Me!FNAME & "]が存在しません", , "ファイルがありません"
Exit Sub
L100:
Dim fno%, fno2%, ln%, pk$, fn$, cmd$, fln&, i&, tid&, phd&
Dim cb As Byte
'作業用ファイルを削除する
DELWORKFN
'レコード挿入用データファイルを作成する
'[6バイト][２バイト（大きさ）][varchar文字列][４バイト（大きさ）][ファイル本体]
'このようなレコードを作成する
fno = FreeFile
Open WORKFN For Binary As #fno
'先頭６バイトの書き込み
pk$ = Me!ID
Put #fno, , pk$
'ファイル名の文字数（Shift-JISの文字数計算）
fn$ = Me!FNAME
ln% = LenB(StrConv(fn$, vbFromUnicode))
Put #fno, , ln%
Put #fno, , fn$
'ファイル本体の大きさ
fln& = FileLen(fn$) 'バイト数
Put #fno, , fln& '４バイトで書き込む
'ファイルの中身の転送
fno2 = FreeFile
Open fn$ For Binary As #fno2
For i& = 0 To (fln& - 1)
Get #fno2, , cb
Put #fno, , cb
Next
Close #fno2
'作業用ファイルの作成
Close #fno
'レコード挿入bcpコマンドの作成
cmd$ = "bcp " & DBNAME & "..FILEDB in " & WORKFN & " -n -S" & _
ServerName & " -U" & LoginName & " -P" & PassWord
MsgBox cmd$, , "BCPコマンドによりレコード挿入処理の実行"
tid& = Shell(cmd$)
'プロセスのハンドルに変換する
phd& = OpenProcess(PROCESS_ALL_ACCESS, TRUE_API, tid&)
'プロセスが終了するまで待機する
WaitForSingleObject phd&, INFINITE
CloseHandle phd&
MsgBox "データベースに書き込みました", , "終了しました"
End Sub
'
'********************************************
' レコードを取得する
'********************************************
'
Private Sub CMDDown_Click()
Dim dt&
Dim fno%, fno2%, ln%, i&, pk$, fn$, cmd$, fln&, tid&, phd&
Dim cb As Byte
'チェック
If Me!ID = "" Then Exit Sub
If Len(Me!ID) <> 6 Then Exit Sub '主キーは６文字
If Me!FNAME = "" Then Exit Sub
'念ため、存在するファイル名はダメ
fn$ = Me!FNAME
On Error GoTo NO_FILE
dt = FileLen(fn$)
On Error GoTo 0
MsgBox "同じ名前のファイル名があります。上書き禁止です", , _
"存在しないファイル名を入力してください"
Exit Sub
NO_FILE:
On Error GoTo 0
'作業用ファイルを削除する
DELWORKFN
'レコード取得bcpコマンドの作成
cmd$ = "bcp ""SELECT * FROM " & DBNAME & "..FILEDB WHERE(ID='" & Me!ID & "') """ & _
" queryout " & WORKFN & " -n -S" & _
ServerName & " -U" & LoginName & " -P" & PassWord
MsgBox cmd$, , "BCPコマンドによりレコード取得処理の実行"
'タスクIDを取得
tid& = Shell(cmd$)
'プロセスのハンドルに変換する
phd& = OpenProcess(PROCESS_ALL_ACCESS, TRUE_API, tid&)
'プロセスが終了するまで待機する
WaitForSingleObject phd&, INFINITE
CloseHandle phd&
'レコード挿入用データファイルを作成する
'[6バイト][２バイト（大きさ）][varchar文字列][４バイト（大きさ）][ファイル本体]
'このようなレコードを作成する
fno = FreeFile
Open WORKFN For Binary As #fno
'先頭６バイトの読み込み
pk$ = "123456"
Get #fno, , pk$
MsgBox pk$, , "読み出した主キーの値"
'ファイル名の文字数（Shift-JISの文字数）
Get #fno, , ln%
'ファイル名の読み出し
Dim cba() As Byte
ReDim cba(ln%)
'１バイト単位で文字コードの読み出し（シフトJISコード）
For i = 0 To (ln% - 1): Get #fno, , cb: cba(i) = cb: Next
MsgBox StrConv(cba, vbUnicode), , "読み出したファイル名"
Erase cba()
'ファイル本体の大きさ
Get #fno, , fln&
'ファイルの中身の転送
fno2 = FreeFile
Open fn$ For Binary As #fno2
For i& = 0 To (fln& - 1)
Get #fno, , cb
Put #fno2, , cb
'***Debug.Print cb
Next
Close #fno2
'作業用ファイルの作成
Close #fno
MsgBox "データベースからファイルの内容を取得しました", , "終了"
End Sub
'
'********************************************
' 更新系クエリーの実行を行ないます
'********************************************
'
Sub ExecQuery(sql$)
Dim cmd$
'OSQLコマンドによる実行
cmd$ = "OSQL -S" & ServerName & " -U" & LoginName & " -P" & PassWord & _
" -Q""" & sql$ & """"
MsgBox cmd$
'SHELLによるコマンドの実行
Shell cmd$
End Sub
'
'********************************************
' 作業用ファイルを削除する
'********************************************
'
Sub DELWORKFN()
On Error GoTo L10 '削除するファイルが存在しないとエラーの発生
Kill WORKFN
L10:
On Error GoTo 0
End Sub
