すごろくメモ２

Public Type POINTAPI
x As Long
y As Long
End Type

Public Declare Function GetCursorPos Lib "USER32" (lpPoint As POINTAPI) As Long

Sub 座標調整()
Dim poi As POINTAPI
Call GetCursorPos(poi)
Range("O1").Value = poi.x
Range("O2").Value = poi.y
End Sub

Sub ナンバリング_リセット()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
shp.Delete
End If
Next shp
End Sub

Sub ナンバリング_追加()
'最大値を取得
Dim shp As Shape
Dim max As Integer
Dim tmp_text As String
Dim tmp_int As Integer
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
tmp_text = shp.TextFrame2.TextRange.Characters.Text
If IsNumeric(tmp_text) Then
tmp_int = Val(tmp_text)
If max < tmp_int Then
max = tmp_int
End If
End If
End If
Next shp

'位置調整用の座標を取得
x_offset = Range("O1").Value
y_offset = Range("O2").Value

'クリック座標を取得
Dim poi As POINTAPI
Call GetCursorPos(poi)
If poi.x < x_offset Then
Application.StatusBar = "範囲外です"
Application.Wait Now() + TimeSerial(0, 0, 1)
Application.StatusBar = ""
Exit Sub
End If
If poi.y < y_offset Then
Application.StatusBar = "範囲外です"
Application.Wait Now() + TimeSerial(0, 0, 1)
Application.StatusBar = ""
Exit Sub
End If

'最大値+1のオブジェクトを追加
ActiveSheet.Shapes.AddLabel(msoTextOrientationHorizontal, _
(poi.x - x_offset - 16) / 2, _
(poi.y - y_offset - 16) / 2, _
32, 32).Select
Selection.ShapeRange(1).TextFrame2.TextRange.Characters.Text = Str(max + 1)
Selection.ShapeRange(1).TextFrame2.TextRange.Characters(1, 1).ParagraphFormat.FirstLineIndent = 0
End Sub

すごろくメモ１

Function キャラクタ_位置リセット()

End Function

Function 分かれ道選択(min, max)
Randomize '乱数系列初期化
分かれ道選択 = (max - min + 1) * Rnd + 1
End Function

Function キャラクタ_進む(ch_name)
'最大値を取得
Dim shp As Shape
Dim max As Integer
Dim tmp_text As String
Dim tmp_int As Integer
For Each shp In ActiveSheet.Shapes
'MsgBox shp.Type & " : " & shp.Name
If shp.Type = msoTextBox Then
tmp_text = shp.TextFrame2.TextRange.Characters.Text
If IsNumeric(tmp_text) Then
tmp_int = Val(tmp_text)
If max < tmp_int Then
max = tmp_int
End If
End If
End If
Next shp

'ルート取得
Dim masu_x() As Integer
Dim masu_y() As Integer
ReDim masu_x(max)
ReDim masu_y(max)
For Each shp In ActiveSheet.Shapes
If shp.Type = msoTextBox Then
tmp_text = shp.TextFrame2.TextRange.Characters.Text
If IsNumeric(tmp_text) Then
tmp_int = Val(tmp_text)
x = shp.Left + (shp.Width / 2)
y = shp.Top + (shp.Height / 2)
masu_x(tmp_int) = x
masu_y(tmp_int) = y
End If
End If
Next shp

'進む
ActiveSheet.Shapes("icon_yuki").Select
offset_x = Selection.Width / 2
offset_y = Selection.Height / 2
For i = 1 To max - 1
'位置をセット
Selection.ShapeRange.Left = masu_x(i) - offset_x
Selection.ShapeRange.Top = masu_y(i) - offset_y
DoEvents

'次のマスへの距離を取得
move_x = masu_x(i + 1) - masu_x(i)
move_y = masu_y(i + 1) - masu_y(i)

'移動の方向を取得
If move_x = 0 Then
unit_x = 0
Else
unit_x = move_x / Abs(move_x) 'プラス1またはマイナス1
End If
If move_y = 0 Then
unit_y = 0
Else
unit_y = move_y / Abs(move_y) 'プラス1またはマイナス1
End If

'移動する
If Abs(move_x) > Abs(move_y) Then
ratio = Abs(move_y / move_x)
Selection.ShapeRange.IncrementLeft unit_x
For px = 1 To move_x
If move_y <> 0 And Int(px * ratio) - Int((px - 1) * ratio) = 1 Then
Selection.ShapeRange.IncrementTop unit_y
End If
Selection.ShapeRange.IncrementLeft unit_x
DoEvents
Next
Else
ratio = Abs(move_x / move_y)
Selection.ShapeRange.IncrementTop unit_y
For px = 1 To move_y
If move_x <> 0 And Int(px * ratio) - Int((px - 1) * ratio) = 1 Then
Selection.ShapeRange.IncrementLeft unit_x
End If
Selection.ShapeRange.IncrementTop unit_y
DoEvents
Next
End If

'位置をセット
Selection.ShapeRange.Left = masu_x(i + 1) - offset_x
Selection.ShapeRange.Top = masu_y(i + 1) - offset_y
DoEvents
Next

End Function

写真

ほ

写真

ほ

写真

と