« 一太郎マクロ・・・ユーザの入力を受け取る | メイン | 一太郎マクロ・・・悪児ならこう作る »

2007年6月 1日 (金)

一太郎マクロ・・・WORD FIND公開

 いよいよ、WORD FIND完成版の公開だ。実はいよいよ、と言っているが

とうの昔に出来上がっていたのだ。だから、今コードを見直してみると

気持ちの悪い部分もあるのだが、一太郎マクロ処女作ということで

敢えて手直しせずに公開することにした。下がそのキャプチャー画面である。

Taro_macro0101 *

*

*

*

*

*

*

*

*

*

*

免責: このマクロの使用によっていかなる損害が生じようと、一切責任は負いません。あらかじめご承知の上ご使用下さい。
マクロ名: 「WORD FIND」
機能: リストに入力した単語を12×12のマス目にランダムに配置する。
詳細: 単語は20個まで。
単語配置は右から左、左から右、上から下、下から上、右下から左上、左上から右下、左下から右上、右上から左下の8方向にランダムに配置する。
ブランクのマスにはオプションでランダムにアルファベットを配置する。
実行法: 右上の「★実 行★」ボタンをクリックする。

以下がそのコードだ。

declare variable $MyCell(1 To 12, 1 To 12)
%TopWall = 1
%BottomWall = 12
%LeftWall = 1
%RightWall = 12
%LoopCountMax=100

!!単語の長さを取得する
SetLength


!!単語を長い順にソートする
For %i = 1 to 20-1
    For %j = %i + 1 To 20
       If $Length(%i) < $Length(%j) Then
            %Temp =$MyWord(%i)
            $MyWord(%i) = $MyWord(%j)
            $MyWord(%j) = %Temp
            %TempNum =$Length(%i)
            $Length(%i) = $Length(%j)
            $Length(%j) = %TempNum

        End If
     Next
Next

!!単語、既データ消去
ジャンプ(.ページ番号=1,.行番号=5,.文字位置=44)
For %i = 1 To 20
    削除(.回数=12)
    Insert($MyWord(%i))
    DownCell
Next

!!単語の長さ、既データ消去
ジャンプ(.ページ番号=1,.行番号=5,.文字位置=69)
For %i= 1 to 20
    削除(.回数=2)
    Insert($Length(%i))
    DownCell()
Next

!!単語をメモリ上のセル%MyCellに書き込む
%LoopCount=1
Do

   %WordNum = 1

    For %i = 1 To 30000
       If %WordNum = 20+1 Then !!20はwordの最大数
          Exit Do
       End if

!!%LoopCountMaxに達しても回答例が見つからないときの処理--開始--
       If %LoopCount = %LoopCountMax Then
          %para = {.Title = "回答例が見つかりません。", .Icon = 3, .Button = 5}
          %Ans = MsgBox("処理を続けますか?", %para)



          If %Ans = 6 Then !! 6は「はい」
             %LoopCount = 0
          Else
             Stop
          End If
       End If
!!%LoopCountMaxに達しても回答例が見つからないときの処理--終了--

%Str = $MyWord(%WordNum)

Randomize(ThisTime())

%X = Int(Rand() * 12) + 1
%Y = Int(Rand() * 12) + 1
Randomize(ThisTime()) !!8方向
%Dir = Int(Rand() * 12)+1
%Length = Len(%Str)
%CanPlace = True
Select Case %Dir
   Case 1 !!Bottom to Top
      If %Y - %Length + 1 >= %TopWall Then
         For %DY = %Length To 1 Step -1

          If $MyCell(%Y - %DY + 1, %X) <> "" And $MyCell(%Y - %DY + 1, %X) <> Mid(%Str, %DY, 1) Then
             %CanPlace = False


             Exit For
           End If
          Next

        If %CanPlace = True Then
             For %DY = %Length To 1 Step -1
                $MyCell(%Y - %DY + 1, %X) = Mid(%Str, %DY, 1)

             Next
             %WordNum = %WordNum + 1

        End If
End If

    Case 2 To 3 !!LeftBottom to RightTop
       If %Y - %Length + 1 >= %TopWall Then
          If %X + %Length - 1 <= %RightWall Then
            For %DY = %Length To 1 Step -1
              For %DX = 1 To %Length
                 If $MyCell(%Y - %DY + 1, %X + %DX - 1) <> "" And $MyCell(%Y - %DY + 1, %X + %DX - 1) <> Mid(%Str, %DY, 1) Then


                   %CanPlace = False
                   Exit For
                 End If
              Next
            Next

       If %CanPlace = True Then
           For %DY = %Length To 1 Step -1

             $MyCell(%Y - %DY + 1, %X + %DY - 1) = Mid(%Str, %DY, 1)

           Next
             %WordNum = %WordNum + 1

       End If
   End If
End If
    Case 4 !! Left to Right
                                                                                                                       If %X + %Length - 1 <= %RightWall Then
For %DX = 1 To %Length

If $MyCell(%Y, %X + %DX - 1) <> "" And $MyCell(%Y, %X + %DX - 1) <> Mid(%Str, %DX, 1) Then
%CanPlace = False
Exit For
End If
Next

If %CanPlace = True Then
For %DX = 1 To %Length
$MyCell(%Y, %X + %DX - 1) = Mid(%Str, %DX, 1)

Next

%WordNum = %WordNum + 1

