リッチエディットでActiveBasicコードの色分けをやっております。
この程、色分けを全て終了することができました。しかし、それでも問題があります。
①それぞれのキーワードを選択しながら色変更をしているので、色変更する前の状態に戻せません。
②あまりにも重たいです。文字ひとつ入力しただけで一秒近くまたされるときもあります。
①について解決方法と考えているのは、リッチエディットのスクロールバーの位置を色変更前に記録し、変更後に記録した位置に戻すと言うことです。これは可能でしょうか。
②については、誰かプログラムの「ムダ」を見つけてくれませんでしょうか。
今回は、現在の状態のソフトを公開したいと思います。
http://www.exfiction.net/~yu0627/temp/AB_T_RichEdit.zip
現在のコードはこちら↓
[ここをクリックすると内容が表示されます]
コード: 全て選択
' ----------------------------------------------------------------------------
' イベント プロシージャ
' ----------------------------------------------------------------------------
' このファイルには、ウィンドウ [MainWnd] に関するイベントをコーディングします。
' ウィンドウ ハンドル: hMainWnd
' メモ - 以下の領域を、変数、構造体、定数、関数を宣言するための、
' グローバル領域として利用することができます。
' ----------------------------------ここから----------------------------------
Declare Function GetDialogBaseUnits Lib "user32.dll" () As Long
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 'フラグ
Dim dwStartPos As DWord '範囲の始まり
Dim strTemp As String '文字コード格納用
Dim nLineIndex 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)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_ALL, VarPtr(cfmt))
'カーソル位置を先頭にする
SendMessage(hEdit, EM_SETSEL, 0, 0)
'キーワードを検索し、その部分の文字色を変更
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 or FR_MATCHCASE, VarPtr(ftex))>-1 Then
Do
'キーワードを選択し、その部分の色を変更
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
cfmt.crTextColor=RGB(0, 0, 255)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
ftex.chrg.cpMin=ftex.chrgText.cpMax+1
Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_WHOLEWORD or FR_DOWN or FR_MATCHCASE, 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_SETSEL, 0, 0)
ftex.chrg.cpMin=0
ftex.chrg.cpMax=-1
ftex.lpstrText=Ex"\q"
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))>-1 Then
Do
dwStartPos=ftex.chrgText.cpMin
ftex.chrg.cpMin=ftex.chrgText.cpMin+1
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))>-1 Then
'ダブルクォートで囲まれた範囲を選択し、その部分の色を変更
ftex.chrgText.cpMin=dwStartPos
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
cfmt.crTextColor=RGB(160, 20, 20)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
ftex.chrg.cpMin=ftex.chrgText.cpMax+1
End If
Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))=-1
End If
'コメントの文字色を変更
SendMessage(hEdit, EM_SETSEL, 0, 0)
ftex.chrg.cpMin=0
ftex.chrg.cpMax=-1
ftex.lpstrText="'"
Do
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))>-1 Then
dwStartPos=ftex.chrgText.cpMin
ftex.chrg.cpMin=ftex.chrgText.cpMax
ftex.lpstrText=Ex"\r"
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))>-1 Then
ftex.chrgText.cpMin=dwStartPos
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
cfmt.crTextColor=RGB(0, 128, 0)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
Else
Exit Do
End If
ftex.chrg.cpMin=ftex.chrgText.cpMax
ftex.lpstrText="'"
Else
Exit Do
End If
Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))=-1
'複数行コメントの文字色を変更
SendMessage(hEdit, EM_SETSEL, 0, 0)
strTemp=Chr$(47) + Chr$(42)
ftex.chrg.cpMin=0
ftex.chrg.cpMax=-1
ftex.lpstrText=StrPtr(strTemp)
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))>-1 Then
Do
dwStartPos=ftex.chrgText.cpMin
ftex.chrg.cpMin=ftex.chrgText.cpMin+1
strTemp=Chr$(42) + Chr$(47)
ftex.lpstrText=StrPtr(strTemp)
If SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))=-1 Then
'複数行コメントで囲まれた範囲を選択し、その部分の色を変更
ftex.chrgText.cpMin=dwStartPos
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
cfmt.crTextColor=RGB(0, 128, 0)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
Exit Do
Else
ftex.chrgText.cpMin=dwStartPos
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(ftex.chrgText))
cfmt.crTextColor=RGB(0, 128, 0)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
ftex.chrg.cpMin=ftex.chrgText.cpMax+1
strTemp=Chr$(47) + Chr$(42)
ftex.lpstrText=StrPtr(strTemp)
End If
Loop Until SendMessage(hEdit, EM_FINDTEXTEX, FR_DOWN, VarPtr(ftex))=-1
End If
'カーソルを元の位置に戻す
SendMessage(hEdit, EM_EXSETSEL, 0, VarPtr(chrg))
'ウインドウの描画を再開
LockWindowUpdate(NULL)
'文字色を黒に変更
cfmt.crTextColor=RGB(0, 0, 0)
SendMessage(hEdit, EM_SETCHARFORMAT, SCF_SELECTION, VarPtr(cfmt))
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_AUTOHSCROLL or ES_AUTOVSCROLL, '〃
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 = SHIFTJIS_CHARSET 'キャラクタセット(128=SHIFTJIS_CHARSET)
lstrcpy(.szFaceName,"FixedSys") 'フォント名
End With
SendMessage(hEdit, EM_SETCHARFORMAT, 0, VarPtr(cfmt))
'「Dual-font support」を無効にする
SendMessage(hEdit, EM_SETLANGOPTIONS, 0, 0)
'タブの間隔を設定
'SendMessage(hEdit, EM_SETTABSTOPS, 1, 4*LOWORD(GetDialogBaseUnits()) \ 2)
'マウスイベントを追加する
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