EXECL VBAにて自動印刷１００枚でフリーズ

非常に困っています。
VBAにてシーケンサからのデータを印刷するプログラムでシーケンサのトリガーで
印刷をしています。
シーケンサのデータは５秒に１回５１２点のデータを読み込み
１番目が印刷命令だと印刷すると言った具合ですが、
何度シミュレーションしても１０５～１１０枚印刷するとフィリーズします。
何が影響しているかイベントビュワー等解析しても分からず困っています。
ご教示願います。

====================================
Private Sub Auto_Open()

一定時間周期でプロシージャー実行

End Sub

Sub 一定時間周期でプロシージャー実行()

myReserveTime = Now + TimeValue("00:00:5")
Application.OnTime EarliestTime:=myReserveTime, Procedure:="一定時間周期でプロシージャー実行"


ActiveWorkbook.Worksheets("form").Activate 'シートformをアクティブにする

データ読み込み
チェンジプリンター

End Sub

'すべての変数を明示的に宣言するようにします。

Sub データ読み込み()

Dim wRet As Long '戻り値　wRetは長整数型を宣言する
Dim wdata(513) As Long 'Integer '読み出したデバイス値
Dim wcnt As Integer 'ワークカウンタ
Dim iRet As Long '戻り値　iRetは長整数型を宣言する
Dim idata(1) As Integer '書き込むデバイス値
Dim szData As String 'デバイス名

On Error GoTo Error 'エラー処理ルーチン先設定

'論理局番をActUtlTypeコントロールのプロパティに設定する。
Worksheets("DeviceRead-Write").ActUtlType1.ActLogicalStationNumber = 1 '論理局番１を指定

'通信回線１をオープンする。
wRet = Worksheets("DeviceRead-Write").ActUtlType1.Open()

'異常終了の場合
' If (wRet <> 0) Then
'エラーコードに対応したトラブルシュートメッセージを表示する。
' ErrorViewMessage (wRet)
' Exit Sub 'VBA終了する
' End If

'---------------------D10000～読み出し-----------------------------

'D10000-D10511を読み出し、セルに表示する。

'シーケンサからデバイス値を読み出す。
wRet = Worksheets("DeviceRead-Write").ActUtlType1.ReadDeviceBlock("D10000", 512, wdata(0)) 'D10000～取込点数を指定(512)

'読み出し成功の場合
If (wRet = 0) Then '正常終了の場合

With Worksheets("DeviceRead-Write") '読み出したデバイス値をセルに設定する。
For wcnt = 0 To 511
.Cells(6 + wcnt, 4).Value = wdata(wcnt) 'セルD6～D6+512まで繰り返す
Next wcnt
End With
Else
'読み出し失敗の場合
'エラーコードに対応したトラブルシュートメッセージを表示する。
' ErrorViewMessage (wRet)

End If

'=====================D10001～書込=====================================

'PLC　D10002　に印刷命令を返す
'PLC　D10001　に　D10000の値を返す。セルにも表示する。
'M6(D10000) のセルデータをシーケンサデバイス(D10002)に書き込む。

'セルのデータを書き込むデバイス値(idata)に格納する。

With Worksheets("DeviceRead-Write")
idata(1) = CInt(.Cells(6, 4).Value)
End With

'シーケンサデバイスに値を書き込む。
szData = "D10001" & vbLf
iRet = Worksheets("DeviceRead-Write").ActUtlType1.WriteDeviceRandom2(szData, 1, idata(1))

'==================== D10001～書込終了 ==================================
'機種G,生産区分,納入先データ代入

Worksheets("DeviceRead-Write").Range("N28").Value = Worksheets("DeviceRead-Write").Range("M28").Value
Worksheets("DeviceRead-Write").Range("N33").Value = Worksheets("DeviceRead-Write").Range("L33").Value
Worksheets("DeviceRead-Write").Range("N36").Value = Worksheets("DeviceRead-Write").Range("L36").Value
'---------------------D10000～読み出し終了-----------------------------

'回線のクローズを行なう。
wRet = Worksheets("DeviceRead-Write").ActUtlType1.Close()

Exit Sub
Error: '例外処理
'回線のクローズを行なう。
wRet = Worksheets("DeviceRead-Write").ActUtlType1.Close()

'エラーを表示する。
' MsgBox Error$(Err), vbCritical
End
End Sub

Sub チェンジプリンター() '印刷切り替え
Dim myPrinter As String
myPrinter = Application.ActivePrinter '現在のプリンターを記憶
If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 2 Then 'Ｉ６が２ならEPSON_2プリンターに印刷する（Ｄ１００００上位２ビットが２）
Application.ActivePrinter = "EPSON_2 on Ne00:" 'プリンターを切り替える
ActiveSheet.PrintOut 'シートFormの印刷
Application.ActivePrinter = myPrinter 'プリンターを元に戻す
End If
If Worksheets("DeviceRead-Write").Cells(6, 13).Value = 1 Then 'Ｉ６が1ならEPSON LPプリンターに印刷する（Ｄ１００００上位２ビットが１）
ActiveSheet.PrintOut 'シートFormの印刷
End If
End Sub

No.1 回答者： DreamyCat 回答日時： 2014/07/27 10:07

まったく門外漢なのと、印刷のVBAは使ったことがないので

見当違いかもしれませんが、気になった点を書いてみます。

最後の行の印刷実行しないようにすると何回繰り返してもフリーズしないのですね。
ActiveSheet.PrintOut 'シートFormの印刷

だとすれば、５秒に１回の印刷が終わらないうちに次の指示が入り、たくさんたまっててメモリー不足になるのでは？
・５秒ごとになっているのを、１秒ごとにしてみるとか２０秒ごとにしてみるとか
・プリンターにプリントバッファーを取り付けてみるとか

・無関係だと思いますが、以下の場所にDoEventsを入れてみるとか
ActiveSheet.PrintOut 'シートFormの印刷
'ここにDoEvents

For wcnt = 0 To 511
.Cells(6 + wcnt, 4).Value = wdata(wcnt) 'セルD6～D6+512まで繰り返す
Next wcnt
'ここにDoEvents

この回答への補足

チェンジプリンタの後の行及び
御指南頂いたところにもDoEvents　を
入れてみましたが効果なしでし。
Office2003,2010でも同じ結果です。
Office2007で現在検証中・・・

なぜ１００枚を超えるとフィリーズするのかがわからないです。

補足日時：2014/07/28 10:42

この回答へのお礼

ご意見ありがとうございました。
いろいろ実験をした結果、
プリンター切替にはリソースを費やすようです。
定期的にExelを保存しないで再起動することで
継続的に出力できます。
定期的にExelを保存しないで再起動する方法を探します。

お礼日時：2014/08/04 15:04