Public Function getCurrentFolder() As String
Dim sPath As String
Dim i As Integer
sPath = CurrentDb.Name
For i = Len(sPath) To 1 Step -1
If Mid(sPath, i, 1) = "\" Then
getCurrentFolder = Left(sPath, i - 1)
Exit For
End If
Next i
End Function
Public Sub 既存のエクセルファイルを読む()
MsgBox readExcelCell("\" & "vba.xls", 1, 2, 2)
End Sub
Public Function readExcelCell( _
ByVal sBookPath As String _
, ByVal iSheetNo As Integer _
, ByVal iRowNo As Integer _
, ByVal iCellNo As Integer _
) As Variant
On Error GoTo catch_
Dim oApp As Object
Dim sPath As String
Dim i As Integer
Set oApp = CreateObject("Excel.Application")
sPath = sBookPath
If Left(sBookPath, 1) = "\" Then
sPath = getCurrentFolder() & sBookPath
End If
oApp.Workbooks.Open Filename:=sPath
readExcelCell = oApp.ActiveWorkbook _
.Worksheets(iSheetNo).Cells(iRowNo, iCellNo)
GoTo finally_
catch_:
MsgBox "実行時エラー:" & Err.Number & " " _
& Err.Description, vbExclamation
Resume finally_
finally_:
If Not (oApp Is Nothing) Then
oApp.Quit
Set oApp = Nothing
End If
End Function
Public Sub テーブルの内容を参照したい()
On Error GoTo catch_
Dim oDB As DAO.Database: Set oDB = Nothing
Dim oRS As DAO.Recordset: Set oRS = Nothing
Set oDB = CurrentDb()
Set oRS = oDB.OpenRecordset("person")
Do Until oRS.EOF
Debug.Print oRS!id
Debug.Print oRS!name
Debug.Print oRS!address
oRS.MoveNext
Loop
GoTo finally_
catch_:
MsgBox "実行時エラー:" & Err.Number & " " _
& Err.Description, vbExclamation
Resume finally_
finally_:
If Not (oRS Is Nothing) Then
oRS.Close: Set oRS = Nothing
End If
If Not (oDB Is Nothing) Then
oDB.Close: Set oDB = Nothing
End If
End Sub
