| |
▼こるぎ さん：
おはようございます。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
以上です。自動実行するようになっています。
よかったら、確認してみて下さい。
|
|
ichinose
- 04/1/31(土) 9:35 -
