ab.com コミュニティ

コード: 全て選択

' ----------------------------------------------------------------------------
'  イベント プロシージャ
' ----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd

' メモ - 以下の領域を、変数、構造体、定数、関数を宣言するための、
'        グローバル領域として利用することができます。
' ----------------------------------ここから----------------------------------
Dim hFont As DWord							'フォントのハンドル
Dim lfnt As LOGFONT							'LOGFONT構造体

Dim cfmt As CHARFORMAT						'CHARFOMAT構造体
Dim lpstrFolderPath[MAX_PATH] As Byte		'ソフトの親フォルダ
Dim i As Long, i2=0 As Long					'フラグ
Dim hEdit As DWord							'リッチエディットのハンドル
Dim hLib As DWord							'ライブラリのハンドル
Dim lpKeywordBuffer As BytePtr				'キーワードファイルの内容を保持するバッファ
Dim strKeyword As String					'キーワード

Const RICHEDIT_CLASS = "RichEdit20A"
Const ID_EDIT = &HFF00
Const MaxText = 102400	'最大容量(byte)default=64K

Type FINDTEXTEX
	chrg As CHARRANGE
	lpstrText As BytePtr
	chrgText As CHARRANGE
End Type

Type CHARRANGE
	cpMin As Long
	cpMax As Long
End Type

'フルパスからファイル部を切り取る
GetModuleFileName(GetModuleHandle(0), lpstrFolderPath, MAX_PATH)
i=lstrlen(lpstrFolderPath)-1
Do
	If lpstrFolderPath=Asc("\") Then
		lpstrFolderPath=0
		Exit Do
	End If
	i=i-1
	If i<0 Then Exit Do
Loop

Sub SetKeywordColor()
	'変数宣言
	Dim ftex As FINDTEXTEX			'FINDTEXTEX構造体
	Dim chrg As CHARRANGE			'CHARRANGE構造体
	Dim i As Long, i2 As Long		'フラグ

	'リッチエディットの今までの設定を取得
	SendMessage(hEdit, EM_GETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))

	'元のカーソル位置を取得
	SendMessage(hEdit, EM_EXGETSEL, 0, VarPtr(chrg))

	'ウインドウの描画を停止
	LockWindowUpdate(hEdit)

	'一度全ての文字色を黒に変更
	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_ALL, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If

	'キーワードを検索し、その部分の文字色を変更
	i=0 : i2=0
	Do
		'キーワードを取り出す
		If (lpKeywordBuffer=13 and lpKeywordBuffer[i+1]=10) or lpKeywordBuffer=0 Then
			strKeyword[i2]=0
			ftex.chrg.cpMin=0
			ftex.chrg.cpMax=-1
			ftex.lpstrText=StrPtr(strKeyword)
			If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))>-1 Then
				Do
					'キーワードを選択し、その部分の色を変更
					SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
					cfmt.crTextColor=RGB(0, 0, 255)
					If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
						MessageBox(hMainWnd, "文字色の変更に失敗", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
					End If
					ftex.chrg.cpMin=ftex.chrgText.cpMax+1
				Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1
			End If
			If lpKeywordBuffer=0 Then Exit Do
			i=i+2 : i2=0
			Continue
		End If
		strKeyword[i2]=lpKeywordBuffer
		i=i+1 : i2=i2+1
	Loop

	'カーソルを元の位置に戻す
	SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(chrg))

	'ウインドウの描画を再開
	LockWindowUpdate(NULL)

	'文字色を黒に変更
	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If

	SendMessage(hEdit, EM_REPLACESEL, FALSE, NULL)
End Sub

Function MainWndProc(hWnd As DWord, dwMsg As DWord, wParam As DWord, lParam As DWord) As DWord
	' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
	Select Case dwMsg
		Case WM_COMMAND
			Select Case HIWORD(wParam)
				Case EN_CHANGE
						SetKeywordColor()
			End Select
	End Select

	' イベントプロシージャの呼び出しを行います。
	MainWndProc=EventCall_MainWnd(hWnd, dwMsg, wParam, lParam)
