ActiveSheet.PrintOut

画像を変更しながらの印刷

 Excelに取り込んだ画像を順に表示し印刷したい。そのような時に使用するマクロです。

サンプルコード

予め「印刷範囲の設定」を行っておく必要があります。

Option Explicit
'Declare~は標準モジュールの先頭に記述します。
#If VBA7 And Win64 Then      'VBAのVersion7で、64bitマシンの場合
    Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#Else 'それ以外
    Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
#End If
'-------------------------------------------------------------------------------------------------------

Sub All_Images_PrintOut() 'シート上の全ての画像を順番に表示しながら印刷する
    '定数
    Const conCell As String = "B3"      'セル番地
    Const conWait As Long = 100         '待機時間

    '変数
    Dim dblTop(1 To 2) As Double
    Dim dblLeft(1 To 2) As Double
    Dim objImage As Shape
    With Application
        .ScreenUpdating = False
        dblTop(1) = .Range(conCell).Top
        dblLeft(1) = .Range(conCell).Left
        With .ActiveSheet
            For Each objImage In .Shapes
                With objImage
                    dblTop(2) = .Top
                    dblLeft(2) = .Left
                    .Top = dblTop(1)
                    .Left = dblLeft(1)
                    DoEvents
                    Call Sleep(conWait)
                    ActiveSheet.PrintOut
                    .Top = dblTop(2)
                    .Left = dblLeft(2)
                    DoEvents
                End With
            Next
        End With
        .ScreenUpdating = True
    End With
End Sub

連番の名前を付けた画像を順に印刷する例

Option Explicit

'Declare~は標準モジュールの先頭に記述します。
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) 
'-------------------------------------------------------------------------------------------------------

Sub Images_PrintOut() '連番の名前がついた画像を順番に表示しながら印刷する
    '定数
    Const conStart As Long = 1          '開始番号
    Const conEnd As Long = 40           '終了番号
    Const conStep As Long = 1           '間隔
    Const conCell As String = "B3"      'セル番地
    Const conShape As String = "Image_"    '画像名
    Const conWait As Long = 100         '待機時間

    '変数
    Dim lngI As Long
    Dim dblTop(1 To 2) As Double
    Dim dblLeft(1 To 2) As Double

    With Application
        .ScreenUpdating = False
        dblTop(1) = .Range(conCell).Top
        dblLeft(1) = .Range(conCell).Left
        With .ActiveSheet
            For lngI = conStart To conEnd Step conStep
                With .Shapes(conShape & lngI)
                    dblTop(2) = .Top
                    dblLeft(2) = .Left
                    .Top = dblTop(1)
                    .Left = dblLeft(1)
                    DoEvents
                    Call Sleep(conWait)
                    ActiveSheet.PrintOut
                    .Top = dblTop(2)
                    .Left = dblLeft(2)
                    DoEvents
                End With
            Next
        End With
        .ScreenUpdating = True
    End With
End Sub

定数を変更することで、様々な状況に対応出来ます。
 
 ・「開始番号」1番から40番までの印刷だと、1番の事です。
 ・「終了番号」1番から40番までの印刷だと、40番の事です。
 ・「間   隔」通常は「1」ですが、一つ飛ばしにする場合は「2」にします。
 ・「セル番地」画像を移動する際の基準となるセルです。画像の左上に位置します。
 ・「画像名 」画像の名前です。予め「画像名」+「連番」にしておく必要があります。
 ・「待機時間」画像が上手く印刷されない場合は、この値を増やして下さい。1000=1秒。

Excel Tips for Teachers

Copyright (C) 2009- 坂江 保 All Rights Reserved.