印刷関係サンプルマクロ

すべてのシートに対して同じ印刷設定をする

Excelの改善して欲しい機能に印刷設定があります。

複数のシートを選択した状態で印刷設定すると、
選択したすべてのシートすべてに同じ印刷設定を適用して欲しいのに、
1つのシートしか設定されないんですよね。

そこで、すべてのシートに対して同じ印刷設定をするマクロを作ってみました。

サンプルコード



Sub すべてのシートに対して同じ印刷設定をする()
Dim objWS As Worksheet

For Each objWS In ThisWorkbook.Worksheets
  With objWS.PageSetup
    .RightHeader = "&A"
    .CenterFooter = "&P/&N"
    .Zoom = False
    .FitToPagesWide = 1
    .FitToPagesTall = False
  End With
Next objWS

End Sub


解説


マクロが記述されているブックにあるすべてのシートに対して、
次の印刷設定を行います。

右上ヘッダー:シート名
中央フッター:ページ番号/総ページ数
拡大縮小印刷:横1ページ、縦指定なし
一括印刷設定

ほかは現在の設定を変えません。


印刷設定のプロパティはとてもいっぱいあって、覚えるのは無理なので
マクロ記録から起こします。

プロパティ名はそのものズバリな名前なので特に説明なくてもわかるはず。
拡大縮小印刷だけ、ZoomプロパティをFalseにしておかないと
FitToPagesWideプロパティやFitToPagesTallプロパティを設定しても反映されないので注意が必要です。

設定を変えなくていい部分はマクロに記述しなくてOKです。

印刷関係サンプルマクロ

拡張子を気にせず印刷する

私の職場では会議資料などを印刷する時、Excelファイル以外にも
WordファイルやらPDFファイルやらが混ざっている事があります。

そこで拡張子を気にせず、一気に印刷するマクロを作ってみました。
WindowsAPIを使って、関連付けられたアプリケーションで印刷を行います。

サンプルコード1



'◆APIの宣言
Declare Function ShellExecute Lib "SHELL32" Alias "ShellExecuteA" _
  (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub ファイル印刷1()
  Dim strPath As String
  Dim strName As String
  
  '◆パス指定
  strPath = "C:" & "¥"
  strName = Dir(strPath & "*")
  
  '◆フォルダ内のファイルすべて印刷
  Do Until strName = ""
    Call ShellExecute(Application.hwnd, "print", strPath & strName, vbNullString, "", 0)
    strName = Dir()
  Loop
End Sub


変数strPathで指定したフォルダ内のファイルをすべて印刷します。

欠点は、Dir関数のファイル名を取得する順番が自分で決められないのと、
開く前のメッセージ(すでにファイルが開かれていた時の「読み取り専用で開きますか?」というメッセージや「読み取り専用を推奨する」にしていた場合のメッセージなど)が非表示にできない事。

順番を決めて印刷したい時は、Bookに下記のようなリストを作って
順番に印刷していけばいいでしょう。
ついでにパスを書く欄も作っておけば、違うフォルダにあるファイルも順番に印刷できます。



 AB
1フォルダファイル名
2C:¥Test1Test1.doc
3C:¥Test2Test2.pdf
4C:¥Test3Test3.xls


サンプルコード2



'◆APIの宣言
Declare Function ShellExecute Lib "SHELL32" Alias "ShellExecuteA" _
  (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
   ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long

Sub ファイル印刷2() ' ◆リストにあるファイルをすべて印刷

  Dim strPath As String
  Dim strName As String
  Dim lngRow As Long
  
  lngRow = 2

  With ThisWorkbook.Worksheets(1)
    Do Until .Cells(lngRow, 1).Value = ""
      '◆パス指定
      strPath = .Cells(lngRow, 1).Value & "¥"
      strName = .Cells(lngRow, 2).Value
    
      '◆印刷
      Call ShellExecute(Application.hwnd, "print", strPath & strName, vbNullString, "", 0)
    
      lngRow = lngRow + 1
    Loop
  End With

End Sub

ちなみに、存在しないファイルを印刷しようとするとエラーメッセージも何も出ずに次に進むので、もしフォルダやファイル名が変更される可能性があるなら、事前に自分でDir関数を使ってファイルが存在するかチェックするといいでしょう。

Powered by Seesaa
×

この広告は1年以上新しい記事の投稿がないブログに表示されております。