End Function

' ----------------------------------ここまで----------------------------------

Sub MainWnd_Destroy()
	DeleteObject(hFont)
    If hEdit Then DestroyWindow(hEdit)
    If hLib Then FreeLibrary(hLib)
	If lpKeywordBuffer Then free(lpKeywordBuffer)
	T_RichEdit_DestroyObjects()
	PostQuitMessage(0)
End Sub

Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
	Dim dwEvent As DWord							'イベントマスク
	Dim lpstrKeywordFilePath[MAX_PATH] As Byte		'キーワードファイルのパス
	Dim hFile As DWord								'キーワードファイルのハンドル
	Dim dwFileSize As DWord							'ファイルサイズ
	Dim dwAccessByte As DWord						'ファイルアクセスサイズ

	'RICHED32.DLL のロード
	hLib = LoadLibrary("riched20.dll")
	If hLib=0 then
		MessageBox(hMainWnd, "リッチエディットライブラリのロードに失敗", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
		Exit Sub
	End If
	'リッチエディットコントロールの作成
	hEdit = CreateWindowEx(0, _			'拡張ウィンドウスタイル
				RICHEDIT_CLASS, _		'ウィンドウクラス名
				"", _					'ウィンドウタイトル
				WS_CHILD or WS_VISIBLE or WS_BORDER or WS_VSCROLL or WS_HSCROLL or_
				ES_MULTILINE or ES_AUTOVSCROLL or ES_AUTOHSCROLL, _
				0, 0, 0, 0, _	'あとで、リサイズイベントで大きさを変える
				hMainWnd, _		'親ウィンドウ
				ID_EDIT, _		'コントロールID
				GetModuleHandle(0), _	'インスタンスハンドル
				0)
	If hEdit = 0 Then
		MessageBox(hMainWnd, "リッチエディットの作成に失敗", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
		Exit Sub
	End If
	
	'テキストの上限を設定
	SendMessage(hEdit, EM_EXLIMITTEXT, 0, MaxText)

	'フォント情報の取得
	'(hFont_MainWnd：メインウィンドのフォントハンドル:Callback.wbpで定義済み)
	GetObject(hFont_MainWnd,Len(lfnt), lfnt)

	'新しいフォントの設定
	ZeroMemory(VarPtr(lfnt), Len(lfnt))
	lfnt.lfHeight=12	'文字の高さ
	lstrcpy(lfnt.lfFaceName, "ＭＳゴシック")
	hFont=CreateFontIndirect(lfnt)

	'エディットボックスに新しいフォントを設定(WM_SETFONT)
	SendMessage(hEdit, WM_SETFONT, hFont, 1)

	'書式の設定(CHARFORMAT構造体)
	With cfmt
		.cbSize	= Len(cfmt)		'構造体のサイズ(=60)
    	.dwMask = CFM_COLOR	or CFM_CHARSET or CFM_FACE or CFM_SIZE	'有効メンバ
    	.yHeight = 280			'(twip)文字の高さ 1point=20twip
      	.crTextColor = RGB(0, 0, 0)	'文字の色
    	.bCharSet = 128     'キャラクタセット(128=SHIFTJIS_CHARSET)
    	lstrcpy(.szFaceName,"ＭＳ Ｐ明朝")	'フォント名
	End With
	SendMessage(hEdit, EM_SETCHARFORMAT, 0, VarPtr(cfmt))

	'マウスイベントを追加する
	dwEvent=SendMessage(hEdit, EM_GETEVENTMASK, 0, 0)
	SendMessage(hEdit, EM_SETEVENTMASK, 0, dwEvent or ENM_MOUSEEVENTS or ENM_UPDATE or ENM_CHANGE)

	'キーワードファイルのパスを設定
	lstrcpy(lpstrKeywordFilePath, lpstrFolderPath & Ex"\\" & "derective.ini")

	'キーワードファイルをオープン
	hFile=CreateFile(lpstrKeywordFilePath, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
						ByVal 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
	If hFile=INVALID_HANDLE_VALUE Then
		MessageBox(hMainWnd, "キーワードファイルが存在しません", "T_RichEdit", MB_OK or MB_ICONSTOP)
		ExitProcess(0)
	End If

	'ファイルサイズを取得し、バッファを確保
	dwFileSize=GetFileSize(hFile, 0)
	lpKeywordBuffer=malloc(dwFileSize+1)
	strKeyword=ZeroString(dwFileSize+1)

	'ファイルの内容を読み込む
	ReadFile(hFile, lpKeywordBuffer, dwFileSize, VarPtr(dwAccessByte), ByVal 0)
	lpKeywordBuffer[dwAccessByte]=0

	'ファイルハンドルを閉じる
	CloseHandle(hFile)
End Sub

Sub MainWnd_Resize(SizeType As Long, cx As Integer, cy As Integer)
	'メインウィンドのクライアント領域にエディットを合わせる
	MoveWindow(hEdit, 0, 0, cx, cy, TRUE)
End Sub


Sub MainWnd_Notify(ByRef nmHdr As NMHDR)
'プロジェクトオプションに「コモンコントロールを使用する」必要
	Dim lpmf As *MSGFILTER
	Dim pos As POINTAPI

	'右クリックをつかまえる
	If nmHdr.code = EN_MSGFILTER Then
		lpmf = VarPtr(nmHdr)
		If lpmf->msg = WM_RBUTTONDOWN Then
			pos.x = LOWORD(lpmf->lParam)
			pos.y = HIWORD(lpmf->lParam)
			ClientToScreen(hMainWnd, pos)
            TrackPopupMenu(hMenu_MyMenu_1, _
                 TPM_LEFTALIGN or TPM_TOPALIGN, _
                 pos.x,pos.y,0,hEdit,ByVal NULL)
		End If
	End If
End Sub

コード: 全て選択

' ----------------------------------------------------------------------------
'  イベント プロシージャ
' ----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd

' メモ - 以下の領域を、変数、構造体、定数、関数を宣言するための、
'        グローバル領域として利用することができます。
' ----------------------------------ここから----------------------------------
Dim hFont As DWord	'フォントのハンドル
Dim lfnt As LOGFONT

Dim cfmt As CHARFORMAT
Dim hEdit As DWord
Dim hLib As DWord
Dim nIsRichEditChange As Long
Dim nIsSetKeywordColor As Long
Dim lpstrFolder[MAX_PATH] As Byte
Dim i As Long

'フルパスからファイル部を切り取る
GetModuleFileName(GetModuleHandle(0), lpstrFolder, MAX_PATH)
i=lstrlen(lpstrFolder)-1
Do
	If lpstrFolder=Asc("\") Then
		lpstrFolder=0
		Exit Do
	End If
	i=i-1
	If i<0 Then Exit Do
Loop

Const RICHEDIT_CLASS = "RichEdit20A"
Const ID_EDIT = &HFF00
Const MaxText = 102400	'最大容量(byte)default=64K

Type FINDTEXTEX
	chrg As CHARRANGE
	lpstrText As *Char
	chrgText As CHARRANGE
End Type

Type CHARRANGE
	cpMin As Long
	cpMax As Long
End Type

'キーワードを色付けするプロシージャ
Sub SetKeywordColor()
	Dim ftex As FINDTEXTEX				'FINDTEXT構造体
	Dim chrg As CHARRANGE				'CHARRANGE構造体。元のカーソルの位置が格納される
	Dim hFile As DWord					'ファイルハンドル
	Dim lpBuffer As BytePtr				'バッファ
	Dim dwFileSize As DWord				'ファイルサイズ
	Dim dwAccessByte As DWord			'アクセスバイト
	Dim lpstrFilePath[MAX_PATH] As Byte	'ファイルパス 
	Dim i As Long, i2 As Long			'フラグ
	Dim strKeyword As String			'キーワード
	Dim StPos As DWord					'範囲があるタグの初めと終わりの位置
	Dim dwTopCursorPos As DWord			'一番上に表示されているカーソルのインデックスナンバー
	Dim nMovePos As Long				'エディットボックスの内容をスクロールする

	'リッチエディットの今までの設定を取得
	SendMessage(hEdit, EM_GETCHARFORMAT, TRUE, VarPtr(cfmt))

	'元のカーソル位置を取得
	SendMessage(hEdit, EM_EXGETSEL, 0, VarPtr(chrg))

	'一番上に表示されている行のインデックスナンバーを取得
	dwTopCursorPos=SendMessage(hEdit, EM_GETFIRSTVISIBLELINE, 0, 0)

	'カーソルの行と一番上の行の差を計算
	nMovePos=chrg.cpMin-dwTopCursorPos

	'リッチエディットの反転表示を一時停止
	SendMessage(hEdit, EM_HIDESELECTION, 1, 0)

	'キーワードファイルのパスを設定
	lstrcpy(lpstrFilePath, lpstrFolder & "\\" & "derective.ini")

	'ウインドウの描画を停止する
	LockWindowUpdate(hEdit)

	'キーワードファイルをオープン
	hFile=CreateFile(lpstrFilePath, GENERIC_READ, FILE_SHARE_READ or FILE_SHARE_WRITE,
						ByVal 0, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0)
	If hFile=INVALID_HANDLE_VALUE Then
		MessageBox(hMainWnd, Ex"キーワードファイルをオープンできません\r\nキーワードファイルが他プロセスで使用中でないか、キーワードファイルが削除されていないかです", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
		Exit Sub
	End If

	'ファイルサイズを取得し、バッファを確保
	dwFileSize=GetFileSize(hFile, 0)
	lpBuffer=malloc(dwFileSize+1)
	strKeyword=ZeroString(dwFileSize+1)

	'ファイルの内容を読み込む
	ReadFile(hFile, lpBuffer, dwFileSize, VarPtr(dwAccessByte), ByVal 0)
	lpBuffer[dwAccessByte]=0

	'ファイルハンドルを閉じる
	CloseHandle(hFile)

	'一度全ての文字を黒色に変更
	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_ALL, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If

	'キーワードを検索し、その部分の文字色を変更
	i=0:i2=0
	Do
		'キーワードを取り出す
		If (lpBuffer=13 and lpBuffer[i+1]=10) or lpBuffer=0 Then
			strKeyword[i2]=0
			FillMemory(VarPtr(ftex), 0, Len(ftex))
			ftex.chrg.cpMin=0
			ftex.chrg.cpMax=-1
			ftex.lpstrText=StrPtr(strKeyword)
			If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))>-1 Then
				Do
					SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
					cfmt.crTextColor=RGB(0, 0, 255)
					If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
						MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
					End If
					ftex.chrg.cpMin=ftex.chrgText.cpMin+1
				Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1
			End If
			If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD, VarPtr(ftex))>-1 Then
				Do
					SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
					cfmt.crTextColor=RGB(0, 0, 255)
					If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
						MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
					End If
					ftex.chrg.cpMin=ftex.chrgText.cpMin+1
				Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1
			End If
			If lpBuffer=0 Then Exit Do
			i=i+2:i2=0
			Continue
		End If
		strKeyword[i2]=lpBuffer
		i=i+1:i2=i2+1
	Loop

	'コメントとダブルクォートの色を変える
	ftex.chrg.cpMin=0
	ftex.chrg.cpMax=-1
	ftex.lpstrText=Ex"\q"
	If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))>-1 Then
		Do
			StPos=ftex.chrgText.cpMin
			ftex.chrg.cpMin=ftex.chrgText.cpMin+1
			If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1 Then Exit Do
			ftex.chrgText.cpMin=StPos
			SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
			cfmt.crTextColor=RGB(160, 20, 20)
			If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
				MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
			End If
			ftex.chrg.cpMin=ftex.chrgText.cpMin+1
			ftex.chrg.cpMax=-1
		Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1
	End If

	'リッチエディットの反転表示一時停止を解除
	SendMessage(hEdit, EM_HIDESELECTION, 0, 0)

	'元の位置にカーソルを戻す
	SendMessage(hEdit, EM_SETSEL, chrg.cpMin, chrg.cpMax)
	If nMovePos>-1 and nMovePos<>0 Then
		For i=1 To nMovePos
			SendMessage(hEdit, EM_SCROLL, SB_LINEDOWN, 0)
		Next 
	ElseIf nMovePos<0 Then
		For i=0 To nMovePos Step -1
			SendMessage(hEdit, EM_SCROLL, SB_LINEUP, 0)
		Next
	End If 

	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If

	'ウインドウの描画を開始する
	LockWindowUpdate(NULL)
