いよいよ、WORD FIND完成版の公開だ。実はいよいよ、と言っているが
とうの昔に出来上がっていたのだ。だから、今コードを見直してみると
気持ちの悪い部分もあるのだが、一太郎マクロ処女作ということで
敢えて手直しせずに公開することにした。下がそのキャプチャー画面である。
*
*
*
*
*
*
*
*
*
*
*
| 免責： |
このマクロの使用によっていかなる損害が生じようと、一切責任は負いません。あらかじめご承知の上ご使用下さい。 |
| マクロ名： |
「WORD FIND」 |
| 機能： |
リストに入力した単語を１２×１２のマス目にランダムに配置する。 |
| 詳細： |
単語は２０個まで。 |
| 単語配置は右から左、左から右、上から下、下から上、右下から左上、左上から右下、左下から右上、右上から左下の８方向にランダムに配置する。 |
| ブランクのマスにはオプションでランダムにアルファベットを配置する。 |
| 実行法： |
右上の「★実 行★」ボタンをクリックする。 |
以下がそのコードだ。
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をダウンロード
最近のコメント