TOP絵変更 → 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41  クリックすると変更されます
HOME

スポンサーサイト

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

Microsoft Access2010 で Excel出力

このブログに書く必要はないと思ったけど、一応備忘録程度に。

アクセス2010でフォームを作り、そのフォームから
抽出条件を選ばせ、その結果をエクセル出力するような
プログラムを例に説明。


―ソース部分――――――――――――――――

Option Compare Database
Option Explicit

――――――――――――――――――――――

この上の二つはとりあえず書いておく……
一つは変数定義ちゃんとしてるよねチェックみたいなやつ。
もう1つは忘れた。



―ソース部分――――――――――――――――

Private Sub btnOutput_Click()

――――――――――――――――――――――

フォームにボタンを用意。
名前は「btnOutput」

―ソース部分――――――――――――――――

Dim adoCn As ADODB.Connection
Dim adoRs As ADODB.Recordset

Set adoCn = CurrentProject.Connection
Set adoRs = New ADODB.Recordset

 ~中略~

Select Case opgWhere.Value
Case 1
whereStr = "where col1 = 1 "
Case 2
whereStr = "where col1 = 2 "
Case 3
whereStr = "where col1 = 3 "
End Select

――――――――――――――――――――――

コネクションとレコードセットを用意しておく。
画面上にオプショングループとラジオボタンを
用意して、ラジオボタンのどれを押したかによって
where文を可変させる。
order by文用のラジオボタンなんかも画面に置くといいかも。

―ソース部分――――――――――――――――

cSql = "select * from テストテーブル " & whereStr
adoRs.Open cSql, adoCn, , adLockPessimistic

――――――――――――――――――――――