End Sub

Function MainWndProc(hWnd As DWord, dwMsg As DWord, wParam As DWord, lParam As DWord) As DWord
	' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
	Select Case dwMsg
		Case WM_COMMAND
			Select Case HIWORD(wParam)
				Case EN_CHANGE
					SetKeywordColor()
			End Select
	End Select

	' イベントプロシージャの呼び出しを行います。
	MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function

' ----------------------------------ここまで----------------------------------

Sub MainWnd_Destroy()
	'DeleteObject(hFont)
    If hEdit Then DestroyWindow(hEdit)
    If hLib Then FreeLibrary(hLib)
	T_RichEdit_DestroyObjects()
	PostQuitMessage(0)
End Sub

Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
	Dim dwEvent As DWord

	'RICHED32.DLL のロード
	hLib = LoadLibrary("riched20.dll")
	If hLib=0 then
		MessageBox(hMainWnd,"Failure LoadLib","",MB_OK)
		Exit Sub
	End If
	'リッチエディットコントロールの作成
	hEdit = CreateWindowEx(0, _			'拡張ウィンドウスタイル
				RICHEDIT_CLASS, _		'ウィンドウクラス名
				"", _					'ウィンドウタイトル
				WS_CHILD or WS_VISIBLE or WS_BORDER or WS_VSCROLL or _
				ES_MULTILINE or ES_AUTOVSCROLL, _
				0, 0, 0, 0, _	'あとで、リサイズイベントで大きさを変える
				hMainWnd, _		'親ウィンドウ
				ID_EDIT, _		'コントロールID
				GetModuleHandle(0), _	'インスタンスハンドル
				0)
	If hEdit = 0 Then
		MessageBox(hMainWnd,"Failure CreateWindowEx","",MB_OK)
		Exit Sub
	End If
	
	'テキストの上限を設定
	SendMessage(hEdit, EM_EXLIMITTEXT, 0, MaxText)

	'フォント情報の取得
	'(hFont_MainWnd：メインウィンドのフォントハンドル:Callback.wbpで定義済み)
	GetObject(hFont_MainWnd,Len(lfnt),lfnt)

	'新しいフォントの設定
	ZeroMemory(VarPtr(lfnt),Len(lfnt))
	lfnt.lfHeight=12	'文字の高さ
	lstrcpy(lfnt.lfFaceName, "FixedSys")
	hFont=CreateFontIndirect(lfnt)

	'エディットボックスに新しいフォントを設定(WM_SETFONT)
	SendMessage(hEdit,WM_SETFONT,hFont,1)

	'書式の設定(CHARFORMAT構造体)
	With cfmt
		.cbSize	= Len(cfmt)		'構造体のサイズ(=60)
    	.dwMask = CFM_COLOR	or CFM_CHARSET or CFM_FACE or CFM_SIZE	'有効メンバ
    	.yHeight = 280			'(twip)文字の高さ 1point=20twip
      	.crTextColor = RGB(0,0,0)	'文字の色
    	.bCharSet = 128     'キャラクタセット(128=SHIFTJIS_CHARSET)
    	lstrcpy(.szFaceName,"FixedSys")	'フォント名
	End With
	SendMessage(hEdit,EM_SETCHARFORMAT,0,VarPtr(cfmt))

	'マウスイベントを追加する
	dwEvent=SendMessage(hEdit, EM_GETEVENTMASK, 0, 0)
	SendMessage(hEdit, EM_SETEVENTMASK, 0, dwEvent or ENM_MOUSEEVENTS or ENM_CHANGE)
