年: 2014年

ずっと前に仕事でxlsやdocのfooterの内容を変えることがあった時に書いたVBAコード。
仕事としてではなく試しに家で書いたものなので公開しても問題ない…はず(・∀・)

まあ内容的に古いので今更有効活用出来る内容ではないけれども、
いつかまた何かの役に立つかもしれないのでエントリとして保存しておこう。

多分、こちらのエントリを参考にして再帰部分は書いた…ような。
VBA（2007もOK）で，ファイルの再帰検索をしよう

その他の部分は色々なVBA関連のサイトやヘルプ(リファレンス？)を
参考にしたような気がするけど、詳しくは覚えていない。

MsgBoxとかの部分はお試しで入れているだけなので本当は要らない。
対象となるパスはxls_test()の中で直書きして、そこにxlsファイル群を
ぶちこんでこれを実行すると「All Rights Reserved, Copyright © ～」
みたいなのが右下のfooterに追加されるはず。
rightfooterを他のfooterやheaderに代えれば任意の部分の値を変更出来る…はず。

このままで動くかもしれないけれども、このコード自体は実地で
試したものではないので修正が必要かも(ﾉ∀`)

doc_test()はWord用。確かこれで動いたような気がする…けど自信はないｗ
最新のOfficeのVBAはどうなってるんだろうか。

Option Explicit

Function FileSearch2007(dir_path, target_extension)
	Dim found_files As Collection

	Set found_files = New Collection
	Call FileSearch2007_Repeat(dir_path, found_files, target_extension)
	Set FileSearch2007 = found_files
End Function

Private Sub FileSearch2007_Repeat(dir_path, found_files, target_extension)
	Dim fso As FileSystemObject
	Dim target_folder As Folder
	Dim sub_folder As Folder
	Dim objFile As File

	Set fso = New FileSystemObject
	Set target_folder = fso.GetFolder(dir_path)

	For Each sub_folder In target_folder.SubFolders
		Call FileSearch2007_Repeat(sub_folder.Path,found_files,target_extension)
	Next sub_folder

	For Each objFile In target_folder.Files
		With objFile
			If ((UCase)fso.GetExtensionName(.Path)) = target_extension) Then
				found_files.Add Item:=.Path
			End If
		End With
	Next objFile

	Set fso = Nothing
End Sub

Sub xls_test()
	Dim dir_path As String
	Dim target_extension As String
	Dim found_files As Collection
	Dim found_num As Integer

	//ここに対象のファイル群があるパスを指定
	dir_path = "<ディレクトリパス>" 'ThisWorkbook.Path & "\test"
	target_extension = UCase("xls")

	Set found_files = FileSearch2007(dir_path, target_extension)

	found_num = found_files.Count
	If found_num = 0 Then
		MsgBox "not found"
	Else
		MsgBox found_num & " found"

		Dim i As Integer
		Dim bookpath As String
		Dim TargetBook As Workbook
		Dim eachsheet As Worksheet

		For i= 1 To found_num
			bookpath=found_files(i)
			If Len(bookpath) > 0 Then
				'MsgBox bookpath
				Set TargetBook = Workbooks.Open(bookpath)

				'Office2010の互換性チェックを無効にする。
				Dim ret As Variant
				ret = Application.Version
				If Val(ret)=14 Then
					ActiveWorkbook.CheckCompatibility = False
				Else
				End If

				For Each eachsheet In TargetBook.Worksheets
					With eachsheet.PageSetup
					//ここでFooterやHeaderの値を修正
						RightFooter = "All Rights Reserved, Copyright " & Chr(169) & ""
					End With
				Next eachsheet

				TargetBook.Save
				TargetBook.Close
			End If
		Next i

		MsgBox "xls modified"
	End If
End　Sub

Sub doc_test()
	Dim dir_path As String
	Dim target_extension As String
	Dim found_files As Collection
	Dim found_num As Integer

	dir_path = "<ディレクトリパス>" 'ThisWorkbook.Path & "\test"
	target_extension = UCase("doc")

	Set found_files = FileSearch2007(dir_path, target_extension)
	found_num = found_files.Count
	If found_num = 0 Then
		MsgBox "not found"
	Else
		MsgBox found_num & " found"

		Dim i As Integer
		Dim docpath As String
		Dim eachsheet As Worksheet
		Dim objWord As Object

		Set objWord = CreateObject("Word.Application")
		For i = 1 To found_num
			docpath = found_files(i)
			If Len(docpath) > 0 Then
				'MsgBox docpath
				With objWord
					.Documents. Open docpath

					.ActiveDocument.Section(1).Footers(1).Range.Text=
					"All Rights Reserved, Copyright " & Chr(169) & ""

					.ActiveDocument.Save
					.ActiveDocument.Close
				End with
			End if
		Next i
		MsgBox "doc modified"
	End If
End Sub