項目

一覧を出力する

概要

EXCELにて一覧を出力をする。

例

Option Compare Database
Option Explicit

'------------------------------------------------------------------------------------
' 名称    : CreateExcelList
'
' 機能    : 一覧を出力する
'
' 引数    : fname : ファイル名をフルパス指定 (例) "c:\temp\hoge.xls"
'           sql   : SQL                      (例) "select * from Tbl_TEST"
'
'
' 戻値    : 正常:true
'------------------------------------------------------------------------------------
Function CreateExcelList(fname As String, _
                      sql As String) As Boolean

    Dim xlApp   As Object
    Dim xlBook  As Object
    Dim xlSheet As Object

    Dim row     As Long
    Dim lastRow As Long
    Dim lastCol As Long

    Dim rs      As New ADODB.Recordset
    
    Dim i       As Long
    Dim endLoop As Long
    
On Error GoTo err_handle

    '-----------------------------------
    ' 1.上書き確認
    '-----------------------------------
    If Dir(fname) <> "" Then
        If MsgBox("指定したファイルがあります。" & vbCrLf & "上書きしますか?", vbInformation + vbYesNo) = vbNo Then
            GoTo exit_handle:
        End If
        
        'ファイルが開かれているか確認
        If IsExcelFileOpened(fname) Then
            MsgBox "指定したファイルが操作中です。処理を中断します。"
            GoTo exit_handle:
        End If
    End If

    '-----------------------------------
    ' 2.初期処理
    '-----------------------------------
    '砂時計
    DoCmd.Hourglass True
    
    '-----------------------------------
    ' 3.EXCEL準備
    '-----------------------------------
    'インスタンスの生成
    Set xlApp = CreateObject("excel.application")
    'ワークブックの追加
    Set xlBook = xlApp.Workbooks.Add
    'シートを変数に設定
    Set xlSheet = xlBook.Worksheets(1)
    '確認のメッセージ非表示
    xlApp.DisplayAlerts = False
        
    '-----------------------------------
    ' 4.レコードセット取得
    '-----------------------------------
    rs.Open sql, CurrentProject.Connection, adOpenDynamic, adLockOptimistic

    '-----------------------------------
    ' 5.EXCELシートへ出力
    '-----------------------------------
    With xlSheet
    
        '出力開始行
        row = 1
        
        endLoop = rs.Fields.Count
        
        If endLoop > 254 Then endLoop = 254
        
        '*** ヘッダ出力 ***
        For i = 1 To endLoop
            .cells(row, i) = rs.Fields(i - 1).Name
        Next
        
        '次の行へ
        row = row + 1
        
        '*** データ出力 ***
        .range("A" & row).CopyFromRecordset rs, 65534, 254

        '*** 終端位置取得 ***
        lastRow = .range("A65536").end(-4162).row '最終行を取得
        lastCol = .range("IV1").end(-4159).Column '最終列を取得
        
        '*** シート書式設定 ***
        
        '罫線描画
        Call DrawRuledLine(.range(.cells(1, 1), .cells(lastRow, lastCol)))
        'ヘッダ 方向:90度
        .range(.cells(1, 1), .cells(1, lastCol)).Orientation = 90
        'ヘッダ 色:グレー
        .range(.cells(1, 1), .cells(1, lastCol)).Interior.ColorIndex = 15
        'オートフィット
        .Columns.AutoFit
        'フィルタ
        .range(.cells(1, 1), .cells(1, lastCol)).AutoFilter

        '枠固定
        .range("A2").Select '固定する位置を選択
        xlApp.ActiveWindow.FreezePanes = True
        
    End With

    '-----------------------------------
    ' 6.ブックの保存
    '-----------------------------------
    xlBook.saveAs fname

    '*** 戻り値 ***
    CreateExcelList = True

'----------------------------------
' ※終了処理
'----------------------------------
exit_handle:

    On Error Resume Next

    'レコードセット
    If rs.State = adStateOpen Then
        rs.Close
    End If
    Set rs = Nothing
    
    'EXCEL終了処理
    xlApp.DisplayAlerts = True
    
    Set xlSheet = Nothing
    
    xlBook.Close
    Set xlBook = Nothing
    
    xlApp.Quit
    Set xlApp = Nothing

    '砂時計解除
    DoCmd.Hourglass False
    
    Exit Function
    
err_handle:
    MsgBox Err.Description
    Resume exit_handle
End Function

'--------------------------------------------------------
' 名称    : IsExcelFileOpened
'
' 機能    : EXCELファイルが開いているかチェックする
'
' 引数    : fname   : ファイル名
'
' 戻値    : 開いている場合:true
'--------------------------------------------------------
Function IsExcelFileOpened(fname)

    Dim fnum As Long

On Error GoTo err_handle

    fnum = FreeFile

    Open fname For Random Access Read Write Lock Read Write As #fnum

exit_handle:

    'ファイル開放
    Reset

    Exit Function
    
err_handle:

    IsExcelFileOpened = True
    
End Function

'--------------------------------------------------------
' 名称    : DrawRuleDLine
'
' 機能    : 罫線描画
'
' 引数    : range      : レンジ
' 戻値    : なし
'--------------------------------------------------------
Sub DrawRuledLine(range As Object)

    '罫線
    With range
        '罫線
        .Borders(7).LineStyle = 1   'xlEdgeLeft
        .Borders(8).LineStyle = 1   'xlEdgeTop
        .Borders(9).LineStyle = 1   'xlEdgeBottom
        .Borders(10).LineStyle = 1  'xlEdgeRight
        .Borders(11).LineStyle = 1  'xlInsideVertical
        
        If .Rows.Count > 1 Then
            .Borders(12).LineStyle = 1  'xlInsideHorizontal
        End If
    End With

End Sub