シェープの描画速度を早めるには？ (ID:80287)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

ううむ、私のマシンではがくがくすることはないですね。
それに、私のモニターは1280x1024が限度で、この解像度において試してみてもがくがくすることはありませんでした。
コンテナ用ピクチャーボックスを用意して、その中に３つピクチャーボックス
をいれて、擬似的ではありますが2400*1800にしてみてやってみたのですが、
これでもがくがくすることなくスムーズに行えました。
これはマシンのスペックに左右されてしまいますけどね。
私の考察もめるさんの考察と同じです。
ひとつのピクチャーボックスに処理をまとめてしまっているからその分オーバーヘッドが生じていると思われます。
ですので、動くのは確認してますが速度が早くなったのかはわかりませんが、
SendMessageで、Ａに飛んでくるMouseMoveメッセージ（イベント）をＢ・Ｃにも同じパラメータのMoseMoveメッセージを飛ばして、Ａ・Ｂ・Ｃそれぞれの
ウィンドウプロシージャに処理を割り振って見てはいかがでしょうか。
サンプル（RECT構造体は別に3つ用意する必要はないですが一応３つ使用してます）
Option Explicit
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
Private BackPosA    As RECT
Private BackPosB    As RECT
Private BackPosC    As RECT

Private LineDrawFlg As Boolean
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Const WM_MOUSEMOVE = &H200

Private Sub Form_Load()
picScanImg.DrawMode = vbInvert
picScanImg.ScaleMode = vbPixels
picJPEGImg.DrawMode = vbInvert
picJPEGImg.ScaleMode = vbPixels
picACCImg.DrawMode = vbInvert
picACCImg.ScaleMode = vbPixels
End Sub

Private Sub Form_Resize()
With Picture1
    .Left = 0
    .Top = 0
    .Width = Me.ScaleWidth
    .Height = Me.ScaleHeight
End With
With picScanImg
    .Left = 0
    .Top = 0
    .Width = 2400
    .Height = 1800
End With
With picACCImg
    .Left = 0
    .Top = 0
    .Width = 2400
    .Height = 1800
End With
With picJPEGImg
    .Left = 0
    .Top = 0
    .Width = 2400
    .Height = 1800
End With

End Sub

Private Sub picScanImg_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Button
    'Case vbLeftButton
    
    Case vbRightButton
        LineDrawFlg = True
        With BackPosA
            .Left = X
            .Top = Y
            .Right = X
            .Bottom = Y
        End With
        With BackPosB
            .Left = X
            .Top = Y
            .Right = X
            .Bottom = Y
        End With
        With BackPosC
            .Left = X
            .Top = Y
            .Right = X
            .Bottom = Y
        End With
        
End Select
End Sub

Private Sub picScanImg_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Select Case Button
    Case vbRightButton
        If Not LineDrawFlg Then Exit Sub
        'picScanImgに飛んでくるMouseMoveメッセージと同じ内容のメッセージをpicJPEGImg、PicACCImgにも飛ばす
        SendMessage picJPEGImg.hWnd, WM_MOUSEMOVE, 0, &H10000 * Y + X
        SendMessage picACCImg.hWnd, WM_MOUSEMOVE, 0, &H10000 * Y + X

'直前の罫線を消す
        With BackPosA
            picScanImg.Line (.Right, .Bottom)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の罫線を描画
        With BackPosA
            picScanImg.Line (X, Y)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の座標を保持
        BackPosA.Right = X
        BackPosA.Bottom = Y
End Select

End Sub
Private Sub picJPEGImg_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Debug.Print X, Y
Select Case Button
    Case vbRightButton
        '直前の罫線を消す
        With BackPosB
            picJPEGImg.Line (.Right, .Bottom)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の罫線を描画
        With BackPosB
            picJPEGImg.Line (X, Y)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の座標を保持
        BackPosB.Right = X
        BackPosB.Bottom = Y
End Select

End Sub
Private Sub picACCImg_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

Select Case Button
    Case vbRightButton
        '直前の罫線を消す
        With BackPosC
            picACCImg.Line (.Right, .Bottom)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の罫線を描画
        With BackPosC
            picACCImg.Line (X, Y)-(.Left, .Top), RGB(255, 0, 0), B
        End With
        
        '現在の座標を保持
        BackPosC.Right = X
        BackPosC.Bottom = Y
End Select

End Sub
Private Sub picScanImg_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
LineDrawFlg = False
End Sub

←解決時は質問者本人がここをチェックしてください。

戻る