End Sub

Sub MainWnd_Resize(SizeType As Long, cx As Integer, cy As Integer)
	'メインウィンドのクライアント領域にエディットを合わせる
	MoveWindow(hEdit, 0, 0, cx, cy, TRUE)
End Sub


Sub MainWnd_Notify(ByRef nmHdr As NMHDR)
'プロジェクトオプションに「コモンコントロールを使用する」必要
	Dim lpmf As *MSGFILTER
	Dim pos As POINTAPI

	'右クリックをつかまえる
	If nmHdr.code = EN_MSGFILTER Then
		lpmf = VarPtr(nmHdr)
		If lpmf->msg = WM_RBUTTONDOWN Then
			pos.x = LOWORD(lpmf->lParam)
			pos.y = HIWORD(lpmf->lParam)
			ClientToScreen(hMainWnd, pos)
            Select Case TrackPopupMenu(hMenu_MyMenu_1, TPM_LEFTALIGN or TPM_TOPALIGN or TPM_RETURNCMD, pos.x,pos.y,0,hEdit,ByVal NULL)
				Case IDM_UNDO
			End Select
		End If
	End If
End Sub

コード: 全て選択

'キーワードを色付けするプロシージャ
Sub SetKeywordColor()
	Dim strTextBuffer As String			'テキストバッファ
	Dim dwLength As DWord				'テキストの長さ
	Dim strTemp As String				'新たに書き込むテキストの一時保存用
	Dim dw As DWord, dw2 As DWord
	Dim ftex As FINDTEXTEX				'FINDTEXT構造体
	Dim chrg As CHARRANGE				'CHARRANGE構造体。元のカーソルの位置が格納される

	'リッチエディットの今までの設定を取得
	SendMessage(hEdit, EM_GETCHARFORMAT, TRUE, VarPtr(cfmt))

	'元のカーソル位置を取得
	SendMessage(hEdit, EM_EXGETSEL, 0, VarPtr(chrg))

	'リッチエディットの反転表示を一時停止
	SendMessage(hEdit, EM_HIDESELECTION, 1, 0)

	'カーソルの位置を一時的に先頭に変更
	SendMessage(hEdit, EM_SETSEL, 0, 0)

	dwLength=GetWindowTextLength(hEdit)

	'キーワードを検索し、その部分の文字色を変更
	ftex.chrg.cpMin=0
	ftex.chrg.cpMax=-1
	ftex.lpstrText="If"
	If SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))>-1 Then
		Do
			SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
			cfmt.crTextColor=RGB(0, 0, 255)
			If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
				MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
			End If
			ftex.chrg.cpMin=ftex.chrgText.cpMin+1
		Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))=-1
	End If

	'リッチエディットの反転表示一時停止を解除
	SendMessage(hEdit, EM_HIDESELECTION, 0, 0)

	'元の位置にカーソルを戻す
	SendMessage(hEdit, EM_SETSEL, chrg.cpMin, chrg.cpMax)

	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If