End If
End If
Case 5 To 6 !!LeftTop to RightBottom
If %X + %Length - 1 <= %RightWall Then
If %Y + %Length - 1 <= %BottomWall Then
For %DX = 1 To %Length
For %DY = 1 To %Length
If $MyCell(%Y + %DY - 1, %X + %DX - 1) <> "" And $MyCell(%Y + %DY - 1, %X + %DX - 1) <> Mid(%Str, %DY, 1) Then
%CanPlace = False
Exit For
End If
Next
Next

If %CanPlace = True Then
For %DX = 1 To %Length
$MyCell(%Y + %DX - 1, %X + %DX - 1) = Mid(%Str, %DX, 1)


Next
%WordNum = %WordNum + 1

End If
End If
End If
Case 7 !! Top To Bottom
If %Y + %Length - 1 <= %BottomWall Then

For %DY = 1 To %Length

If $MyCell(%Y + %DY - 1, %X) <> "" And $MyCell(%Y + %DY - 1, %X) <> Mid(%Str, %DY, 1) Then
%CanPlace = False
Exit For
End If
Next

If %CanPlace = True Then
For %DY = 1 To %Length
$MyCell(%Y + %DY - 1, %X) = Mid(%Str, %DY, 1)

Next
%WordNum = %WordNum + 1

End If
End If


Case 8 To 9 !!RightTop to LeftBottom
If %X - %Length + 1 >= %LeftWall Then
If %Y + %Length - 1 <= %BottomWall Then
For %DX = %Length To 1 Step -1

For %DY = 1 To %Length

If $MyCell(%Y + %DY - 1, %X - %DX + 1) <> "" And $MyCell(%Y + %DY - 1, %X - %DX + 1) <> Mid(%Str, %DX, 1) Then
%CanPlace = False
Exit For
End If
Next
Next

If %CanPlace = True Then
For %DX = %Length To 1 Step -1
$MyCell(%Y + %DX - 1, %X - %DX + 1) = Mid(%Str, %DX, 1)

Next
%WordNum = %WordNum + 1

End If
End If
End If

Case 10 !! Right to Left
If %X - %Length + 1 >= %LeftWall Then
For %DX = %Length To 1 Step -1

If $MyCell(%Y, %X - %DX + 1) <> "" And $MyCell(%Y, %X - %DX + 1) <> Mid(%Str, %DX, 1) Then
%CanPlace = False
Exit For
End If
Next


If %CanPlace = True Then
For %DX = %Length To 1 Step -1
$MyCell(%Y, %X - %DX + 1) = Mid(%Str, %DX, 1)

Next
%WordNum = %WordNum + 1

End If
End If
Case 11 To 12 !! RightBottom to LeftTop
If %X - %Length + 1 >= %LeftWall Then
If %Y - %Length + 1 >= %TopWall Then
For %DX = %Length To 1 Step -1
For %DY = %Length To 1 Step -1
If $MyCell(%Y - %DY + 1, %X - %DX + 1) <> "" And $MyCell(%Y - %DY + 1, %X - %DX + 1) <> Mid(%Str, %DX, 1) Then
%CanPlace = False
Exit For
End If
Next
Next


If %CanPlace = True Then
For %DX = %Length To 1 Step -1
$MyCell(%Y - %DX + 1, %X - %DX + 1) = Mid(%Str, %DX, 1)

Next
%WordNum = %WordNum + 1


End If
End If
End If
End Select
Next



%LoopCount = %LoopCount + 1

Loop
%para = {.Title = "回答例が見つかりました。", .Icon = 3, .Button = 5}
%Ans = MsgBox("空白をアルファベットで埋めますか?", %para)
!!SlamIt
If %Ans=6 Then
FillBlank
End If
SlamIt


Sub SetLength
ジャンプ(.ページ番号=1,.行番号=5,.文字位置=44)

For %y = 1 to 20
%Str=""
For %x = 1 to 12
%S = GetCharacter()
If %S= " " Or %S = " " Then
Exit For
End If

%Str = %Str & %S
Next
$MyWord(%y)=%Str
$Length(%y) = Len(%Str)
ジャンプ(.ページ番号=1,.行番号=(5+%y),.文字位置=44)
Next

ジャンプ(.ページ番号=1,.行番号=5,.文字位置=68)
For %i= 1 to 20
削除(.回数=2)
Insert($Length(%i))
DownCell()
Next

End Sub


sub FillBlank
ジャンプ(.ページ番号=1,.行番号=4,.文字位置=2)
範囲選択開始(.単位=1)
範囲選択単位(.単位=7)
ジャンプ(.ページ番号=1,.行番号=15,.文字位置=73)
削除(.回数=1)


For %Y = 1 To 12
  For %X = 1 To 12
    Randomize(ThisTime())
    %num = Int(Rand() * 26) + 97
    If $MyCell(%Y, %X)="" then
      $MyCell(%Y, %X)= Char(%num)
    End If


  Next
Next
end sub

sub SlamIt
ジャンプ(.ページ番号=1,.行番号=4,.文字位置=2)
範囲選択開始(.単位=1)
範囲選択単位(.単位=7)
ジャンプ(.ページ番号=1,.行番号=15,.文字位置=73)
削除(.回数=1)


For %Y = 1 To 12
  For %X = 1 To 12
    Randomize(ThisTime())
    %num = $MyCell(%Y, %X)
    Insert(%num)
    if %X < 12 Then
      RightCell()

    End If
  Next
  DownCell
  LeftCell(11)
Next
end sub

WORD_FIND06.lzhをダウンロード

トラックバック

このページのトラックバックURL:
http://www.typepad.jp/t/trackback/237650/6994114

このページへのトラックバック一覧 一太郎マクロ・・・WORD FIND公開:

コメント

コメントを投稿