워크시트에서 퍼즐 게임

옛날에 쓰여진 VBA Tips

Const RANGE_COUNT As String = "K15"
Const RANGE_PUZZLE As String = "F15:I18"

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

  Dim moveDirection As String

  Cancel = True
  If Intersect(Target, Range(RANGE_PUZZLE)) Is Nothing Then
    Call PuzzleStart
    Exit Sub
  End If

  ' 移動方向判定
  moveDirection = IsCanMove(Target)

  ' 移動
  Select Case moveDirection
    Case ""
     Exit Sub
    Case "Up"
      Call PieceMove(Target, Target.Offset(-1, 0))

    Case "Right"
      Call PieceMove(Target, Target.Offset(0, 1))

    Case "Down"
      Call PieceMove(Target, Target.Offset(1, 0))

    Case "Left"
      Call PieceMove(Target, Target.Offset(0, -1))

  End Select

  Range(RANGE_COUNT).Value = Range(RANGE_COUNT).Value + 1

  If IsComplete Then
    MsgBox "Complete!!"
    'Range(RANGE_COUNT).Value = 0
  End If

End Sub

' 終了判定
Function IsComplete() As Boolean

  Dim i As Integer
  Dim rngPiece As Range

  i = 1
  For Each rngPiece In Range(RANGE_PUZZLE)
    If rngPiece.Value = "" Then Exit For
    If rngPiece.Value <> i Then Exit For
    i = i + 1
  Next

  If i = 16 Then
    IsComplete = True
  Else
    IsComplete = False
  End If

End Function

' 駒の移動
Sub PieceMove(rngTarget As Range, rngMove As Range)

  rngMove.Value = rngTarget.Value
  rngMove.Interior.ColorIndex = 36

  rngTarget.ClearContents
  rngTarget.Interior.ColorIndex = 2

End Sub

' 移動可能な方向を返す
Function IsCanMove(rngTarget As Range) As String

  IsCanMove = ""
  With rngTarget
    ' 上
    If .Offset(-1, 0) = "" Then
      If Not Intersect(.Offset(-1, 0), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Up"
        Exit Function
      End If
    End If

    ' 右
    If .Offset(0, 1) = "" Then
      If Not Intersect(.Offset(0, 1), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Right"
        Exit Function
      End If
    End If

    ' 下
    If .Offset(1, 0) = "" Then
      If Not Intersect(.Offset(1, 0), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Down"
        Exit Function
      End If
    End If

    ' 左
    If .Offset(0, -1) = "" Then
      If Not Intersect(.Offset(0, -1), Range(RANGE_PUZZLE)) Is Nothing Then
        IsCanMove = "Left"
        Exit Function
      End If
    End If

  End With

End Function

' 並びをバラバラにする
Sub PuzzleStart()

  Dim i As Integer
  Dim rngPiece As Range
  Dim strMovePiece As String

  ' 100回駒を動かして並びをバラバラにする
  For i = 0 To 100
    For Each rngPiece In Range(RANGE_PUZZLE)
      If rngPiece.Value = "" Then Exit For
    Next

    strMovePiece = GetMovePiece(rngPiece)

    Select Case strMovePiece
      Case "Up"
        Call PieceMove(rngPiece.Offset(-1, 0), rngPiece)

      Case "Right"
        Call PieceMove(rngPiece.Offset(0, 1), rngPiece)

      Case "Down"
        Call PieceMove(rngPiece.Offset(1, 0), rngPiece)

      Case "Left"
        Call PieceMove(rngPiece.Offset(0, -1), rngPiece)
    End Select
  Next

  Range(RANGE_COUNT).Value = 0

End Sub

' 移動する駒をランダム選択
Function GetMovePiece(rngTarget As Range) As String

  Dim i As Integer
  Dim j As Integer
  Dim aryMoveDirection() As String

  i = 0

  ' 上
  If rngTarget.Offset(-1, 0) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Up"
    i = i + 1
  End If

  ' 右
  If rngTarget.Offset(0, 1) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Right"
    i = i + 1
  End If

  ' 下
  If rngTarget.Offset(1, 0) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Down"
    i = i + 1
  End If

  ' 左
  If rngTarget.Offset(0, -1) <> "" Then
    ReDim Preserve aryMoveDirection(i)
    aryMoveDirection(i) = "Left"
    i = i + 1
  End If

  Randomize
  j = Int(((UBound(aryMoveDirection) + 1) * Rnd))
  GetMovePiece = aryMoveDirection(j)

End Function