やりだすと、こだわってしまう。。
前回のソースコードの修正版。
バグ修正：オブジェクトを閉じる（.Quit）系の処理がすっぽり抜けていたので追加。
これは恥ずかしい。。。
機能追加：コンパイルオプションで参照設定のスイッチフラグ追加
このスイッチフラグには利点は２点ある。
１点目は、実行環境に参照設定が無くても実行できること。
２点目は、実行環境に参照設定があると、コードの補完機能（インテリセンス）が使えること。
コードはやや冗長になるけど、保守性と再利用性が高まるのでおすすめ
それと最後にエラーハンドリング用に例外処理用のラベル追加
JAVAとか、C#によくある構文をまねた。
#Const LINK_LIBRATY = 0 ‘参照設定あり(1)/参照設定なし(0)
‘LINK_LIBRATY = 1 の場合 参照設定にてexcel,word,powerpoint,AccessのLibraryを追加する。
‘確認環境はoffice2010で参照Libraryとバージョンは以下のとおり
‘①Excel Microsoft Excel 14.0 Object Library
‘②Access Microsoft Access 14.0 Object Library
‘③PowerPoint Microsoft PowerPoint 14.0 Object Library
‘④Word Microsoft Word 14.0 Object Library
Sub 各OFFICEドキュメントの新規作成マクロ()
On Error GoTo EXCEPTION
‘以下ソースコード
‘SavePath配下にSaveName(+各ドキュメント毎の拡張子)のファイルが作成される。
Dim SavePath As String
Dim SaveName As String
SavePath = "C:\test\"
SaveName = "testData"
If Dir(SavePath, vbDirectory) = "" Then
MkDir SavePath
End If
‘Excelの新規作成
#If LINK_LIBRATY Then ‘ 参照設定あり
Dim xlsApp As Excel.Application
Set xlsApp = New Excel.Application
Dim wb As Excel.Workbook
#Else ‘参照設定なし
Dim xlsApp As Object
Set xlsApp = CreateObject("Excel.Application")
Dim wb As Object
#End If
Set wb = xlsApp.Workbooks.Add
wb.Saved = True
Call wb.SaveAs(SavePath & SaveName)
Debug.Print wb.Path
wb.Close
‘Wordの新規作成
#If LINK_LIBRATY Then ‘参照設定あり
Dim docApp As Word.Application
Set docApp = New Word.Application
Dim doc As Word.Document
#Else ‘参照設定なし
Dim docApp As Object
Set docApp = CreateObject("Word.Application")
Dim doc As Object
#End If
Set doc = docApp.Documents.Add
Call doc.SaveAs2(SavePath & SaveName)
Debug.Print doc.Path
doc.Close
‘PowerPointの新規作成
#If LINK_LIBRATY Then ‘参照設定あり
Dim pptApp As PowerPoint.Application
Set pptApp = New PowerPoint.Application
Dim pre As PowerPoint.Presentation
#Else ‘参照設定なし
Dim pptApp As Object
Set pptApp = CreateObject("PowerPoint.Application")
Dim pre As Object
#End If
Set pre = pptApp.Presentations.Add(msoFalse)
Call pre.SaveAs(SavePath & SaveName)
Debug.Print pre.Path
Call pre.Close
‘Accessの新規作成
#If LINK_LIBRATY Then ‘参照設定あり
Dim dbApp As Access.Application
Set dbApp = New Access.Application
#Else ‘参照設定なし
Dim dbApp As Object
Set dbApp = CreateObject("Access.Application")
#End If
Call dbApp.NewCurrentDatabase(SavePath & SaveName)
Debug.Print dbApp.CurrentProject.Path
Call dbApp.CloseCurrentDatabase
GoTo FINALLY
EXCEPTION:
MsgBox "エラー" & Err.Description
FINALLY:
‘オブジェクトを閉じる
xlsApp.Quit
docApp.Quit
pptApp.Quit
dbApp.Quit
‘フェイルセーフ（このソースコードを２次加工したとき用）
Set xlsApp = Nothing
Set docApp = Nothing
Set pptApp = Nothing
Set dbApp = Nothing
End Sub
コメント