Word VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃ホーム

42 / 45 ﾍﾟｰｼﾞ

←次へ　｜　前へ→


	【77】Re:コードのバックアップ

ichinose - 04/1/31(土) 9:35 -


	引用なし

	パスワード

▼こるぎさん：
おはようございます。ichinoseと申します。
普段、WORD VBAの掲示板は、あまり閲覧していないのですが、気になる内容だったので
投稿しました。
時間が経ってしまったので、ご覧になってもらえないかもしれませんが・・。
>私は、コードを書き換えるために、エクスポートして、そのファイルを
>外付けHDD等に定期的に保存していますが、時々、エクスポート自体を忘れています。
>もし、その間にPCがクラッシュしたら・・・と不安です。
>そこで、コードが格納されているフォルダが分かれば教えていただけないでしょうか。
>そのフォルダごと定期的にバックアップすれば安全ですので。
以下に示すコードの仕様です。

機能:　

指定されたフォルダ内にあるWordのDocファイルに含まれるモジュールを指定された
フォルダ内にエクスポートします。
エクスポートファイルは、指定されたフォルダ内に
Docファイル名（拡張子なし）+"exp"という名前のフォルダを
作成し、その中に作成します。
2度、フォルダ選択ダイアログが表示されます。
最初にエクスポート対象のWordDocumentファイルが入っているフォルダ選択
次がエクスポート先フォルダ選択です。

