Access2Genzo

上記の広告は１ヶ月以上更新のないブログに表示されています。新しい記事を書く事で広告が消せます。

今回の無駄コードは

SQL文からエクセルに出力しちゃうコード

「SQL文で一気にエクセル出力!･･･できればいいな〜」

コードです。

え？なんで弱気なのか？
自信ないんですよね〜･･･実は･･･orz

でもこれでも一応頑張ってはみてるんですよね･･･。

追記(2011/2/7):
今回のコードよりももっと簡単な、「SQL文で一気にエクセル出力!･･･パート2」の方を
作成しました。動作の結果は今回とほぼ同じ内容になってます。
今回はWizHookを利用してみたいという考えのもと作成していますので
予めご了承ください･･･m(_ _)m

･･･というよりも･･･むしろ、この記事恥ずかしい･･･ (／｡＼)ｲﾔﾝ!

---

さて、既存のテーブルやクエリをエクセルに出力しようとした場合ですが、これは

'テーブルをエクセルに出力する場合
Docmd.OutputTo acOutputTable, "テーブル名", acFormatXLS, "", false, ""

'クエリをエクセルに出力する場合
Docmd.OutputTo acOutputQuery, "クエリ名", acFormatXLS, "", false, ""

とすることで、エクセルに出力してくれるので簡単です。

また別の方法であればTransferSpreadsheetメソッドを利用する方法もありますが、
いずれにしても既存のテーブルやクエリが必要です。

でも今回は、VBA上で指定したSQL文をエクセルに出力したいと思ってるので、
既存のテーブルやクエリを指定して実行する上記の方法は使えません。

じゃ〜 懲りもせずに無駄コード書いちゃおうってなわけです。（￣＾￣） ｴｯﾍﾝ!

ただ、事前に言っておきますが、今回のコードはWizHookを利用して、
参照設定を使わずに保存のダイアログを表示させています。
(通常は、「Microsoft Office 1x.0 Object Library」等を参照設定して
保存ダイアログ等を利用する方法が一般的だと思います。)

このWizHookオブジェクトは非公式なオブジェクトです。
このコード(オブジェクト)の利用によって生じたトラブルや損害が
発生しても、一切の保障はできませんのでよろしくお願いします。

とりあえず下記を標準プロシージャに記述します。

Public Sub ExcelOut(strSQL As String)
On Error GoTo ErrHnd

Dim rsOut As DAO.Recordset 'レコードセット用変数
Dim strErr As String 'エラーメッセージ用変数

Dim intVal As Integer '保存ダイアログの戻り値用変数
Dim strPass As String '保存先用変数

Dim LOut As Long ' Loop用変数(列番号)
Dim xlsApp As Object 'エクセル用オブジェクト変数

'SQLをレコードセットに指定
Set rsOut = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)

If rsOut.EOF Then
    strErr = "出力するデータが存在しません"
    GoTo ErrHnd
End If

'保存のダイアログを表示
FilePick:
WizHook.Key = 51488399
    intVal = WizHook.GetFileName(0, "", "", "", strPass, "", _
                    "Excelファイル(*.xls)|*.xls", _
                    0, 0, 0, False)
WizHook.Key = 0

'保存キャンセルの処理
If intVal = -302 Then
    strErr = "キャンセルしました"
    GoTo ErrHnd
End If

'既存ファイルの確認
If Dir(strPass, vbNormal) <> "" Then
    MsgBox "同名のファイルが存在します。" _
    & "別名で保存してください。", vbOKOnly, "情報"
    GoTo FilePick
End If

'エクセルの起動
Set xlsApp = CreateObject("Excel.Sheet")

'エクセルの1行目に項目名を出力
For LOut = 0 To rsOut.Fields.Count - 1
    xlsApp.Application.cells(1, LOut + 1).Value = rsOut(LOut).Name
Next

'エクセルにレコードセットを出力
xlsApp.Application.cells(2, 1).CopyFromRecordset rsOut

'エクセルファイルの保存
xlsApp.SaveAs Left(strPass, Len(strPass) - 4)

'クローズ処理
rsOut.Close: Set rsOut = Nothing
xlsApp.Close SaveChanges:=False: Set xlsApp = Nothing

Exit Sub

'エラーハンドル    
ErrHnd:
Select Case Err.Number
    Case 0 'エラーなし

    Case 1004 'フォルダー/ファイルアクセスエラー
        strErr = "指定されたフォルダ/ファイルが存在しないか、" & _
        Chr(13) & "ファイルにアクセスできない状態です。"
    
    Case 3061, 3075, 3078, 3131 'SQL構文エラー
        strErr = "SQL構文エラーです"
        
    Case Else 'それ以外のエラー
        MsgBox "ErrNo:" & Err.Number & Chr(13) & "Err:" & Err.Description

End Select

If strErr <> "" Then MsgBox strErr, vbOKOnly + vbExclamation, "情報"

'エラー時のクローズ処理
If Not rsOut Is Nothing Then rsOut.Close: Set rsOut = Nothing
If Not xlsApp Is Nothing Then 
	xlsApp.Close SaveChanges:=False
	Set xlsApp = Nothing
End If
End Sub

基本的にコメントに全て書いていますが、処理の流れをだらだら書くと･･･

まず4〜11行目までは変数を定義しています。
今回はエクセルに出力するため、11行目がエクセル用としてのオブジェクト変数に
なっています。

14行目でSQL文を利用したレコードセットを開き、16行目からそのレコードセットに
レコードが存在しているか確認しています。
もしレコードが存在していなければ、出力する意味がないのでそのまま終了･･･
･･･という流れになっています。

さて23行目〜27行目ですが、ここでWizHookオブジェクトを利用して、
エクセルを利用する前に保存先を指定させるようにしています。

今回は、36行目からの処理で同名のファイル名では保存ができないように
しています。理由は、手を抜くためですヾ(@^▽^@)ﾉわはは

43行目でオブジェクト変数にエクセルシートを割り当てて起動させてます。
46〜48行目で、エクセルの1行目にレコードセットのフィールド名を出力させて、
レコードの出力に関しては、51行目のコードだけで終了です。

(実は、自分この51行目のコードを知るまでは、1件1件のレコードを
ループ処理でエクセルに出力していました･･･(-｡-) ﾎﾞｿｯ)

出力後は保存してクローズ処理を行う流れです。
エラー処理に関しては、適当に書いてます。(^^ゞ

･･･で上記の利用方法ですが、

ExcelOut "SQL文"

で動作してくれるはず･･･(-｡-) ﾎﾞｿｯ

ただ前述していますが、本来は、「Microsoft Office 1x.0 Object Library」等を
参照設定して保存ダイアログ等を利用する方法が一般的です。

今回は敢えて、参照設定をしない方法を個人的に挑戦してるだけですので、
予めご了承ください。 m(_ _)m

参照設定を利用した方法をご希望の方がいれば、ブログにアップしてもいいのですが、
あちこちで既に公開されてますもんね･･･(;^_^A ｱｾｱｾ

ま･･･ここを見ている人も少ないでしょうけれど･･･o(〃＾▽＾〃)oあははっ

そんなわけで、今回もお蔵入りになりそうな無駄コードでした･･･。

では（・・）/ ｼｭﾀ
．．．．．．．．．．．．．．．．ﾀﾀﾀｯ．ﾍ(；･･)ﾉ

タグ : Access VBA SQL Excel 出力