End Sub

コード: 全て選択

' ----------------------------------------------------------------------------
'  イベント プロシージャ
' ----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd

' メモ - 以下の領域を、変数、構造体、定数、関数を宣言するための、
'        グローバル領域として利用することができます。
' ----------------------------------ここから----------------------------------
Dim hFont As DWord	'フォントのハンドル
Dim lfnt As LOGFONT

Dim cfmt As CHARFORMAT
Dim hEdit As DWord
Dim hLib As DWord
Dim nIsRichEditChange As Long
Dim nIsSetKeywordColor As Long

Const RICHEDIT_CLASS = "RichEdit20A"
Const ID_EDIT = &HFF00
Const MaxText = 102400	'最大容量(byte)default=64K

Type FINDTEXTEX
	chrg As CHARRANGE
	lpstrText As *Char
	chrgText As CHARRANGE
End Type

Type CHARRANGE
	cpMin As Long
	cpMax As Long
End Type

'キーワードを色付けするプロシージャ
Sub SetKeywordColor()
	Dim strTextBuffer As String			'テキストバッファ
	Dim dwLength As DWord				'テキストの長さ
	Dim strTemp As String				'新たに書き込むテキストの一時保存用
	Dim dw As DWord, dw2 As DWord
	Dim ftex As FINDTEXTEX				'FINDTEXT構造体
	Dim chrg As CHARRANGE				'CHARRANGE構造体。元のカーソルの位置が格納される

	'リッチエディットの今までの設定を取得
	SendMessage(hEdit, EM_GETCHARFORMAT, TRUE, VarPtr(cfmt))

	'元のカーソル位置を取得
	SendMessage(hEdit, EM_EXGETSEL, 0, VarPtr(chrg))

	'リッチエディットの反転表示を一時停止
	SendMessage(hEdit, EM_HIDESELECTION, 1, 0)

	'カーソルの位置を一時的に先頭に変更
	SendMessage(hEdit, EM_SETSEL, 0, 0)

	dwLength=GetWindowTextLength(hEdit)

	'キーワードを検索し、その部分の文字色を変更
	ftex.chrg.cpMin=1
	ftex.chrg.cpMax=-1
	ftex.lpstrText="If"
	If SendMessage(hEdit, EM_FINDTEXT, FR_WHOLEWORD or FR_DOWN, VarPtr(ftex))>-1 Then
		SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
		cfmt.crTextColor=RGB(0, 0, 255)
		If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
			MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
		End If
	End If

	'リッチエディットの反転表示一時停止を解除
	SendMessage(hEdit, EM_HIDESELECTION, 0, 0)

	SendMessage(hEdit, EM_SETSEL, chrg.cpMin, chrg.cpMax)/*
	cfmt.crTextColor=RGB(0, 0, 0)
	If SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))=0 Then
		MessageBox(hMainWnd, "文字色の変更に失敗しました", "Error - T_RichEdit", MB_OK or MB_ICONSTOP)
	End If*/
