| 投稿日 | ： 2004/08/09(Mon) 10:29 |
| 投稿者 | ： みっち〜 |
| ＵＲＬ | ： |
| タイトル | ： Re^2: VBからEXCELファイルを作成し、完了後ファイルがうまく開かない |
> > このとき、ファイル（複数）の作成が完了したらAPI関数ShellExecuteを使用して
> >ファイルの格納先の ディレクトリを画面表示するようにしています。
>
> ShellExecute でそのような事できましたか？
説明が言葉不足と私自身の理解不足で申し訳ありません。
こちらの ファイル操作関係 の「指定のフォルダをエクスプローラで表示する」を参考にさせて
いただきました。
> > 上記のWindows98SEでは問題ないのですが、OSがWindows2000でEXEを実行すると、EXEを終
了せずに出
> > 力したファイルを開こうとするとファイルがうまく開けません。（EXCELのツールバーのみ
が表示され
> > る）
>
> 状況がよく解りません。
非常に説明しづらいのですが…
Windows2000のマシンでEXEを実行すると、EXCELのタイトル、ツールバーは表示されるのですが、表
の部分だけが表示されないのです。
> 再現できる（部分ではなく）コードを投稿して下さい。
以下にコードを記述します。
よろしくお願いします。
******************************************************************************
Option Explicit
'拡張子に関連付けられたプログラムを実行する (P699)
Private Declare Function ShellExecute Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hwnd As Long, _
ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
'指定のウインドウを非表示にし、他のウインドウをアクティブ化
Private Const SW_HIDE = 0
'ウインドウをアクティブ化し表示（元の位置とサイズで復元）
Private Const SW_RESTORE = 9
'ウインドウをアクティブ化し最大表示する
Private Const SW_SHOWMAXIMIZED = 3
******************************************************************************
Public Function gfb_PrintData() As Boolean
On Error GoTo Err_gfb_PrintData
Dim sFileName As String 'ファイル名（フルパス）
Dim iRc As Integer
Dim iLp As Integer
gfb_PrintData = False
gWS.BeginTrans
'===データ作成===
If Not gfb_CreateData2() Then
If Not gbCancel Then
MsgBox "Excelデータの作成に失敗しました", vbCritical + vbOKOnly, gcAP
P_TITLE
End If
gWS.Rollback
gfb_PrintData = True
GoTo Exit_gfb_PrintData
End If
gWS.CommitTrans
If gfb_OutPutExcel() Then
MsgBox "Ｅｘｃｅｌファイルの作成が完了しました。", vbOKOnly + vbInformati
on, gcAPP_TITLE
'フォルダを開く
ShellExecute frmMain.hwnd, "Open", "D:\出力先", _
vbNullString, vbNullString, SW_RESTORE
End If
gfb_PrintData = True
Exit_gfb_PrintData:
Exit Function
Err_gfb_PrintData:
MsgBox Err.Description & " (" & Err.Number & ")"
Resume Next
Cancel_Error:
gfb_PrintData = True
Exit Function
End Function
******************************************************************************
Public Function gfb_OutPutExcel() As Boolean
On Error GoTo Err_gfb_OutPutExcel
Dim oExcelApp As Object 'Excelオブジェクト
Dim oDataSheet2 As Object 'Excelシートオブジェクト
Dim sFileName As String 'Exlce出力ファイル名（フルパス）
Dim rsK As Recordset
Dim bFlg As Boolean
gfb_OutPutExcel = False
Set rsK = gDB.OpenRecordset(TB_WEEK, dbOpenSnapshot)
flgOpen = False
Do Until rsK.EOF
bFlg = False
If flgOpen = True Then
'----- Excelファイルデータ保存 -----
oDataSheet2.SaveAs (sFileName)
Dim w
For Each w In oExcelApp.Workbooks
w.Save
Next w
oExcelApp.Quit
flgOpen = False
End If
If Dir(App.Path & "\wk_雛型.xls") <> "" Then
Kill App.Path & "\wk_雛型"
End If
'出力ファイル名保存----------
giFIdx = giFIdx + 1
ReDim Preserve GM_FName(giFIdx)
sFileName = gsEXL_OUT_PATH & giFIdx & "タイトル.xls" '出力ファイ
ル名
GM_FName(giFIdx) = sFileName
'---------------------------
'----- 雛形のExcelをコピーする -----
FileCopy App.Path & "\" & gcEXL_IN_FILE, App.Path & "\wk
_雛型.xls"
'----- Excelを開く -----
Set oExcelApp = CreateObject(Class:="Excel.Application")
oExcelApp.Workbooks.Add (App.Path & "\wk_" & gsEXL_OUT_FILE)
Set oDataSheet2 = oExcelApp.ActiveWorkbook.Worksheets("sheet1")
flgOpen = True
'-----シートへ出力-------------------------------------
oDataSheet2.cells(4, 2).Value = "タイトル１"
oDataSheet2.cells(4, 4).Value = "タイトル２"
rsK.MoveNext
Loop
If flgOpen = True Then
'----- Excelファイルデータ保存 -----
oDataSheet2.SaveAs (sFileName)
For Each w In oExcelApp.Workbooks
w.Save
Next w
oExcelApp.Quit
End If
gfb_OutPutExcel = True
Close_gfb_OutPutExcel:
Set oExcelApp = Nothing
Set oDataSheet2 = Nothing
rsK.Close
Exit_gfb_OutPutExcel:
On Error GoTo 0
Exit Function
Err_gfb_OutPutExcel:
MsgBox "Excelファイル作成処理エラー " & vbNewLine & _
Err.Description & " (" & Err.Number & ")", vbCr
itical, gcAPP_TITLE
Resume Close_gfb_OutPutExcel
End Function