ab.com コミュニティ

コード: 全て選択

'文字の描画

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