Lightbox Info Board : SQLの窓

DB.bas by Lightbox


Global ConnectionString As String

' ******************************************************
' DB接続(SQLServer)
'
' 【戻り値】: 接続済みの Connection オブジェクト
' ******************************************************
Public Function lbSQS_DBConnect( _
    Server As String, _
    DB As String, _
    User As String, _
    Pass As String _
) As Object

    ConnectionString = _
        "Provider=SQLOLEDB;" & _
        "Data Source=" & Server & ";" & _
        "Initial Catalog=" & DB & ";" & _
        "User ID=" & User & ";" & _
        "Password=" & Pass & ";"
    
    Set lbSQS_DBConnect = CreateObject("ADODB.Connection")
    lbSQS_DBConnect.Open ConnectionString

End Function

' ******************************************************
' DB接続(MDB)
'
' 【戻り値】: 接続済みの Connection オブジェクト
' ******************************************************
Public Function lbMDB_DBConnect( _
    MdbPath As String _
) As Object

    ConnectionString = _
        "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & MdbPath & ";"
    
    Set lbMDB_DBConnect = CreateObject("ADODB.Connection")
    lbMDB_DBConnect.Open ConnectionString

End Function

' ******************************************************
' DB読込み
' Visual Basic では、既定値は ByRef であるが
' 使用法的に Rs は I/O なので明示
'
' 【戻り値】: True(データ有り),False(データ無し)
' ******************************************************
Public Function lbDBGet( _
    Cn As Object, _
    ByRef Rs As Object, _
    SqlQuery As String, _
    bUpadateFlg As Boolean _
) As Boolean
    
    ' Rs がObject変数として初期状態の時のみ実行
    If TypeName(Rs) = "Nothing" Then
        Set Rs = CreateObject("ADODB.Recordset")
    End If
    
    ' 閉じていない時は閉じる
    If Rs.State >= 1 Then
        Rs.Close
    End If
    
    ' 更新処理に使用する場合は、レコード単位の共有的ロック
    If bUpadateFlg Then
        Rs.LockType = 3
    End If
    
    ' レコードセット作成
    Rs.Open SqlQuery, Cn
    If Rs.EOF Then
        lbDBGet = False
    Else
        lbDBGet = True
    End If

End Function

' ******************************************************
' DB終了処理(接続を閉じる)
' ******************************************************
Public Function lbDBClose( _
    ByRef CnRs As Object _
) As Boolean
    
    On Error Resume Next
    If CnRs.State >= 1 Then
        CnRs.Close
    End If

'    Set CnRs = Nothing

    lbDBClose = True

End Function

' ******************************************************
' コンボボックス設定(DBより)
' ******************************************************
Public Function lbSetListFromSQL( _
    Cn As Object, _
    Rs As Object, _
    Target As Variant, _
    SqlQuery As String _
)
    
    Dim idx As Integer
    
    idx = 0
    Target.Clear
    
    If lbDBGet(Cn, Rs, SqlQuery, False) Then
        Do While Not Rs.EOF
            Target.AddItem Rs.Fields(1).Value
            Target.ItemData(idx) = Rs.Fields(0).Value
            idx = idx + 1
            Rs.MoveNext
        Loop
    End If

    lbDBClose (Rs)

End Function

処理サンプル



Dim Cn As Object
Dim Rs As Object
Dim SqlQuery As String
Dim strWeek(8) As String