SQLを実行する。
adLockPessimisticってなんだっけ?(

―ソース部分――――――――――――――――

Set xls = CreateObject("Excel.Application")
Set wkb = xls.Workbooks.Add

――――――――――――――――――――――

Excelオブジェクト生成。
この状態だとまだ裏でExcelが開いてるだけなので
表には見えない。


―ソース部分――――――――――――――――

While wkb.Sheets.Count <> 1
wkb.Sheets(2).Delete
Wend

――――――――――――――――――――――

シートを1つにする方法がよくわからなかったので、
シートが1個になるまで削除という原始的なものを置いておく。

―ソース部分――――――――――――――――

wkb.Worksheets(1).Columns("A:C").ColumnWidth = 30

――――――――――――――――――――――

とりあえずシート幅を設定。
A~C列の幅を30に設定している。(30ってどのぐらいだ?)
wkb.Worksheets(1)はWithで指定して囲ってもいいかも。

―ソース部分――――――――――――――――

wkb.Worksheets(1).Cells(1, 1).Value = "項目1"
wkb.Worksheets(1).Cells(1, 2).Value = "項目2"
wkb.Worksheets(1).Cells(1, 3).Value = "項目3"

――――――――――――――――――――――

ExcelのセルはCellsで指定できる。Rangeも使える。
上記の場合、A1、A2、A3セルに指定した文字を入れている。

―ソース部分――――――――――――――――

dataRow = 2
Do Until adoRs.EOF
wkb.Worksheets(1).Cells(dataRow, 1).Value = adoRs.Fields("col1").Value
wkb.Worksheets(1).Cells(dataRow, 2).Value = adoRs.Fields("col2").Value
wkb.Worksheets(1).Cells(dataRow, 3).Value = adoRs.Fields("col3").Value
dataRow = dataRow + 1
adoRs.MoveNext
Loop

――――――――――――――――――――――

一行目は項目行のため、二行目からデータを出力するために
dataRowという変数を用意している。
取得したSQLのレコードをDo UntilとMoveNextで回す。
adoRs.Fields("col3").Valueのcol3ってのはテーブルの項目名。

―ソース部分――――――――――――――――

dataRow = dataRow - 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(7).LineStyle = 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(8).LineStyle = 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(9).LineStyle = 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(10).LineStyle = 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(11).LineStyle = 1
wkb.Worksheets(1).Range(wkb.Worksheets(1).Cells(1, 1), wkb.Worksheets(1).Cells(dataRow,

3)).Borders(12).LineStyle = 1

――――――――――――――――――――――

上記ロジックだと、ループの最後にdataRowが1多くなるため、
まずマイナス1している。
罫線の設定。Borders(7)~(12)は線の種類?ていうか向き?方向?
なんて言えばいいのか。
xlEdgeLeftとか、xlEdgeTopとかのアレ。
AccessにはxlEdgeLeftとかの定数定義が入ってないので直接数値を入れている。

しかしやっぱりwkb.Worksheets(1)はwithにしたほうがよかった。
withで囲ってれば
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(12).LineStyle = 1
ぐらいには収まる。

―ソース部分――――――――――――――――

wkb.Worksheets(1).Columns("A:C").AutoFit

――――――――――――――――――――――

30に設定しといた幅をわざわざ自動調整してみる。
これはレコードから文字がエクセルのセルにセットされたときに、
長すぎるとすんげー改行して入ってる可能性があるので、
それの予防策。
幅を最初に大きくとってから文字を入れ、そのあとに
自動調整すればセルごとの改行を回避するというわけ。


―ソース部分――――――――――――――――

adoRs.Close
Set adoCn = Nothing

xls.Visible = True
AppActivate wkb.Name

――――――――――――――――――――――

クローズ処理。
Excelの保存ダイアログを出してもよかったんだけど、
今回はExcelの表示のみ。
AppActivate wkb.NameってのはExcelを最前面へ
表示させるためのもの。

―ソース部分――――――――――――――――

Exit_btnOutput_Click:
Exit Sub

Err_btnOutput_Click:
MsgBox Err.Description, vbOKOnly, "エラー"
If Not IsEmpty(xls) Then
xls.DisplayAlerts = False
xls.Quit
xls.DisplayAlerts = True
End If

Set wkb = Nothing
Set xls = Nothing

If adoRs.State <> adStateClosed Then
adoRs.Close
End If

Set adoCn = Nothing

Resume Exit_btnOutput_Click

――――――――――――――――――――――

エラー処理。
レコードセットやエクセルがすでに開いていた場合は
閉じる処理が入っている。


以上、ソースをまとめるとこんな感じ。


―ソース部分――――――――――――――――


Option Compare Database
Option Explicit

Private Sub btnOutput_Click()
Dim adoCn As ADODB.Connection
Dim adoRs As ADODB.Recordset

Dim cSql As String
Dim whereStr As String
Dim dataRow As Integer

Set adoCn = CurrentProject.Connection
Set adoRs = New ADODB.Recordset

Select Case opgWhere.Value
Case 1
whereStr = "where col1 = 1 "
Case 2
whereStr = "where col1 = 2 "
Case 3
whereStr = "where col1 = 3 "
End Select

cSql = "select * from テストテーブル " & whereStr
adoRs.Open cSql, adoCn, , adLockPessimistic

Set xls = CreateObject("Excel.Application")
Set wkb = xls.Workbooks.Add

While wkb.Sheets.Count <> 1
wkb.Sheets(2).Delete
Wend

With wkb.Worksheets(1)

.Columns("A:C").ColumnWidth = 30

.Cells(1, 1).Value = "項目1"
.Cells(1, 2).Value = "項目2"
.Cells(1, 3).Value = "項目3"

dataRow = 2
Do Until adoRs.EOF
.Cells(dataRow, 1).Value = adoRs.Fields("col1").Value
.Cells(dataRow, 2).Value = adoRs.Fields("col2").Value
.Cells(dataRow, 3).Value = adoRs.Fields("col3").Value
dataRow = dataRow + 1
adoRs.MoveNext
Loop

dataRow = dataRow - 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(7).LineStyle = 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(8).LineStyle = 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(9).LineStyle = 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(10).LineStyle = 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(11).LineStyle = 1
.Range(.Cells(1, 1), .Cells(dataRow, 3)).Borders(12).LineStyle = 1

.Columns("A:C").AutoFit

End With


adoRs.Close
Set adoCn = Nothing

xls.Visible = True
AppActivate wkb.Name

Exit_btnOutput_Click:
Exit Sub

Err_btnOutput_Click:
MsgBox Err.Description, vbOKOnly, "エラー"
If Not IsEmpty(xls) Then
xls.DisplayAlerts = False
xls.Quit
xls.DisplayAlerts = True
End If

Set wkb = Nothing
Set xls = Nothing

If adoRs.State <> adStateClosed Then
adoRs.Close
End If

Set adoCn = Nothing

Resume Exit_btnOutput_Click
End Sub

――――――――――――――――――――――

結局with使ったっていう。



・保存したい場合


新規保存したい場合は以下のような感じにする

xls.DisplayAlerts = False
wkb.SaveAs FileName:="C:\テスト.xlsx"
xls.Quit
xls.DisplayAlerts = True
Set wkb = Nothing
Set xls = Nothing

あと使いそうなのはデスクトップパスの取得

Public Function myDeskTopPath() As String
Dim MyWSH As Object

Set MyWSH = CreateObject("WScript.Shell")
myDeskTopPath = MyWSH.SpecialFolders("Desktop")
Set MyWSH = Nothing
End Function

あと保存するバージョンを変えたかったりする場合

Private Const xlExcel8 As Integer = 56
wkb.SaveAs FileName:=savePath, FileFormat:=xlExcel8

xlExcel8とかは本来はExcelの定数なのだが、
Accessにはないので自分で定義。


既存のエクセルにシート追加し、そこに増やす場合

If Dir("C:\テスト.xlsx") = "" Then
Set wkb = xls.Workbooks.Add
While wkb.Sheets.Count <> 1
wkb.Sheets(2).Delete
Wend
Else
If MsgBox("出力先に同じファイル名のエクセルファイルが存在します。" & vbCr & _
"今回出力するデータを新しいシートに保存しますか?", vbOKCancel, "テスト"= vbCancel Then
MsgBox "エクセル出力をキャンセルしました。", vbOKOnly, "テスト"
Exit Sub
End If

Set wkb = xls.Workbooks.Open("C:\テスト.xlsx")
'wkb.Worksheets.Add after:=wkb.Sheets(wkb.Sheets.Count) ' 末尾にシートを作成
wkb.Worksheets.Add before:=wkb.Sheets(1) ' 先頭にシートを作成

End If

'With wkb.Worksheets(wkb.Sheets.Count) ' 末尾にシートを作成した場合の設定
With wkb.Worksheets(1)

~中略~


なんかいろいろいらないメッセージボックスも出しているが、
ようは単純にワークシートを追加するだけ。
"C:\テスト.xlsx"のところは変数にして可変にするとよい。


ファイル選択ダイアログボックスを開いてファイルパスを取得する場合

Public Function GetFileName() As String

Dim returnValue As Integer
Dim strFilePath As String

strFilePath = myDeskTopPath() & "\テスト.xlsx"

WizHook.Key = 51488399 'WIZHOOKを有効化する
returnValue = WizHook.GetFileName( _
0, "", "出力先を選択", "", strFilePath, "", _
"エクセルファイル (*.xls,*.xlsx)|*.xls|*.xlsx", _
0, 0, 0, False _
)
WizHook.Key = 0 ' WizHook 無効化
GetFileName = strFilePath

End Function


これを呼べばダイアログを表示してディレクトリパスを持ってこれる。
WizHook.GetFileNameの各引数はググって。(てかこのコード自体ググったらでてくる)
前述したデスクトップパスの取得の関数を読んでいるので少し注意。
スポンサーサイト

テーマ : テイルズウィーバー
ジャンル : オンラインゲーム

コメントの投稿

非公開コメント

著作権

Copyrights (C) NEXON Corporation and NEXON Co., Ltd.
All Rights Reserved.
乱数試行機

乱数試行機

成功率 %
試行回数 回

成功    :0 回
失敗    :0 回
成功率結果 :0 %
試行回数結果:0 回
簡易MRシミュレータ

簡易MRシミュレータ
by †真・ブリニクルディメンションスレイヤー

S:64 
H:136 
F:17 
I:16 
M:14 
X:16 
A:11 
Q:10 
C:9 
アンチ無
MR費用:0
MR券込:0
回した回数:0

※ステがMAXになると
 黄色文字になります
 ステ自体違う場合はコメントくだs
※ラジオボタンを押下すると
 アンチマジックを使った状態に
なります

個人リンク
みんなの呟き

   



サイト説明
BloodyRosary は
テイルズウィーバーなブログです。
レコ…霧鯖で活動してるってばよ。
TwitterID:yoinagiTW

このブログはリンクフリーです。
+50000
しかしなぜか東方カウンター
自己紹介

宵凪(テチ) Lv:290
3次覚醒済


江戸川ドイル(アナイス) Lv290
2次覚醒済


竜崎シオン(イソ) Lv290
2次覚醒済


ラストセラフィ(ベンヤ) Lv290
2次覚醒済


シルフィアス(ナヤ) Lv:290
2次覚醒済


ジールラファル(マキシ) Lv:255
覚醒済


レスヴィリア(ミラ) Lv:255
覚醒済


聖王リヴァイア(シベ) Lv:255
覚醒済


セレス(クロエ) Lv265
覚醒済


月千夜(ジョシュ) Lv255
覚醒済


雪千夜(ランジエ) Lv255
覚醒済


超社長(イサック) Lv255
覚醒済


ナズナ(ボリ) Lv255
覚醒済


シルベイン(ピン) Lv:255
覚醒済


ディシディア(ルシ) Lv255
覚醒済


メルブレイズ(ロアミニ) Lv255
覚醒済


ルヴァリオ(ノクターン) Lv255
覚醒済


臼いネコ(テチ) Lv290


x音葉x(テチ) Lv199

他のキャラ
セリカ様(アナイス) Lv290
黒銀シア(ピン) Lv274
全キャラレコ…霧鯖で適当に活動中
今までの絵
右下に行くほど新
左上に行くほど古
リンクにマウスをあわせると
縮小画像表示

ちなみに読み込み遅いです。
最新コメント
カレンダー
05 | 2017/06 | 07
- - - - 1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30 -
カテゴリ
リンク
テスト
クリックすると
シナリオ開始 
 
検索フォーム
上記広告は1ヶ月以上更新のないブログに表示されています。新しい記事を書くことで広告を消せます。