ZeroStringを使って可変長文字列を処理しようとしたのですが、文字列の長さ(バイト数)が一定の長さ(バイト数)を超えた時点(その長さは未計測)で、BasicCompiler.exeが、エラーも出さずに、いきなりクラッシュしてコンパイルが停止します。
上記の条件を満たさない(一定の長さよりも短い)と、まったくエラーは発生しません。
このプログラムは、指定された文字列を、プログラムで解析して、StrPutに送り、TextOutで出力しています(ゲームなどである、色が途中で変わったり、太字になったりする処理を実現するためのプログラムで、StrPutは内部処理用の関数で、画面へ出力するにはStrOutを使用)。
[ここをクリックすると内容が表示されます]
※コード内の"\@"などと書かれているところは、正確には"￥@"と記述されています。
コード: 全て選択
'文字の描画
Sub StrPut(hTargetDC As HDC,dstr As BytePtr,x As Long,y As Long,fontName As BytePtr,fontSize As Integer,fontItalic As BOOL,fontUl As BOOL,fontStk As BOOL,col As Dword)
Dim new_font As HFONT
Dim old_font As HFONT
'フォント作成
new_font=CreateFont(
fontSize, '高さ
0, '横幅
0, '角度
0, ' 文字単位の角度
0, '太さ
fontItalic, '斜体
fontUl, '下線
fontStk, '打ち消し
SHIFTJIS_CHARSET,OUT_DEFAULT_PRECIS,CLIP_DEFAULT_PRECIS,
DEFAULT_QUALITY,DEFAULT_PITCH,fontName)
SetBkMode(hTargetDC,TRANSPARENT) '背景モード設定
old_font=SelectObject(hTargetDC,new_font) 'フォント選択
SetTextColor(hTargetDC,col) 'フォントカラー設定
TextOut(hTargetDC,x,y,dstr,lstrlen(dstr)) '出力
SelectObject(hTargetDC,old_font) 'フォント復元
DeleteObject(new_font) 'フォント消去
End Sub
'文字列の描画
Sub StrOut(hTargetDC As HDC,dstr As BytePtr,x As Long,y As Long,fontSize As Integer,outLine As BOOL,olCol As Dword)
Dim tstr As String '取得した文字列
Dim strCnt As Long '文字数ループ
Dim strSX As Long '取得開始位置
Dim retCnt As Long '改行の回数
Dim strX As Long '現在のX位置
Dim flgCmdExt As BytePtr '特殊コマンドフラグ
Dim strCol As Dword '文字色
Dim strBold As BOOL '太字フラグ
Dim strItalic As BOOL '斜体フラグ
Dim strUl As BOOL '下線フラグ
Dim strStk As BOOL '取り消し線フラグ
Dim fontList(1) As BytePtr 'フォントリスト
Dim cExtFontname As Integer 'フォントリスト番号
tstr = ZeroString(lstrlen(dstr))
tstr = MakeStr(dstr)
fontList(0) = "ＭＳ ゴシック"
fontList(1) = "ＭＳ 明朝"
cExtFontname = 0
strCol = RGB(255,255,255)
strX = 0
strSX = 1
For strCnt = 1 To lstrlen(tstr) \ 2
'特殊コマンドチェック ---
'通常のコマンドを検出する
Select Case Mid$(MakeStr(tstr),strSX,2)
Case "\@" '改行
strX = 0
retCnt = retCnt + 1
Goto *SkipOutChar
Case "\%" '太字にするか(このコマンドが実行されるたび、設定が変わる)
If strBold = TRUE Then
strBold = FALSE
ElseIf strBold = FALSE Then
strBold = TRUE
End If
Goto *SkipOutChar
Case "\/" '斜体にするか(このコマンドが実行されるたび、設定が変わる)
If strItalic = TRUE Then
strItalic = FALSE
ElseIf strItalic = FALSE Then
strItalic = TRUE
End If
Goto *SkipOutChar
Case "\_" '下線をつけるか(このコマンドが実行されるたび、設定が変わる)
If strUl = TRUE Then
strUl = FALSE
ElseIf strUl = FALSE Then
strUl = TRUE
End If
Goto *SkipOutChar
Case "\-" '取り消し線をつけるか(このコマンドが実行されるたび、設定が変わる)
If strStk = TRUE Then
strStk = FALSE
ElseIf strStk = FALSE Then
strStk = TRUE
End If
Goto *SkipOutChar
Case "\r" '文字色を赤に
strCol = RGB(255,0,0)
Goto *SkipOutChar
Case "\g" '文字色を緑に
strCol = RGB(0,255,0)
Goto *SkipOutChar
Case "\b" '文字色を青に
strCol = RGB(0,0,255)
Goto *SkipOutChar
Case "\y" '文字色を黄色に
strCol = RGB(255,255,0)
Goto *SkipOutChar
Case "\a" '文字色を水色に
strCol = RGB(105,180,255)
Goto *SkipOutChar
Case "\o" '文字色をオレンジに
strCol = RGB(255,125,0)
Goto *SkipOutChar
Case "\d" '文字色を黒に
strCol = RGB(0,0,0)
Goto *SkipOutChar
Case "\h" '文字色を灰色に
strCol = RGB(155,155,155)
Goto *SkipOutChar
Case "\w" '文字色を白に
strCol = RGB(255,255,255)
Goto *SkipOutChar
Case "\*" 'フォント名(番号指定)
flgCmdExt = "fontname"
'コマンドヘッダがない
If Mid$(MakeStr(tstr),strSX + 2,1) <> "{" Then
Goto *DrawMsg
End If
strSX = strSX + 2
Case Else
Goto *DrawMsg
End Select
'値を直接指定できるコマンドを検出する
If MakeStr(flgCmdExt) <> "" Then
'要素を取り出す
Dim getCmdExt As BytePtr,cntSPos As Long,CEStartPos As Long
For cntSPos = strSX To lstrlen(tstr)
'コマンドフッタ発見
If Mid$(tstr,cntSPos + 1,1) = "}" Then
CEStartPos = InStr(1,Mid$(MakeStr(tstr),strSX + 1,cntSPos),"}") - 1
getCmdExt = StrPtr(ByVal Left$(Mid$(MakeStr(tstr),strSX + 1,CEStartPos),CEStartPos))
Exit For
End If
'コマンドフッタ無し
If cntSPos >= lstrlen(tstr) Then
Goto *SkipOutChar
End If
Sleep(1)
Next cntSPos
'要素のチェック
Select Case MakeStr(flgCmdExt)
Case "fontname"
cExtFontname = Val(MakeStr(getCmdExt))
End Select
flgCmdExt = ""
If (lstrlen(MakeStr(getCmdExt)) Mod 2) = 0 Then
strSX = strSX + CEStartPos
Goto *SkipOutChar
Else
strSX = strSX + (CEStartPos + 2)
Goto *SkipOutChar2
End If
Else
flgCmdExt = ""
Goto *SkipOutChar
End If
'---
'描画
*DrawMsg
If outLine = TRUE And strBold = FALSE Then
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + ((strX * fontSize) - 1),y + (retCnt * fontSize),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,olCol)
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + (strX * fontSize),y + ((retCnt * fontSize) - 1),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,olCol)
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + ((strX * fontSize) + 1),y + (retCnt * fontSize),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,olCol)
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + (strX * fontSize),y + ((retCnt * fontSize) + 1),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,olCol)
End If
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + (strX * fontSize),y + (retCnt * fontSize),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,strCol)
If strBold = TRUE Then
StrPut(hTargetDC,Mid$(MakeStr(tstr),strSX,2),x + ((strX * fontSize) + 1),y + (retCnt * fontSize),fontList(cExtFontname),fontSize,strItalic,strUl,strStk,strCol)
End If
strX = strX + 1
*SkipOutChar
strSX = strSX + 2
*SkipOutChar2
Sleep(1)
If strSX > lstrlen(tstr) Then Exit For
Next strCnt
End Sub