End Sub 

Function MainWndProc(hWnd As DWord, dwMsg As DWord, wParam As DWord, lParam As DWord) As DWord
	' TODO: この位置にウィンドウメッセージを処理するためのコードを記述します。
	Select Case dwMsg
		Case WM_COMMAND
			Select Case HIWORD(wParam)
				Case EN_CHANGE
					SetKeywordColor()
			End Select
	End Select

	' イベントプロシージャの呼び出しを行います。
	MainWndProc=EventCall_MainWnd(hWnd,dwMsg,wParam,lParam)
End Function

' ----------------------------------ここまで----------------------------------

Sub MainWnd_Destroy()
	'DeleteObject(hFont)
    If hEdit Then DestroyWindow(hEdit)
    If hLib Then FreeLibrary(hLib)
	T_RichEdit_DestroyObjects()
	PostQuitMessage(0)
End Sub

Sub MainWnd_Create(ByRef CreateStruct As CREATESTRUCT)
	Dim dwEvent As DWord

	'RICHED32.DLL のロード
	hLib = LoadLibrary("riched20.dll")
	If hLib=0 then
		MessageBox(hMainWnd,"Failure LoadLib","",MB_OK)
		Exit Sub
	End If
	'リッチエディットコントロールの作成
	hEdit = CreateWindowEx(0, _			'拡張ウィンドウスタイル
				RICHEDIT_CLASS, _		'ウィンドウクラス名
				"", _					'ウィンドウタイトル
				WS_CHILD or WS_VISIBLE or WS_BORDER or WS_VSCROLL or _
				ES_MULTILINE or ES_AUTOVSCROLL, _
				0, 0, 0, 0, _	'あとで、リサイズイベントで大きさを変える
				hMainWnd, _		'親ウィンドウ
				ID_EDIT, _		'コントロールID
				GetModuleHandle(0), _	'インスタンスハンドル
				0)
	If hEdit = 0 Then
		MessageBox(hMainWnd,"Failure CreateWindowEx","",MB_OK)
		Exit Sub
	End If
	
	'テキストの上限を設定
	SendMessage(hEdit,EM_EXLIMITTEXT,0,MaxText)

	'フォント情報の取得
	'(hFont_MainWnd：メインウィンドのフォントハンドル:Callback.wbpで定義済み)
	GetObject(hFont_MainWnd,Len(lfnt),lfnt)

	'新しいフォントの設定
	ZeroMemory(VarPtr(lfnt),Len(lfnt))
	lfnt.lfHeight=12	'文字の高さ
	lstrcpy(lfnt.lfFaceName, "FixedSys")
	hFont=CreateFontIndirect(lfnt)

	'エディットボックスに新しいフォントを設定(WM_SETFONT)
	SendMessage(hEdit,WM_SETFONT,hFont,1)

	'書式の設定(CHARFORMAT構造体)
	With cfmt
		.cbSize	= Len(cfmt)		'構造体のサイズ(=60)
    	.dwMask = CFM_COLOR	or CFM_CHARSET or CFM_FACE or CFM_SIZE	'有効メンバ
    	.yHeight = 280			'(twip)文字の高さ 1point=20twip
      	.crTextColor = RGB(0,0,0)	'文字の色
    	.bCharSet = 128     'キャラクタセット(128=SHIFTJIS_CHARSET)
    	lstrcpy(.szFaceName,"FixedSys")	'フォント名
	End With
	SendMessage(hEdit,EM_SETCHARFORMAT,0,VarPtr(cfmt))

	'マウスイベントを追加する
	dwEvent=SendMessage(hEdit, EM_GETEVENTMASK, 0, 0)
	SendMessage(hEdit, EM_SETEVENTMASK, 0, dwEvent or ENM_MOUSEEVENTS or ENM_CHANGE)

End Sub

Sub MainWnd_Resize(SizeType As Long, cx As Integer, cy As Integer)
	'メインウィンドのクライアント領域にエディットを合わせる
	MoveWindow(hEdit, 0, 0, cx, cy, TRUE)
End Sub


Sub MainWnd_Notify(ByRef nmHdr As NMHDR)
'プロジェクトオプションに「コモンコントロールを使用する」必要
	Dim lpmf As *MSGFILTER
	Dim pos As POINTAPI

	'右クリックをつかまえる
	If nmHdr.code = EN_MSGFILTER Then
		lpmf = VarPtr(nmHdr)
		If lpmf->msg = WM_RBUTTONDOWN Then
			pos.x = LOWORD(lpmf->lParam)
			pos.y = HIWORD(lpmf->lParam)
			ClientToScreen(hMainWnd, pos)
            Select Case TrackPopupMenu(hMenu_MyMenu_1, TPM_LEFTALIGN or TPM_TOPALIGN or TPM_RETURNCMD, pos.x,pos.y,0,hEdit,ByVal NULL)
				Case IDM_UNDO
			End Select
		End If
	End If
End Sub