Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

59194 / 76732

←次へ　｜　前へ→


	【22249】Re:三角形の頂点の座標は？

ｂｙｋｉｎ - 05/2/13(日) 14:01 -


	引用なし

	パスワード

こんにちわ。

>頂点の移動の際に任意の場所で止めたり、再開したりしたい

Waitでは特定のプロシージャ内で実行が一時停止されるだけです。
任意に停止／再開を繰り替えすんやったら、一旦プロシージャを抜けるようにして、
フラグで判定すればええんとちゃいまっか？

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Triangle As Shape
Private CurrentPos As Single
Private Flg As Boolean

Sub 三角形の描画()
　　If Not Flg Then
　　　　図の削除
　　　　With ActiveSheet.Shapes
　　　　　　With .BuildFreeform(msoEditingAuto, 200, 200)
　　　　　　　　.AddNodes msoSegmentLine, msoEditingAuto, 340, 100
　　　　　　　　.AddNodes msoSegmentLine, msoEditingAuto, 400, 200
　　　　　　　　.AddNodes msoSegmentLine, msoEditingAuto, 200, 200
　　　　　　　　Set Triangle = .ConvertToShape
　　　　　　End With
　　　　　　With Triangle
　　　　　　　　.Fill.Visible = msoFalse
　　　　　　　　.Fill.ForeColor.RGB = vbRed
　　　　　　　　.Line.DashStyle = msoLineDash
　　　　　　End With
　　　　　　DoEvents
　　　　　　Sleep 1000
　　　　　　.AddLine(50, 200, 600, 200).Line.DashStyle = msoLineDashDot
　　　　　　.AddLine(50, 100, 600, 100).Line.DashStyle = msoLineDashDot
　　　　　　.AddLine 200, 200, 400, 200
　　　　End With
　　　　CurrentPos = 0
　　End If
End Sub

Sub 移動開始()
　　If Not Flg Then
　　　　Flg = True
　　　　CurrentPos = 頂点の移動(CurrentPos)
　　End If
End Sub

Function 頂点の移動(ByVal Counter As Long) As Long
　　Dim i As Long
　　
　　With Triangle
　　　　With .Nodes
　　　　　　For i = Counter To 250 Step 2
　　　　　　　　If Flg Then
　　　　　　　　　　If Counter = 250 Then Flg = False
　　　　　　　　　　.SetPosition 2, 340 + i, 100
　　　　　　　　　　DoEvents
　　　　　　　　　　Sleep 100
　　　　　　　　Else
　　　　　　　　　　頂点の移動 = i
　　　　　　　　　　Exit Function
　　　　　　　　End If
　　　　　　Next
　　　　End With
　　　　.Fill.Visible = msoTrue
　　　　.Line.DashStyle = msoLineSolid
　　End With
　　Flg = False
　　頂点の移動 = 0
End Function

Sub 頂点を元に戻す()
　　If Not Flg Then
　　　　With Triangle
　　　　　　.Nodes.SetPosition 2, 340, 100
　　　　　　.Fill.Visible = msoFalse
　　　　　　.Line.DashStyle = msoLineDash
　　　　End With
　　　　CurrentPos = 0
　　　　DoEvents
　　End If
End Sub

Sub 図の削除()
　　On Error Resume Next
　　If Not Flg Then
　　　　ActiveSheet.Lines.Delete
　　　　Triangle.Delete
　　　　Set Triangle = Nothing
　　　　CurrentPos = 0
　　　　Flg = False
　　End If
End Sub

Sub 一時停止()
　　If Flg Then Flg = False
End Sub

「移動開始」で変形を開始して、「一時停止」でストップ。
再開はもう一度「移動開始」です。

試してみてな。
ほな。

0 hits

▼

【22204】三角形の頂点の座標は？ ponpon 05/2/11(金) 12:46