Option Explicit

'元に戻す＆やり直しも付いた簡易PaintEditerサンプルです

Const PicCount = 4      '隠しPictureBoxの配列(Index)の最大値
Dim NowTool As String   '現在のツール
Dim NowUndo As Integer  '現在の表示している画像の新しさ(0が一番新しい)
Dim MaxUndo As Integer  'NowUndo(元に戻す)の限界値

'Optionのツールの選択
Private Sub Option1_Click(Index As Integer)
    
    '選択されたOptionだけチェックします
    Option1(Index).Value = 1
    
    'ツール名を代入します
    NowTool = Option1(Index).Caption
    
End Sub

'元に戻す
Private Sub Command1_Click()
    NowUndo = NowUndo + 1
    If NowUndo = MaxUndo Then
        Command1.Enabled = False
    End If
    Command2.Enabled = IIf(NowUndo = 0, False, True)
    Picture1.Picture = Picture2(NowUndo).Image
End Sub

'取り消し
Private Sub Command2_Click()
    NowUndo = NowUndo - 1
    If NowUndo = 0 Then
        Command2.Enabled = False
    End If
    Command1.Enabled = IIf(NowUndo = MaxUndo, False, True)
    Picture1.Picture = Picture2(NowUndo).Image
End Sub

'初期設定
Private Sub Form_Load()
    Dim j As Integer, jw As Single, jh As Single
    
    '現在のツールを代入します
    NowTool = "自由線"
    
    '元に戻すと取り消しが最初(起動直後)に使えないようにする
    Command1.Enabled = False
    Command2.Enabled = False
    
    'Picture2をPicture1と同じ大きさにする
    jw = Picture1.Width
    jh = Picture1.Height
    For j = 0 To PicCount
        Picture2(j).Visible = False
        Picture2(j).AutoRedraw = True
        Picture2(j).Move 0, 0, jw, jh
    Next
    
End Sub

'マウス処理
'マウスボタンを押した
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        SelectTool X, Y, 1
    End If
End Sub

'マウスカーソルを移動した
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        SelectTool X, Y, 2
    End If
End Sub

'マウスボタンを離した
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        SelectTool X, Y, 3
    End If
End Sub

'デバッグ用(無くてもOK)
Private Sub Timer1_Timer()
    Debug.Print "NowUndo=" & NowUndo & " MaxUndo=" & MaxUndo & " NowTool=" & NowTool
End Sub

'各ツールの総合処理をします
Sub SelectTool(X As Single, Y As Single, flag As Integer)
    Static SetX As Single
    Static SetY As Single
    Dim l       As Single
    Dim r       As Single
    Dim ix      As Single
    Dim iy      As Single
    
    'flagが1のときはMouseDown
    '2はMouseMove
    '3はMouseUp
    
    With Picture1
        'AoutoRedrawプロパティに注意して下さい
        Select Case NowTool
        
            Case "自由線"
                If flag = 1 Then
                    .AutoRedraw = True
                    Picture1.PSet (X, Y)
                    
                ElseIf flag = 2 Then
                    Picture1.Line -(X, Y)
                    
                ElseIf flag = 3 Then
                    .AutoRedraw = False
                    '元に戻す用にイメージを追加する
                    AddBeforeImage
                End If
                
                
            Case "直線"
                If flag = 1 Then
                    SetX = X
                    SetY = Y
                    
                ElseIf flag = 2 Then
                    .Cls
                    Picture1.Line (SetX, SetY)-(X, Y)
                
                ElseIf flag = 3 Then
                    .AutoRedraw = True
                    Picture1.Line (SetX, SetY)-(X, Y)
                    .AutoRedraw = False
                    '元に戻す用にイメージを追加する
                    AddBeforeImage
                End If
                
                
            Case "四角形"
                If flag = 1 Then
                    SetX = X
                    SetY = Y
                    
                ElseIf flag = 2 Then
                    .Cls
                    Picture1.Line (SetX, SetY)-(X, Y), , B
                    
                ElseIf flag = 3 Then
                    .AutoRedraw = True
                    Picture1.Line (SetX, SetY)-(X, Y), , B
                    .AutoRedraw = False
                    '元に戻す用にイメージを追加する
                    AddBeforeImage
                End If
                
                
            Case "楕円"
                ix = SetX - X
                iy = SetY - Y
                l = Sqr(Abs(ix * iy))
                
                If ix = 0 Then '分母が０にならないようにする
                    r = 1
                Else
                    r = iy / ix
                End If
                
                If flag = 1 Then
                    SetX = X
                    SetY = Y
                    
                ElseIf flag = 2 Then
                    .Cls
                    Picture1.Circle (SetX, SetY), l, , , , r
                    
                ElseIf flag = 3 Then
                    .AutoRedraw = True
                    Picture1.Circle (SetX, SetY), l, , , , r
                    .AutoRedraw = False
                    '元に戻す用にイメージを追加する
                    AddBeforeImage
                End If
                
        End Select
    End With
End Sub

'元に戻すや取り消し用に使用される
'イメージを追加する
Sub AddBeforeImage()
    Dim j As Integer
    
    'ベルトコンベアのように画像を移動する
    If NowUndo <> 0 Then
        MaxUndo = PicCount - NowUndo
        For j = 0 To MaxUndo
            Picture2(j).Picture = Picture2(j + NowUndo).Image
        Next
        NowUndo = 0
    End If
    
    MaxUndo = MaxUndo + 1
    If MaxUndo > PicCount Then
        MaxUndo = PicCount
    End If
    For j = MaxUndo To 1 Step -1
        Picture2(j).Picture = Picture2(j - 1).Picture
    Next
    Picture2(NowUndo).Picture = Picture1.Image
    Command1.Enabled = True
    Command2.Enabled = False
    
End Sub