では、コードです。Thisdocumentのモジュールに
'==================================================================
Sub Document_Open()
　 Dim r_fld
　 Dim w_fld
　 Application.ActiveWindow.WindowState = wdWindowStateMinimize
　 AppActivate Application.Caption
　 r_fld = get_folder_path("一括エクスポートするＷｏｒｄドキュメントの存在するフォルダを選択して下さい")
　 If VarType(r_fld) <> vbBoolean Then
　　　w_fld = get_folder_path("エクスポート先フォルダを選択して下さい")
　　　If VarType(w_fld) <> vbBoolean Then
　　　　 ans = MsgBox("「" & r_fld & "」に存在するワードファイルのＶＢＡコードを「" & w_fld & "」内に作成します。" & vbLf _
　　　　　　 & "　　・ワードファイル名と同じ名前に「exp」が付いたフォルダが「" & w_fld & "」内に作成されます。" & vbLf _
　　　　　　 & "　　・このフォルダにエクスポートファイルとログファイルが作成されます", vbOKCancel)
　　　　 If ans = 1 Then
　　　　　　WordBasic.DisableAutoMacros 1
　　　　　　Call export_proc(r_fld, w_fld)
　　　　　　WordBasic.DisableAutoMacros 0
　　　　　　End If
　　　　 End If
　　　End If
　 Application.ActiveWindow.WindowState = wdWindowStateMaximize
　
End Sub
'==================================================================
Sub export_proc(infld, outfld)
　 Dim docnm
　 Dim ex_doc As Document
　 Dim result
　 docnm = Dir(infld & "\*.doc")
　 Do While docnm <> ""
　　　If UCase(infld & "\" & docnm) <> UCase(ThisDocument.FullName) Then
　　　　 Set ex_doc = doc_open(infld & "\" & docnm)
　　　　 If Not ex_doc Is Nothing Then
　　　　　　result = export_comp(ex_doc, outfld & "\" & Mid(ex_doc.Name, 1, Len(ex_doc.Name) - 4) & "exp")
　　　　　　If VarType(result) <> vbBoolean Then
　　　　　　　 Call mk_log(outfld & "\" & Mid(ex_doc.Name, 1, Len(ex_doc.Name) - 4) & "exp", ex_doc, result)
　　　　　　　 End If
　　　　　　Call doc_close(ex_doc)
　　　　　　DoEvents
　　　　　　End If
　　　　 End If
　　　docnm = Dir()
　　　Loop
End Sub
'==================================================================
Sub mk_log(foldnm, ex_doc As Document, log_mes)
　 If open_txt(foldnm & "\" & Mid(ex_doc.Name, 1, Len(ex_doc.Name) - 4) & ".txt") = 0 Then
　　　Call put_txt("エクスポート対象ワードファイル　:　" & ex_doc.FullName)
　　　For idx = LBound(log_mes) To UBound(log_mes)
　　　　 Call put_txt(log_mes(idx))
　　　　 Next idx
　　　Call close_txt
　　　End If
End Sub

'次に標準モジュール（Module1）
'==============================================================
Function doc_open(flnm) As Document
'ドキュメントを開く
'input　　　:　flnm　　　----　　オープンするファイルのフルパス
'output　　 :　doc_open　-----　　Documentオブジェクト
　 On Error Resume Next
　 Set doc_open = Nothing
　 Set doc_open = Documents.Open(flnm)
　 On Error GoTo 0
End Function
'==============================================================

Sub doc_close(doc As Document)
'ドキュメントのクローズ
　 On Error Resume Next
　 doc.Close savechanges:=False
　 On Error GoTo 0
End Sub
'==============================================================
Function mk_folder(foldernm) As Long
'フォルダの作成
　 On Error Resume Next
　 mk_folder = 0
　 MkDir foldernm
　 mk_folder = Err.Number
　 On Error GoTo 0
End Function
'==============================================================

Function get_folder_path(mes)
'フォルダ選択処理
'input　　　:　　mes　　:　表示メッセージ
　　Dim fld
　　Set fld = CreateObject("Shell.Application").BrowseForFolder(0, mes, 2, 17)
　　On Error Resume Next
　　If Not fld Is Nothing Then
　　　 get_folder_path = fld.items.Item.Path
　　　 If Err.Number <> 0 Then
　　　　　get_folder_path = False
　　　　　End If
　　Else
　　　 get_folder_path = False
　　　 End If
　 Set fld = Nothing
End Function
'==============================================================
Function export_comp(docu, foldnm)
'指定されたドキュメントのモジュールをエクスポートする
'input : docu　　　　 : モジュールをエクスポートするDocumentオブジェクト
'　　　　foldnm　　　 : エクスポートするフォルダ名
'output: export_comp　: エクスポートのログメッセージ
'　　　　　　　　　　　メッセージがないときは､Falseを返す
　　Dim stt_flg As Boolean
　　Dim tp As Long
　　Dim comp As Object
　　Dim exe As Boolean
　　Dim log_mes()
　　Dim retcode As Long
　　export_comp = False
　　idx = 1
　　On Error Resume Next
　　With docu.VBProject
　　　 stt_flg = True
　　　 For Each comp In .VBComponents
　　　　 exe = True
　　　　 tp = comp.Type
　　　　 If tp = 100 Then tp = 4
　　　　 If tp = 4 Then
　　　　　　If comp.CodeModule.CountOfLines <= 0 Then
　　　　　　　 exe = False
　　　　　　　 End If
　　　　　　End If
　　　　 Err.Clear
　　　　 If exe = True Then
　　　　　　If stt_flg = True Then
　　　　　　　 retcode = mk_folder(foldnm)
　　　　　　　 If retcode = 0 Or retcode = 75 Then
　　　　　　　　　stt_flg = False
　　　　　　　 Else
　　　　　　　　　Exit For
　　　　　　　　　End If
　　　　　　　 End If
　　　　　　comp.Export foldnm & "\" & comp.Name & Choose(tp, ".bas", ".cls", ".frm", ".cls")
　　　　　　If Err.Number <> 0 Then
　　　　　　　 mes = comp.Name & ":" & Error(Err.Number)
　　　　　　Else
　　　　　　　 mes = comp.Name & "エクスポート完了"
　　　　　　　 End If
　　　　　　ReDim Preserve log_mes(1 To idx)
　　　　　　log_mes(idx) = mes
　　　　　　idx = idx + 1
　　　　　　End If
　　　　 Next
　　　 End With
　　If idx > 1 Then
　　　 export_comp = log_mes()
　　　 End If
　　On Error GoTo 0
End Function

'標準モジュール（Module2）に
'==============================================================
Private fno As Long
'==============================================================
Function open_txt(flnm) As Long
　 On Error Resume Next
　 open_txt = 0
　 fno = FreeFile()
　 Open flnm For Output As #fno
　 open_txt = Err.Number
　 On Error GoTo 0
End Function
'==============================================================
Function put_txt(txt) As Long
　 On Error Resume Next
　 put_txt = 0
　 Print #fno, txt
　 put_txt = Err.Number
　 On Error GoTo 0
End Function
'==============================================================
Function close_txt()
　 On Error Resume Next
　 Close #fno
　 On Error GoTo 0
End Function

以上です。自動実行するようになっています。
よかったら、確認してみて下さい。