VBAでリアルタイムで計算結果をグラフに表示

Excel2010でVBAを使っています。


30分くらいかかる計算があるのですが、
計算が終了するまで待っていたのでは、計算結果がどのようなものになるのか分からないため
リアルタイムで計算結果をグラフに表示してくれるプログラムを書きたいと考えています。


検索したところ、
http://www.johoka.net/vbsin.htm
VBの場合には、Picture1.Line を使えば、うまくいきそうだということが分かりました。
同様のことをVBA上でやりたいのですが、
http://pasokoma.jp/xp_bto/a_333563
のページにはVBAにはそのような機能はないと書かれています。

本当にユーザーフォーム上でグラフを表示させることはVBAではできないのでしょうか？


http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9d92.html
そのほか、シート上でのグラフを画像として表示させるという方法も見つかりました。
この方法でリアルタイムで計算結果を表示させるにはどうしたら良いですか？

No.1 回答者： nda23 回答日時： 2012/12/06 21:04

>ユーザフォーム

ということはExcelでしょうか？
安直なのはStatusBarを使う方法があります。
表示：Application.StatusBar = String(10, "□")
消去：Application.StatusBar = False
左から■を増やしていくとか・・・
これはDoEventsをやらないでも表示が変わる
ので、安全な処理です。

その他、プログレスバーコントロールや、
グラフ系の処理は全てウィンドウの
メッセージを処理するため、計算処理の
スレッドが走っている間はメッセージが
処理されないので、画面は変化しません。
これを処理させるには描画毎にDoEventsを
実行します。
ただ、このステートメントは全てのイベントを
拾うので、画面を閉じる操作も受け付けます。
処理中にバッタリ画面が閉じても問題が無い
というなら良いのですが、そうでない場合は
制御が面倒です。

この回答へのお礼

計算結果というのは、計算過程を表示したいという意味ではなく

http://www.johoka.net/vbsin02.gif

のような計算した結果を表示したいという意味です。

お礼日時：2012/12/06 21:21

No.2 回答者： mitarashi 回答日時： 2012/12/07 22:50

UserFormに自前で描画するご参考になるかもしれません。

http://oshiete.goo.ne.jp/qa/7331192.html

昔々C言語でWindowsの基本的な機能で描画していた頃と同じ事をVBAでやろうという事なので面倒臭いです。
http://www.kumei.ne.jp/c_lang/sdk/sdk_23.htm

No.3 回答者： mitarashi 回答日時： 2012/12/08 15:18

#2です。

お役に立つかどうか分かりませんが、「シート上のグラフを画像として表示する」の応用編です。
ファイルを介さずメモリ上で処理します。xl2010でグラフをCopyすると、Picture Objectもクリップボード内にあるのですが、直接取り出す方法が大分探しましたが見つけられませんでした。BitmapもしくはEMFからPictureに変換しています。

Userformに、Imageコントロールと、CommandButton２個を置いています

☆UserForm1モジュール
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim stopFlag As Boolean

Private Sub UserForm_Initialize()
Me.Image1.PictureSizeMode = fmPictureSizeModeStretch
End Sub

Private Sub CommandButton1_Click()
Dim i As Long
stopFlag = False
i = 1
Do While Not stopFlag
'単に既存のグラフの範囲のセル一個の値を変更しているだけ（すなわち単純な状況でしか試験してないです）
　　'この代わりに計算結果をセルに入れれば良いと思いますが、毎回セルにアクセスすると遅くなると思いますので、
　　'1000回毎にとかにする方が良いと思います。
Sheets(1).Range("C7").Value = i
i = i + 1
Sheets(1).ChartObjects(1).Copy
Me.Image1.Picture = PastePicture
　　’今回の課題ではCPU100%占有しても良さそうなので入れなくても可
Sleep 10
DoEvents: DoEvents: DoEvents
Loop
End Sub

Private Sub CommandButton2_Click()
stopFlag = True
End Sub

☆標準モジュール
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long

Const CF_BITMAP = 2
Const CF_PALETTE = 9
Const CF_ENHMETAFILE = 14
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4

'メインルーチンはこれだけ
Sub test()
UserForm1.Show
End Sub

Function PastePicture(Optional lXlPicType As Long = xlPicture) As IPicture
Dim h As Long, hPicAvail As Long, hPtr As Long, hPal As Long, lPicType As Long, hCopy As Long

lPicType = IIf(lXlPicType = xlBitmap, CF_BITMAP, CF_ENHMETAFILE)
hPicAvail = IsClipboardFormatAvailable(lPicType)
If hPicAvail <> 0 Then
h = OpenClipboard(0&)
If h > 0 Then
hPtr = GetClipboardData(lPicType)
If lPicType = CF_BITMAP Then
hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Else
hCopy = CopyEnhMetaFile(hPtr, vbNullString)
End If
h = CloseClipboard
If hPtr <> 0 Then Set PastePicture = CreatePicture(hCopy, 0, lPicType)
End If
End If
End Function

Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
Const PICTYPE_BITMAP = 1
Const PICTYPE_ENHMETAFILE = 4

With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
With uPicInfo
.Size = Len(uPicInfo)
.Type = IIf(lPicType = CF_BITMAP, PICTYPE_BITMAP, PICTYPE_ENHMETAFILE)
.hPic = hPic
.hPal = IIf(lPicType = CF_BITMAP, hPal, 0)
End With
r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
If r <> 0 Then MsgBox "Create Picture Error"
Set CreatePicture = IPic
End Function

この回答へのお礼

丁寧なご回答ありがとうございます。

しかしながら、難しすぎて私には手に負えないと思います。

代替案なのですが、
シート上に存在するグラフをリアルタイムで更新することはできないのでしょうか？
Doeventsを実行することで一瞬だけWindowsの制御をactiveにするわけですが
グラフの更新も同時にactiveにすることってできないのでしょうか？

お礼日時：2012/12/08 21:07

No.4 ベストアンサー 回答者： mitarashi 回答日時： 2012/12/08 21:39

#3です。

下記の様なコードで普通にグラフは書き換わりますので、何が問題なのかわかりかねます。

☆ワークシートモジュールに記載、コマンドボタンを2個もうけている。
Dim stopFlag As Boolean

Private Sub CommandButton1_Click()
Dim i As Long
Dim j As Double

stopFlag = False
i = 1
Do While Not stopFlag
j = i ^ 2 + 3 * i + 4
　　’グラフのデータ範囲のセル一個だけ変更している
Me.Range("B3").Value = j
i = i + 1
DoEvents: DoEvents: DoEvents
Loop

End Sub

Private Sub CommandButton2_Click()
stopFlag = True
End Sub

この回答へのお礼

ありがとうございます。

簡単なプログラムだとリアルタイムでグラフを更新されることに気がつきました。

いま少し複雑なプログラムを書いているのですが
このプログラムだとなぜか更新されません。

Do eventsとなっているところを
DoEvents: DoEvents: DoEvents
にしたり、
Application.Wait [Now() + "0:00:00.1"]
を書いてタイムラグを発生させたりすると
リアルタイムで更新されるようになりました。

Do eventsと
DoEvents: DoEvents: DoEvents

って何が異なるのでしょうか？

お礼日時：2012/12/08 23:35

No.5 回答者： mitarashi 回答日時： 2012/12/09 00:33

#4です

理由は存じませんが、（検索してみても、経験談くらいしか見つからないのですが）
xl2010になってから（VBA7になってから？）
従来は一個で十分であったDoEventsが、3回以上続けないと思うように機能しない様です。