マコテキ-些細な日記

完成したソースを張っていなかった＾＾；

Option Explicit
    'ページ設定のステータス受け取り箱
    Dim para1 As String
    Dim para2 As String
    Dim para3 As String
    Dim para4 As String
    Dim para5 As String
    Dim para6 As String
    Dim para7 As String
Sub pageset() 'ユーザーが指定したディレクトリ内にあるxlsデータ全てのページ設定を変更する
    Dim wb      As Workbook
    Dim strFnm  As String
    Dim strDir  As String
    Dim strDir2  As String
   
    Dim toolwb As Workbook
   
    Dim i As Integer
    Dim AWN As String
    Dim ShtCnt As Integer
   
    Dim ShellApp As Object
    Dim SaveFolder As Object
    Dim TargetFolder As Object
   
    'このツールの情報を取得
    Set toolwb = ThisWorkbook
   
    '処理をするディレクトリを決める
    Set ShellApp = CreateObject("Shell.Application")
    Set TargetFolder = ShellApp.BrowseForFolder(0, "処理を行うフォルダを選択してください。", 1)
    If TargetFolder Is Nothing Then Exit Sub
    'エラーチェック
    If ThisWorkbook.Path = TargetFolder.items.Item.Path Then
    MsgBox "このツールと同じフォルダにあるデータは処理できません。"
    Exit Sub
    End If
   
    '保存するディレクトリを決める
    Set SaveFolder = ShellApp.BrowseForFolder(0, "保存先フォルダを選択してください。", 1)
    If SaveFolder Is Nothing Then Exit Sub
   
    '処理を行うディレクトリ
    strDir = TargetFolder.items.Item.Path
    strDir2 = SaveFolder.items.Item.Path
   
    'ツールの一覧シートにター別途フォルダの場所を記入
    Cells(2, 3).Value = strDir
    '処理を行う対象データ
    strFnm = Dir(strDir & "\*.xls")
   
    '警告ウインドウ非表示
    Application.ScreenUpdating = False
    i = 1
    '処理開始
    Do Until strFnm = ""
        Set wb = Workbooks.Open(strDir & "\" & strFnm)
        '処理内容
        AWN = Left(wb.Name, Len(wb.Name) - 4)
        ChDir (strDir2)
       
        '処理前のステータスをリストに書き留める
        toolwb.Activate

        Cells(i + 6, 3).Value = wb.Name
        Call para_in(wb)
        Call page_status(i + 6, 4)

        'ページ設定を変更する
        wb.Activate
        Call page_status_change
        '処理後のステータスを書き留める
        toolwb.Activate
        Call para_in(wb)
        Call page_status(i + 6, 11)
       
        '処理を行ったデータを保存する
        wb.Activate
        ActiveWorkbook.Close savechanges:=True _
        , Filename:=AWN & "_" & "pageset" & ".xls"
       
        i = i + 1

        strFnm = Dir()                   '次のファイル名
    Loop
    Application.ScreenUpdating = True

End Sub
Sub page_status(GYO As Integer, RETU As Integer) 'ページ設定のステータスを書き出し
If para1 = "1" Then
Cells(GYO, RETU).Value = "縦向き"
Else: Cells(GYO, RETU).Value = "横向き"
End If
Cells(GYO, RETU + 1).Value = para2
Cells(GYO, RETU + 2).Value = para3
Cells(GYO, RETU + 3).Value = para4
Cells(GYO, RETU + 4).Value = para5
Cells(GYO, RETU + 5).Value = para6
Cells(GYO, RETU + 6).Value = para7

End Sub
Sub para_in(wbook As Workbook) 'パラメータを変数に代入
para1 = CStr(wbook.ActiveSheet.PageSetup.Orientation)
para2 = CStr(wbook.ActiveSheet.PageSetup.Zoom)
para3 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesWide)
para4 = CStr(wbook.ActiveSheet.PageSetup.FitToPagesTall)
para5 = CStr(wbook.ActiveSheet.PageSetup.PrintArea)
para6 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleRows)
para7 = CStr(wbook.ActiveSheet.PageSetup.PrintTitleColumns)
End Sub
Private Sub page_status_change() 'ページ設定の変更処理
    With ActiveSheet.PageSetup

    .Orientation = 2 '印刷の向きを横にする
    .Zoom = False '拡大縮小印刷設定を「次のページ数にあわせて印刷」に変更
    .FitToPagesWide = 1 '上記のページ数横幅設定
    .FitToPagesTall = False '同じく縦幅設定
    .PrintTitleRows = "$1:$7" '行タイトルの設定

    '.PrintArea = "" '印刷領域の設定
    '.PrintTitleColumns = "" '列タイトルの設定
    End With
End Sub





 

とりあえず求めている最低限の処理を行ってくれるマクロの完成～
しかしまだ追加せねばいかん処理がまだあるんだよね＾＾；　とりあえず今回はココまで
画像の３～６行目は事前に入力しないとダメなんで入力しておくこと。