VB6.0用掲示板の過去のログ(No.2)−VBレスキュー(花ちゃん)
[記事リスト]
[新規投稿]
[新着記事]
[ワード検索]
[管理用]
| 投稿日 | ： 2004/12/05(Sun) 23:35 |
| 投稿者 | ： SK |
| Ｅメール | ： |
| ＵＲＬ | ： |
| タイトル | ： Excelが終了しません。 |
VB6 Sp6です。
【処理の説明】
あるAccessDB（Office2003)よりデーターを抽出し、フレックスグリッドに表示。
“ファイルに出力”のボタンを押下すると表示されているデーターをExcelファイル
に保存する。
このとき、グリッドに表示されているのは１レコードの一部なので再度、キーをもとに
すべてのフィールドを抽出し、保存する処理なのですが下記事項で困っています。
１．Excelがメモリーに残っている。
２．連続で“ファイルに出力”ボタンが押下できない。
（この連続とは表示するデーターを表示条件で変更してです。）
いろいろ調べて試していますが自分では解りません。
どこを変更すればいいのかお教え願えないでしょうか？
よろしくお願いします。
下記は“ファイルに出力”ボタンを押下したときのロジックです。
-------------------------- ロジック
Private Sub Command4_Click()
On Error GoTo export_click
'StatusBar1.Style = sbrNormal
'StatusBar1.Panels.Item(1) = "処理中"
'ステータスバー表示
StatusBar1.Style = sbrSimple
StatusBar1.SimpleText = "EXCELファイルにデーターを書き込み中、しばらくお待ちください。"
'マウスカーソルを待機中に変更
'Me.MousePointer = vbHourglass
Set rec = New ADODB.Recordset
'レコードセットのデータをExcelに保存
Dim rec_rowNum As Integer
Dim rec_colNum As Integer
Dim xl_rowNum As Integer
Dim xl_colNum As Integer
Dim moji As String
Dim mySheetName As String
' 変数にオブジェクトの参照を代入します。Add メソッドを使って
' 新規 workbookとworksheet オブジェクトを作成。
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Add()
Set xlSheet = xlBook.Worksheets(1)
'エクセルを表示しない
xlApp.Visible = False
'列名取得sql
strSql = "SELECT *, ID FROM 設備投資状況;"
With rec
.ActiveConnection = cnn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
'.LockType = adLockOptimistic
.LockType = adLockReadOnly
.Properties("IRowsetIdentity").Value = True
.Open strSql
End With
Colcount = rec.Fields.Count 'レコードセットの列の数を調べる
rec_colNum = 0 '列カウント初期化 （SQL 抽出レコード）
xl_rowNum = 1 'レコードカウント初期化 （Excel レコード）
xl_colNum = 1 '列カウント初期化 （Excel レコード）
Do While rec_colNum < Colcount '列の数とレコードセットの比較
With xlSheet.Cells
.Item(xl_rowNum, xl_colNum).Value = rec.Fields(rec_colNum).Name 'Excelの列に配列を入れる
End With
With xlSheet.Cells(xl_rowNum, xl_colNum)
.Font.Size = 11 'フォントサイズ
.Font.Name = "ＭＳ Ｐ明朝" 'フォントの種類
.Font.Bold = True '太字に設定
.HorizontalAlignment = xlHAlignCenter '横中央揃え
.VerticalAlignment = xlVAlignCenter '縦中央揃え
.Interior.ColorIndex = 36 'セル内背景色セット
End With
rec_colNum = rec_colNum + 1 '配列のカラムを1移動
xl_colNum = xl_colNum + 1 'Excel 列 を1移動
Loop
Set rec = Nothing
Set rec = New ADODB.Recordset
'実際のレコード取得
'sql 自動生成
strSql = "SELECT *, ID "
strFrom = "FROM 設備投資状況 "
strWhere = ""
strorder = "ORDER BY 計画No, 申請日"
strSql = strSql & strFrom & " WHERE "
'フィールドをセット
rowNum = 1
Do While rowNum < Rowcount + 1 '見出し部分をのぞきカウントさせる
With MSFlexGrid1
strWhere = strWhere & " or (ID = " & .TextMatrix(rowNum, 0) & ")"
End With
rowNum = rowNum + 1 '配列のレコード1行移動
Loop
'strWhereは頭の" OR "を取り除く為Mid()で４桁目以降を取得する
strSql = strSql & Mid(strWhere, 4) & strorder & ";"
MsgBox strSql
With rec
.ActiveConnection = cnn
.CursorLocation = adUseClient
.CursorType = adOpenStatic
'.LockType = adLockOptimistic
.LockType = adLockReadOnly
.Properties("IRowsetIdentity").Value = True
.Open strSql
End With
Colcount = rec.Fields.Count 'レコードセットの列の数を調べる
Rowcount = rec.RecordCount '行の数を取得する
MsgBox Colcount '列
MsgBox Rowcount '行：レコード数
'Excelフォーマット
With xlSheet
.Columns(1).ColumnWidth = 3
.Columns(2).ColumnWidth = 11
.Columns(3).ColumnWidth = 8
.Columns(4).ColumnWidth = 28
.Columns(5).ColumnWidth = 11
.Columns(6).ColumnWidth = 5
.Columns(7).ColumnWidth = 53
.Columns(8).ColumnWidth = 5
.Columns(9).ColumnWidth = 12
.Columns(10).ColumnWidth = 12
.Columns(11).ColumnWidth = 12
.Columns(12).ColumnWidth = 12
.Columns(13).ColumnWidth = 12
.Columns(14).ColumnWidth = 12
.Columns(15).ColumnWidth = 11
.Columns(16).ColumnWidth = 11
.Columns(17).ColumnWidth = 10
.Columns(18).ColumnWidth = 10
.Columns(19).ColumnWidth = 12
.Columns(20).ColumnWidth = 10
.Columns(21).ColumnWidth = 10
.Columns(22).ColumnWidth = 10
.Columns(23).ColumnWidth = 10
.Columns(24).ColumnWidth = 40
.Columns(9).NumberFormat = "@"
.Columns(10).NumberFormat = "@"
.Columns(11).NumberFormat = "@"
.Columns(12).NumberFormat = "@"
.Columns(13).NumberFormat = "@"
.Columns(14).NumberFormat = "\\#,###,###,##0"
.Columns(19).NumberFormat = "\\#,###,###,##0"
End With
'シート名選択
ActiveSheet.Name = "設備投資・状況"
'mySheetName = InputBox("保存するいシート名を入力してください", "シート名設定")
'ActiveSheet.Name = mySheetName
rec_rowNum = 0 'レコードカウント初期化 （SQL 抽出レコード）
xl_rowNum = 2 'レコードカウント初期化 （Excel レコード 2行目より）
Do While Not rec.EOF And rec_rowNum <= Rowcount + 1 '見出し部分を加えてカウントさせる
rec_colNum = 0 'カウンタの初期化
xl_colNum = 1 'Excel 列 初期化
Do While rec_colNum < Colcount '列の数とレコードセットの比較
With xlSheet.Cells
If IsNull(rec.Fields(rec_colNum)) = True Then
.Item(xl_rowNum, xl_colNum).Value = ""
Else
.Item(xl_rowNum, xl_colNum).Value = rec.Fields(rec_colNum).Value
If rec_colNum = 13 Then '申請金額
.Item(xl_rowNum, xl_colNum) = rec.Fields(rec_colNum).Value
End If
If rec_colNum = 18 Then '決裁金額
.Item(xl_rowNum, xl_colNum) = rec.Fields(rec_colNum).Value
End If
End If
rec_colNum = rec_colNum + 1 '配列のカラムを1移動
xl_colNum = xl_colNum + 1 'Excel 列 を1移動
End With
Loop
rec_rowNum = rec_rowNum + 1 '行のレコード1行移動
xl_rowNum = xl_rowNum + 1 'Excelのレコード1行移動
rec.MoveNext 'レコードセットの改行
Loop
'申請額、決裁額 合計値計算 表示
xlSheet.Cells(Rowcount + 2, 13).Value = "合計"
With xlSheet.Cells(Rowcount + 2, 13)
.Font.Size = 11 'フォントサイズ
.Font.Name = "ＭＳ Ｐ明朝" 'フォントの種類
.Font.Bold = True '太字に設定
.HorizontalAlignment = xlHAlignCenter '横中央揃え
.VerticalAlignment = xlVAlignCenter '縦中央揃え
.Interior.ColorIndex = 36 'セル内背景色セット
End With
xlSheet.Cells(Rowcount + 2, 18).Value = "合計"
With xlSheet.Cells(Rowcount + 2, 18)
.Font.Size = 11 'フォントサイズ
.Font.Name = "ＭＳ Ｐ明朝" 'フォントの種類
.Font.Bold = True '太字に設定
.HorizontalAlignment = xlHAlignCenter '横中央揃え
.VerticalAlignment = xlVAlignCenter '縦中央揃え
.Interior.ColorIndex = 36 'セル内背景色セット
End With
xlSheet.Cells(Rowcount + 2, 14).Formula = "=SUM(N1:" & "N" & Rowcount + 1 & ")"
With xlSheet.Cells(Rowcount + 2, 14)
.Font.Size = 10 'フォントサイズ
.Font.Name = "ＭＳ Ｐ明朝" 'フォントの種類
.Font.Bold = True '太字に設定
.HorizontalAlignment = xlHAlignCenter '横中央揃え
.VerticalAlignment = xlVAlignCenter '縦中央揃え
.Interior.ColorIndex = 36 'セル内背景色セット
End With
xlSheet.Cells(Rowcount + 2, 19).Formula = "=SUM(S1:" & "S" & Rowcount + 1 & ")"
With xlSheet.Cells(Rowcount + 2, 19)
.Font.Size = 10 'フォントサイズ
.Font.Name = "ＭＳ Ｐ明朝" 'フォントの種類
.Font.Bold = True '太字に設定
.HorizontalAlignment = xlHAlignCenter '横中央揃え
.VerticalAlignment = xlVAlignCenter '縦中央揃え
.Interior.ColorIndex = 36 'セル内背景色セット
End With
'表に罫線を引く 指定範囲に格子の罫線を引く
xlSheet.Range("A1:" & "X" & Rowcount + 1).Borders.LineStyle = xlContinuous '実線
'表の外枠を太線に
xlSheet.Range("A1:" & "X" & Rowcount + 1).Borders(xlEdgeTop).LineStyle = xlGray75
xlSheet.Range("A1:" & "X" & Rowcount + 1).Borders(xlEdgeLeft).LineStyle = xlGray75
xlSheet.Range("A1:" & "X" & Rowcount + 1).Borders(xlEdgeRight).LineStyle = xlGray75
xlSheet.Range("A1:" & "X" & Rowcount + 1).Borders(xlEdgeBottom).LineStyle = xlGray75
'項目欄を二重線で区切る
xlSheet.Range("A1:X1").Borders(xlEdgeBottom).LineStyle = xlDouble
'DoEvents
'ステータバー 消去
StatusBar1.SimpleText = ""
'マウスカーソルをデフォルトに戻す
'Me.MousePointer = vbDefault
'コモンダイアログボックスを利用
With CommonDialog1
.CancelError = True
.Flags = cdlOFNFileMustExist Or cdlOFNHideReadOnly
.Filter = "Microsoft Office Excel ブック (*.xls)|*.xls"
'最初に表示するファイルの種類の設定
.FilterIndex = 1
'ファイル名に表示するダイアログボックスを表示する
.FileName = "無題"
'コモンダイアログボックスを中央に表示
'.Center = True
'ファイルを保存するダイアログボックスを表示する
.ShowSave
'内容をファイルへ出力
'xlSheet.SaveAs .FileName
xlBook.SaveAs .FileName
End With
'DoEvents
'If Err.Number = cdlCancel Then Exit Sub
xlBook.Windows(1).Visible = True
xlApp.DisplayAlerts = False
' Quit メソッドを使って Excel を終了し。
xlApp.Quit
' オブジェクトを解放します。
Set xlSheet = Nothing
xlBook.Close (False)
Set xlBook = Nothing
Set xlApp = Nothing
'ガベージコレクションのメモリの解放
'system.GC.Collect
Exit Sub
export_click: 'ファイル保存で Cancel をクリック
'キャンセルボタンが押されたときは、エラー処理を抜ける
If Err.Number = 32755 Or 1004 Then
Exit Sub
End If
'メッセージボックスを表示して、エラー番号と内容を表示する
MsgBox Err.Number & Err.Description
End Sub
-------------------------------
- 関連一覧ツリー
（★ をクリックするとツリー全体を一括表示します）
- 返信フォーム
（この記事に返信する場合は下記フォームから投稿して下さい）