' ******************************************************
' 初期処理
' ******************************************************
Private Sub Form_Load()

    ' --------------------------------------------------
    ' フォームの位置
    ' --------------------------------------------------
    Me.Move 0, 0, Screen.Width, Screen.Height - 32

    ' --------------------------------------------------
    ' 基準日初期値
    ' --------------------------------------------------
    With dtp指定日
        .Value = Format(Now, "YYYY/MM/DD")
    End With

    ' --------------------------------------------------
    ' 変数
    ' --------------------------------------------------
    strWeek(1) = "(日)"
    strWeek(2) = "(月)"
    strWeek(3) = "(火)"
    strWeek(4) = "(水)"
    strWeek(5) = "(木)"
    strWeek(6) = "(金)"
    strWeek(7) = "(土)"

    ' --------------------------------------------------
    ' グリッド設定
    ' --------------------------------------------------
    With grd未入力一覧
        .ScrollTrack = True
        .ColWidth(0) = 300
        .FillStyle = flexFillRepeat
    End With
    
    ' --------------------------------------------------
    ' 期間
    ' --------------------------------------------------
    Dim i As Integer
    With cmb期間
        For i = 1 To 15
            .AddItem StrConv(i, 4) & "週間"
            .ItemData(i - 1) = 7 * i
        Next
    End With
    
    ' --------------------------------------------------
    ' DB接続
    ' --------------------------------------------------
    Set Cn = SQS_DBConnect("サーバ", "DB名", "sa", "")

    ' --------------------------------------------------
    ' 教師
    ' --------------------------------------------------
    SqlQuery = "select * from V_教師 order by コード"

    If DBGet(Cn, Rs, SqlQuery, False) Then
        i = 0
        Do While Not Rs.EOF
            With cmb教師
                .AddItem Rs.Fields("名称").Value, i
                cmb教師.ItemData(i) = Rs.Fields("コード").Value
            End With
            Rs.MoveNext
            i = i + 1
        Loop
    End If
    
    Call DBClose(Rs)
    
End Sub

' ******************************************************
' 終了処理
' ******************************************************
Private Sub Form_Unload(Cancel As Integer)

    Call DBClose(Cn)

    Set Cn = Nothing
    Set Rs = Nothing

End Sub

DB.vbs (クライアントスクリプト用)


Dim ConnectionString

' ******************************************************
' DB接続(SQLServer)
' ******************************************************
Function lbSQS_DBConnect( _
	Connection, _
	Server, _
	DB, _
	User, _
	Pass _
)

	ConnectionString = _
		"Provider=SQLOLEDB;" & _
		"Data Source=" & Server & ";" & _
		"Initial Catalog=" & DB & ";" & _
		"User ID=" & User & ";" & _
		"Password=" & Pass & ";"
	
	Connection.Open ConnectionString

End Function

' ******************************************************
' DB接続(Excel)
' ******************************************************
Function lbXLS_DBConnect( _
	Connection, _
	File _
)

	ConnectionString = _
		"Provider=Microsoft.Jet.OLEDB.4.0;" & _
		"Data Source=" & File & ";" & _
		"Extended Properties=""Excel 8.0;"""

	Connection.Open ConnectionString

End Function

' ******************************************************
' DB接続(MDB)
' ******************************************************
Function lbMDB_DBConnect( _
	Connection, _
	File _
)

	ConnectionString = _
		"Provider=Microsoft.Jet.OLEDB.4.0;" & _
		"Data Source=" & File & ";"

	Connection.Open ConnectionString

End Function

' ******************************************************
' DB接続(ODBC)
' ******************************************************
Function lbODBC_DBConnect( _
	Connection, _
	Dsn, _
	Uid, _
	Pwd _
)

	ConnectionString = _
		"Provider=MSDASQL" & _
		";DSN=" & Dsn & _
		";UID=" & Uid & _ 
		";PWD=" & Pwd & _ 
		";" 

	Connection.Open ConnectionString

End Function

' ******************************************************
' DB終了処理(接続を閉じる)
' ******************************************************
Function lbDBClose( _
	CnRs _
)
	
	On Error Resume Next
	If CnRs.State >= 1 Then
		CnRs.Close
	End If

	lbDBClose = True

End Function

' ******************************************************
' DB読込み
' 【戻り値】: True(データ有り),False(データ無し)
' ******************************************************
Function lbDBGet( _
	Connection, _
	Record, _
	SqlQuery, _
	bUpadateFlg _
)
	
	' 閉じていない時は閉じる
	If Record.State >= 1 Then
		Record.Close
	End If
	
	' 更新処理に使用する場合は、レコード単位の共有的ロック
	If bUpadateFlg Then
		Record.LockType = 3
	End If
	
	' レコードセット作成
	Record.Open SqlQuery, Connection
	If Record.EOF Then
		lbDBGet = False
	Else
		lbDBGet = True
	End If

End Function