Changeset 126 for Include/basic/prompt.sbp
- Timestamp:
- Mar 3, 2007, 5:53:34 PM (18 years ago)
- File:
-
- 1 edited
-
Include/basic/prompt.sbp (modified) (30 diffs)
Legend:
- Unmodified
- Added
- Removed
-
Include/basic/prompt.sbp
r125 r126 6 6 7 7 8 #include <api_imm.sbp> 8 #require <api_imm.sbp> 9 #require <Classes/System/Math.ab> 9 10 10 11 Dim _PromptSys_hWnd As HWND … … 13 14 14 15 'text 16 Type _PromptSys_CharacterInformation 17 ForeColor As COLORREF 18 BackColor As COLORREF 19 StartPos As Long 20 End Type 21 22 Type _PromptSys_LineInformation 23 Length As Long 24 Text As *Char 25 CharInfo As *_PromptSys_CharacterInformation 26 End Type 15 27 16 28 Dim _PromptSys_LogFont As LOGFONTA 'LOGFONT … … 21 33 Dim _PromptSys_KeyChar As Byte 22 34 Dim _PromptSys_CurPos As POINTAPI 23 Dim _PromptSys_Buffer[100] As *Char 24 Dim _PromptSys_TextColor[100] As *COLORREF 25 Dim _PromptSys_BackColor[100] As *COLORREF 26 Dim _PromptSys_TextWidth[100] As Long 35 Dim _PromptSys_TextLine[100] As _PromptSys_LineInformation 27 36 Dim _PromptSys_NowTextColor As COLORREF 28 37 Dim _PromptSys_NowBackColor As COLORREF … … 30 39 31 40 32 _PromptSys_InputLen =-141 _PromptSys_InputLen = -1 33 42 34 43 'graphic … … 38 47 Dim _PromptSys_GlobalPos As POINTAPI 39 48 40 41 _PromptSys_bInitFinish =049 CreateEvent(0, FALSE, FALSE, 0) 50 _PromptSys_bInitFinish = 0 42 51 CreateThread(0, 0, AddressOf(PromptMain) As LPTHREAD_START_ROUTINE, 0, 0, _PromptSys_dwThreadID) 43 52 Do … … 54 63 GetClientRect(_PromptSys_hWnd, rc) 55 64 While (_PromptSys_CurPos.y+1) * _PromptSys_FontSize.cy > rc.bottom and _PromptSys_CurPos.y > 0 56 _System_free(_PromptSys_Buffer[0]) 57 _System_free(_PromptSys_TextColor[0]) 58 _System_free(_PromptSys_BackColor[0]) 65 _System_free(_PromptSys_TextLine[0].Text) 66 _System_free(_PromptSys_TextLine[0].CharInfo) 59 67 For i = 0 To 100 - 1 60 _PromptSys_Buffer[i] = _PromptSys_Buffer[i+1] 61 _PromptSys_TextColor[i] = _PromptSys_TextColor[i+1] 62 _PromptSys_BackColor[i] = _PromptSys_BackColor[i+1] 63 _PromptSys_TextWidth[i] = _PromptSys_TextWidth[i+1] 68 _PromptSys_TextLine[i].Length = _PromptSys_TextLine[i+1].Length 69 _PromptSys_TextLine[i].Text = _PromptSys_TextLine[i+1].Text 70 _PromptSys_TextLine[i].CharInfo = _PromptSys_TextLine[i+1].CharInfo 64 71 Next 65 _PromptSys_Buffer[100] = _System_calloc(SizeOf (Char) * 255) 66 _PromptSys_TextColor[100] = _System_calloc(SizeOf(COLORREF) * 255) 67 _PromptSys_BackColor[100] = _System_calloc(SizeOf(COLORREF) * 255) 68 _PromptSys_TextWidth[100] = 0 69 72 _PromptSys_TextLine[100].Length = 0 73 _PromptSys_TextLine[100].Text = _System_calloc(SizeOf (Char) * 255) 74 _PromptSys_TextLine[100].CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255) 70 75 _PromptSys_CurPos.y-- 71 76 … … 74 79 Wend 75 80 76 i = 0 81 i = 0' : Debug 77 82 While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100 78 83 If StartLine=-1 or (StartLine<=i and i<=EndLine) Then 84 Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo 85 79 86 Dim sz As SIZE 80 i3 = lstrlen(_PromptSys_Buffer[i]) 81 GetTextExtentPoint32(hDC, _PromptSys_Buffer[i], i3, sz) 87 i3 = lstrlen(_PromptSys_TextLine[i].Text) '_PromptSys_TextLine[i].Length 88 If i3 <> 0 Then 89 OutputDebugString(Str$(i3) + ":" + Str$(_PromptSys_TextLine[i].Length) + Ex"\r\n") 90 End If 91 GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz) 82 92 83 93 BitBlt(hDC,_ … … 86 96 _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY) 87 97 88 Dim width = 0 As Long 89 For i2 = 0 To i3-1 90 SetTextColor(hDC, _PromptSys_TextColor[i][i2]) 91 If _PromptSys_BackColor[i][i2] = -1 Then 98 While i2 < i3 99 SetTextColor(hDC, currentLineCharInfo[i2].ForeColor) 100 If currentLineCharInfo[i2].BackColor = -1 Then 92 101 SetBkMode(hDC, TRANSPARENT) 93 102 Else 94 103 SetBkMode(hDC, OPAQUE) 95 SetBkColor(hDC, _PromptSys_BackColor[i][i2])104 SetBkColor(hDC, currentLineCharInfo[i2].BackColor) 96 105 End If 97 106 98 Dim temporary[2] As Char99 107 Dim tempLen As Long 100 temporary[0] = _PromptSys_Buffer[i][i2] 101 #ifdef UNICODE 102 If _System_IsSurrogatePair(_PromptSys_Buffer[i][i2], _PromptSys_Buffer[i][i2+1]) Then 103 #else 104 If IsDBCSLeadByte(temporary[0]) Then 105 #endif 106 temporary[1] = _PromptSys_Buffer[i][i2+1] 107 temporary[2] = 0 108 i2++ 108 If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then 109 109 tempLen = 2 110 110 Else 111 temporary[1] = 0112 111 tempLen = 1 113 112 End If 114 113 With _PromptSys_FontSize 115 TextOut(hDC, width, i * .cy, temporary, tempLen)114 TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]), tempLen) 116 115 End With 117 GetTextExtentPoint32(hDC, temporary, i3, sz) 118 width += sz.cx 119 Next 116 i2 += tempLen 117 Wend 120 118 End If 121 119 … … 129 127 EnterCriticalSection(_PromptSys_SectionOfBufferAccess) 130 128 With _PromptSys_CurPos 131 Dim StartLine As Long 132 StartLine = .y 129 Dim hdc = GetDC(_PromptSys_hWnd) 130 Dim hOldFont = SelectObject(hdc, _PromptSys_hFont) 131 Dim StartLine As Long : StartLine = .y 132 Dim bufLen = buf.Length 133 Dim doubleUnitChar = False As Boolean 133 134 'Addition 134 Dim i2 = 0 As Long, i3 As Long 135 Do 136 If buf[i2] = 9 Then 'tab 137 i3 = 8 - (.x And 7) '(.x mod 8) 138 _System_FillChar(VarPtr(_PromptSys_Buffer[.y][.x]), i3, &h20) 'Asc(" ") 139 i2++ 140 .x += i3 141 Continue 135 Dim i2 = 0 As Long, i3 As Long' : Debug 136 For i2 = 0 To ELM(bufLen) 137 If buf[i2] = &h0d Then 'CR \r 138 _PromptSys_TextLine[.y].Length = .x 139 .x = 0 140 ElseIf buf[i2] = &h0a Then 'LF \n 141 _PromptSys_TextLine[.y].Length = Math.Max(_PromptSys_TextLine[.y].Length, .x) 142 .y++ 143 Else 144 Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo As *_PromptSys_CharacterInformation 145 _PromptSys_TextLine[.y].Text[.x] = buf[i2] 146 currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor 147 currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor 148 149 If buf[i2] = &h09 Then 'tab 150 Dim tabStop = _PromptSys_FontSize.cx * 8 151 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _ 152 tabStop - currentLineCharInfo[.x].StartPos Mod tabStop 153 Else 154 If doubleUnitChar <> False Then 155 doubleUnitChar = False 156 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos 157 Else 158 Dim sz As SIZE 159 Dim charLen As Long 160 If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then 161 charLen = 2 162 doubleUnitChar = True 163 Else 164 charLen = 1 165 EndIf 166 GetTextExtentPoint32(hdc, VarPtr(buf.Chars[i2]), charLen, sz) 167 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx 168 /* 169 Dim buf[1023] As Char 170 wsprintf(buf, Ex"%d %d\r\n", currentLineCharInfo[.x + 1].StartPos, currentLineCharInfo[.x].StartPos + sz.cx) 171 OutputDebugString(buf) 172 */ 173 End If 174 End If 175 .x++ 142 176 End If 143 144 If buf[i2] = 13 and buf[i2+1] = 10 Then '\r\n 145 i2 += 2 146 .y++ 147 .x = 0 148 Continue 149 End If 150 151 If buf[i2] = 0 Then Exit Do 152 _PromptSys_Buffer[.y][.x] = buf[i2] 153 _PromptSys_TextColor[.y][.x] = _PromptSys_NowTextColor 154 _PromptSys_BackColor[.y][.x] = _PromptSys_NowBackColor 155 156 i2++ 157 .x++ 158 Loop 177 Next 178 _PromptSys_TextLine[.y].Length = Math.Max(_PromptSys_TextLine[.y].Length, .x) 159 179 160 180 'Draw the text buffer added 161 D im hDC = GetDC(_PromptSys_hWnd)162 DrawPromptBuffer(hDC, StartLine, .y)163 ReleaseDC(_PromptSys_hWnd, h DC)181 DrawPromptBuffer(hdc, StartLine, .y) 182 SelectObject(hdc, hOldFont) 183 ReleaseDC(_PromptSys_hWnd, hdc) 164 184 End With 165 185 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess) … … 167 187 168 188 Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT 169 Dim hIMC As HIMC170 Dim hDC As HDC171 Dim ps As PAINTSTRUCT172 Dim TempStr As String173 Dim CompForm As COMPOSITIONFORM174 175 189 Select Case message 176 190 Case WM_CREATE 177 hDC = GetDC(hWnd) 178 With _PromptSys_ScreenSize 179 _PromptSys_hBitmap = CreateCompatibleBitmap(hDC, .cx, .cy) 180 End With 181 _PromptSys_hMemDC = CreateCompatibleDC(hDC) 182 SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap) 183 184 'Initialize for Win9x 185 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH 186 With _PromptSys_ScreenSize 187 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY) 188 End With 189 SelectObject(_PromptSys_hMemDC, hOldBrush) 190 191 Dim tm As TEXTMETRIC 192 Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT 193 GetTextExtentPoint32(_PromptSys_hMemDC, " " As PCTSTR, 1, _PromptSys_FontSize) 194 GetTextMetrics(_PromptSys_hMemDC, tm) 195 SelectObject(_PromptSys_hMemDC, hOldFont) 196 _PromptSys_FontSize.cy = tm.tmHeight 197 198 ReleaseDC(hWnd,hDC) 191 Return _PromptWnd_OnCreate(hWnd, ByVal lParam As *CREATESTRUCT) 199 192 Case WM_PAINT 200 hDC = BeginPaint(hWnd, ps) 201 /* 202 With _PromptSys_ScreenSize 203 BitBlt(hDC, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY) 204 */ 205 With ps.rcPaint 206 BitBlt(hDC, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY) 207 End With 208 DrawPromptBuffer(hDC, -1, 0) 209 EndPaint(hWnd, ps) 210 211 _PromptSys_bInitFinish = TRUE 193 _PromptWnd_OnPaint(hWnd) 212 194 Case WM_SETFOCUS 213 If _PromptSys_InputLen<>-1 Then 214 hIMC = ImmGetContext(hWnd) 215 If hIMC Then 216 With CompForm 217 .dwStyle = CFS_POINT 218 .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx 219 .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy 220 End With 221 ImmSetCompositionWindow(hIMC, CompForm) 222 ImmSetCompositionFontA(hIMC, _PromptSys_LogFont) 223 End If 224 ImmReleaseContext(hWnd, hIMC) 225 226 CreateCaret(hWnd, NULL, 9, 6) 227 SetCaretPos(_PromptSys_CurPos.x*_PromptSys_FontSize.cx, _ 228 (_PromptSys_CurPos.y+1)*_PromptSys_FontSize.cy-7) 229 ShowCaret(hWnd) 230 End If 195 _PromptWnd_OnSetFocus(hWnd, wParam As HWND) 231 196 Case WM_KILLFOCUS 232 HideCaret(hWnd) 233 DestroyCaret() 197 _PromptWnd_OnKillForcus(hWnd, wParam As HWND) 234 198 Case WM_KEYDOWN 235 If _PromptSys_InputLen=-1 Then 236 _PromptSys_KeyChar=wParam As Byte 237 End If 199 _PromptWnd_OnKeyDown(wParam As DWord, LOWORD(lParam) As DWord, HIWORD(lParam) As DWord) 238 200 Case WM_CHAR 239 If _PromptSys_InputLen <> -1 Then 240 If wParam = VK_BACK Then 241 If _PromptSys_InputLen Then 242 _PromptSys_InputLen-- 243 _PromptSys_InputStr[_PromptSys_InputLen] = 0 244 245 _PromptSys_CurPos.x-- 246 _PromptSys_Buffer[_PromptSys_CurPos.y][_PromptSys_CurPos.x] = 0 247 End If 248 ElseIf wParam = VK_RETURN Then 249 _PromptSys_InputStr[_PromptSys_InputLen] = 0 250 _PromptSys_InputLen = -1 251 TempStr = Ex"\r\n" 252 ElseIf wParam = &H16 Then 253 'Paste Command(Use Clippboard) 254 OpenClipboard(hWnd) 255 Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL 256 If hGlobal = 0 Then Return 0 257 Dim pTemp = GlobalLock(hGlobal) As PCSTR 258 #ifdef UNICODE 'A版ウィンドウプロシージャ用 259 Dim tempSizeA = lstrlenA(pTemp) 260 Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1 261 TempStr = ZeroString(tempSizeW) 262 MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW) 263 #else 264 TempStr = ZeroString(lstrlen(pTemp) + 1) 265 lstrcpy(StrPtr(TempStr), pTemp) 266 #endif 267 memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length) 268 _PromptSys_InputLen += TempStr.Length 269 270 GlobalUnlock(hGlobal) 271 CloseClipboard() 272 Else 273 _PromptSys_InputStr[_PromptSys_InputLen] = wParam As Byte 274 _PromptSys_InputLen++ 275 276 TempStr.ReSize(1) 277 TempStr[0] = wParam As Char 278 End If 279 280 SendMessage(hWnd, WM_KILLFOCUS, 0, 0) 281 PRINT_ToPrompt(TempStr) 282 SendMessage(hWnd, WM_SETFOCUS, 0, 0) 283 End If 201 _PromptWnd_OnChar(hWnd, wParam, lParam) 284 202 Case WM_IME_COMPOSITION 285 Return _Prompt Sys_OnImeCompostion(hWnd, wParam, lParam)203 Return _PromptWnd_OnImeCompostion(hWnd, wParam, lParam) 286 204 Case WM_DESTROY 287 DeleteDC(_PromptSys_hMemDC) 288 DeleteObject(_PromptSys_hBitmap) 289 290 PostQuitMessage(0) 205 _PromptWnd_OnDestroy(hWnd) 291 206 Case Else 292 PromptProc =DefWindowProc(hWnd,message,wParam,lParam)207 PromptProc = DefWindowProc(hWnd, message, wParam, lParam) 293 208 Exit Function 294 209 End Select 295 PromptProc =0210 PromptProc = 0 296 211 End Function 297 212 298 Function _PromptSys_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT 213 Function _PromptWnd_OnCreate(hwnd As HWND, ByRef cs As CREATESTRUCT) As LRESULT 214 Dim hdc = GetDC(hwnd) 215 With _PromptSys_ScreenSize 216 _PromptSys_hBitmap = CreateCompatibleBitmap(hdc, .cx, .cy) 217 End With 218 _PromptSys_hMemDC = CreateCompatibleDC(hdc) 219 SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap) 220 221 'Initialize for Win9x 222 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH 223 With _PromptSys_ScreenSize 224 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY) 225 End With 226 SelectObject(_PromptSys_hMemDC, hOldBrush) 227 228 Dim tm As TEXTMETRIC 229 Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT 230 GetTextMetrics(_PromptSys_hMemDC, tm) 231 SelectObject(_PromptSys_hMemDC, hOldFont) 232 With _PromptSys_FontSize 233 .cx = tm.tmAveCharWidth 234 .cy = tm.tmHeight 235 End With 236 237 ReleaseDC(hwnd, hdc) 238 239 _PromptWnd_OnCreate = 0 240 End Function 241 242 Sub _PromptWnd_OnPaint(hwnd As HWND) 243 Dim ps As PAINTSTRUCT 244 Dim hdc = BeginPaint(hwnd, ps) 245 ' With _PromptSys_ScreenSize 246 ' BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY) 247 With ps.rcPaint 248 BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY) 249 End With 250 DrawPromptBuffer(hdc, -1, 0) 251 EndPaint(hwnd, ps) 252 253 _PromptSys_bInitFinish = TRUE 254 End Sub 255 256 Sub _PromptWnd_OnSetFocus(hwnd As HWND, hwndOldFocus As HWND) 257 If _PromptSys_InputLen <> -1 Then 258 Dim himc = ImmGetContext(hwnd) 259 If himc Then 260 Dim CompForm As COMPOSITIONFORM 261 With CompForm 262 .dwStyle = CFS_POINT 263 .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx 264 .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy 265 End With 266 ImmSetCompositionWindow(himc, CompForm) 267 ImmSetCompositionFontA(himc, _PromptSys_LogFont) 268 End If 269 ImmReleaseContext(hwnd, himc) 270 271 CreateCaret(hwnd, 0, 9, 6) 272 SetCaretPos(_PromptSys_CurPos.x * _PromptSys_FontSize.cx, (_PromptSys_CurPos.y + 1) * _PromptSys_FontSize.cy - 7) 273 ShowCaret(hwnd) 274 End If 275 End Sub 276 277 Sub _PromptWnd_OnKillForcus(hwnd As HWND, hwndNewFocus As HWND) 278 HideCaret(hwnd) 279 DestroyCaret() 280 End Sub 281 282 Sub _PromptWnd_OnKeyDown(vk As DWord, repeat As DWord, flags As DWord) 283 If _PromptSys_InputLen = -1 Then 284 _PromptSys_KeyChar = vk As Byte 285 End If 286 End Sub 287 288 Sub _PromptWnd_OnDestroy(hwnd As HWND) 289 DeleteDC(_PromptSys_hMemDC) 290 DeleteObject(_PromptSys_hBitmap) 291 292 PostQuitMessage(0) 293 End Sub 294 295 Sub _PromptWnd_OnChar(hwnd As HWND, wParam As WPARAM, lParam As LPARAM) 296 Dim TempStr As String 297 If _PromptSys_InputLen <> -1 Then 298 If wParam = VK_BACK Then 299 If _PromptSys_InputLen Then 300 _PromptSys_InputLen-- 301 _PromptSys_InputStr[_PromptSys_InputLen] = 0 302 303 _PromptSys_CurPos.x-- 304 With _PromptSys_CurPos 305 _PromptSys_TextLine[.y].Text[.x] = 0 306 End With 307 End If 308 ElseIf wParam = VK_RETURN Then 309 _PromptSys_InputStr[_PromptSys_InputLen] = 0 310 _PromptSys_InputLen = -1 311 TempStr = Ex"\r\n" 312 ElseIf wParam = &H16 Then 313 'Paste Command(Use Clippboard) 314 OpenClipboard(hwnd) 315 Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL 316 If hGlobal = 0 Then Exit Sub 317 Dim pTemp = GlobalLock(hGlobal) As PCSTR 318 #ifdef UNICODE 'A版ウィンドウプロシージャ用 319 Dim tempSizeA = lstrlenA(pTemp) 320 Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1 321 TempStr = ZeroString(tempSizeW) 322 MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW) 323 #else 324 TempStr = ZeroString(lstrlen(pTemp) + 1) 325 lstrcpy(StrPtr(TempStr), pTemp) 326 #endif 327 memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length) 328 _PromptSys_InputLen += TempStr.Length 329 330 GlobalUnlock(hGlobal) 331 CloseClipboard() 332 Else 333 _PromptSys_InputStr[_PromptSys_InputLen] = wParam As Byte 334 _PromptSys_InputLen++ 335 336 TempStr.ReSize(1) 337 TempStr[0] = wParam As Char 338 End If 339 340 SendMessage(hwnd, WM_KILLFOCUS, 0, 0) 341 PRINT_ToPrompt(TempStr) 342 SendMessage(hwnd, WM_SETFOCUS, 0, 0) 343 End If 344 End Sub 345 346 Function _PromptWnd_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT 299 347 If (lp And GCS_RESULTSTR) <> 0 Then 300 348 Dim himc = ImmGetContext(hwnd) … … 322 370 SendMessage(hwnd, WM_SETFOCUS, 0, 0) 323 371 324 Return0372 _PromptWnd_OnImeCompostion = 0 325 373 Else 326 ReturnDefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)374 _PromptWnd_OnImeCompostion = DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp) 327 375 End If 328 376 End Function … … 332 380 333 381 'Allocate 334 For i=0 To 100 335 _PromptSys_Buffer[i] = _System_calloc(SizeOf (Char) * 255) 336 _PromptSys_TextColor[i] = _System_calloc(SizeOf(COLORREF) * 255) 337 _PromptSys_BackColor[i] = _System_calloc(SizeOf(COLORREF) * 255) 382 For i = 0 To 100 383 With _PromptSys_TextLine[i] 384 .Length = 0 385 .Text = _System_calloc(SizeOf (Char) * 255) 386 .CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255) 387 End With 338 388 Next 339 389 340 390 'Current Colors initialize 341 _PromptSys_NowTextColor =RGB(255,255,255)342 _PromptSys_NowBackColor =RGB(0,0,0)391 _PromptSys_NowTextColor = RGB(255, 255, 255) 392 _PromptSys_NowBackColor = RGB(0, 0, 0) 343 393 344 394 'Setup … … 370 420 End With 371 421 372 _PromptSys_hFont = CreateFontIndirectA( ByVal VarPtr(_PromptSys_LogFont))422 _PromptSys_hFont = CreateFontIndirectA(_PromptSys_LogFont) 373 423 374 424 'Critical Section … … 381 431 .cbSize = Len(wcl) 382 432 .hInstance = GetModuleHandle(0) 383 .style = CS_HREDRAW or CS_VREDRAW' or CS_DBLCLKS384 .hIcon = LoadI con(NULL, MAKEINTRESOURCE(IDI_APPLICATION))385 .hIconSm = LoadI con(NULL, MAKEINTRESOURCE(IDI_WINLOGO))386 .hCursor = Load Cursor(NULL, MAKEINTRESOURCE(IDC_ARROW))433 .style = CS_HREDRAW Or CS_VREDRAW' or CS_DBLCLKS 434 .hIcon = LoadImage(0, MAKEINTRESOURCE(IDI_APPLICATION), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON 435 .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON 436 .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR 387 437 .lpszClassName = "PROMPT" 388 438 .lpfnWndProc = AddressOf(PromptProc) … … 401 451 Do 402 452 Dim iResult = GetMessage(msg, 0, 0, 0) 403 If iResult = 0 or iResult = -1 Then Exit Do453 If iResult = 0 Or iResult = -1 Then Exit Do 404 454 TranslateMessage(msg) 405 455 DispatchMessage(msg) … … 410 460 411 461 EnterCriticalSection(_PromptSys_SectionOfBufferAccess) 412 413 For i=0 to 100 414 _System_free(_PromptSys_Buffer[i]) 415 _System_free(_PromptSys_TextColor[i]) 416 _System_free(_PromptSys_BackColor[i]) 462 463 For i = 0 to 100 464 _System_free(_PromptSys_TextLine[i].Text) 465 _System_free(_PromptSys_TextLine[i].CharInfo) 417 466 Next 418 467 … … 431 480 Macro CLS()(num As Long) 432 481 Dim i As Long 433 Dim hOldBrush As HBRUSH434 482 435 483 'When parameter was omitted, num is set to 1 436 If num =0 Then num=1437 438 If num =1 or num=3 Then484 If num = 0 Then num = 1 485 486 If num = 1 Or num = 3 Then 439 487 'Clear the text screen 440 488 For i = 0 To 100 441 _System_FillChar(_PromptSys_Buffer[i],255,0) 489 With _PromptSys_TextLine[i] 490 .Text[0] = 0 '_System_FillChar(_PromptSys_TextLine[i].Text, -1 As Char, 0) 491 .Length = 0 492 End With 442 493 Next 443 494 With _PromptSys_CurPos … … 447 498 End If 448 499 449 If num =2 or num=3 Then500 If num = 2 Or num = 3 Then 450 501 'Clear the graphics screen 451 hOldBrush=SelectObject(_PromptSys_hMemDC,GetStockObject(BLACK_BRUSH)) 452 PatBlt(_PromptSys_hMemDC,0,0,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy,PATCOPY) 453 SelectObject(_PromptSys_hMemDC,hOldBrush) 502 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) 503 With _PromptSys_ScreenSize 504 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY) 505 End With 506 SelectObject(_PromptSys_hMemDC, hOldBrush) 454 507 End If 455 508 456 509 'Redraw 457 InvalidateRect(_PromptSys_hWnd, ByVal 0,0)510 InvalidateRect(_PromptSys_hWnd, ByVal 0, 0) 458 511 End Macro 459 512 460 513 Macro COLOR(TextColorCode As Long)(BackColorCode As Long) 461 _PromptSys_NowTextColor =GetBasicColor(TextColorCode)462 If BackColorCode =-1 Then463 _PromptSys_NowBackColor =-1514 _PromptSys_NowTextColor = GetBasicColor(TextColorCode) 515 If BackColorCode = -1 Then 516 _PromptSys_NowBackColor = -1 464 517 Else 465 _PromptSys_NowBackColor =GetBasicColor(BackColorCode)518 _PromptSys_NowBackColor = GetBasicColor(BackColorCode) 466 519 End If 467 520 End Macro … … 480 533 481 534 'Input by keyboard 482 _PromptSys_InputLen =0483 SendMessage(_PromptSys_hWnd, WM_SETFOCUS,0,0)484 While _PromptSys_InputLen <>-1535 _PromptSys_InputLen = 0 536 SendMessage(_PromptSys_hWnd, WM_SETFOCUS, 0, 0) 537 While _PromptSys_InputLen <> -1 485 538 Sleep(10) 486 539 Wend 487 SendMessage(_PromptSys_hWnd, WM_KILLFOCUS,0,0)540 SendMessage(_PromptSys_hWnd, WM_KILLFOCUS, 0, 0) 488 541 489 542 'Set value to variable … … 510 563 511 564 i++ 512 If _System_InputDataPtr[i] =0 and _PromptSys_InputStr[i2]=&h2c Then 'Asc(",")565 If _System_InputDataPtr[i] = 0 and _PromptSys_InputStr[i2] = &h2c Then 'Asc(",") 513 566 PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n") 514 567 Goto *InputReStart 515 ElseIf _PromptSys_InputStr[i2] =0 Then568 ElseIf _PromptSys_InputStr[i2] = 0 Then 516 569 If _System_InputDataPtr[i]<>0 Then 517 570 PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n") … … 531 584 532 585 Macro LOCATE(x As Long, y As Long) 533 Dim i As Long, i2 As Long 534 535 If x<0 Then x=0 536 If y<0 Then y=0 537 If y>100 Then y=100 586 If x < 0 Then x = 0 587 If y < 0 Then y = 0 588 If y > 100 Then y = 100 538 589 With _PromptSys_CurPos 539 590 .x = x 540 591 .y = y 541 592 End With 542 i=0 543 While _PromptSys_Buffer[y][i] 544 i++ 545 Wend 546 593 594 Dim i = _PromptSys_TextLine[y].Length 547 595 If i < x Then 548 _System_FillChar(VarPtr(_PromptSys_Buffer[y][i]), x - i, &h20) 'Asc(" ") 549 For i2 = i To x - 1 550 _PromptSys_BackColor[y][i2] = -1 596 _System_FillChar(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20) 'Asc(" ") 597 Dim i2 As Long 598 For i2 = i To ELM(x) 599 _PromptSys_TextLine[y].CharInfo[i2].BackColor = -1 551 600 Next 601 _PromptSys_TextLine[y].Length = x 552 602 End If 553 603 End Macro … … 562 612 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2] 563 613 614 Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long 615 616 Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode)) 564 617 Dim hBrush As HBRUSH 618 If bFill Then 619 hBrush = CreateSolidBrush(GetBasicColor(BrushColor)) 620 Else 621 hBrush = GetStockObject(NULL_BRUSH) 622 End If 623 624 Dim hDC = GetDC(_PromptSys_hWnd) 625 Dim hOldPenDC = SelectObject(hDC, hPen) 626 Dim hOldBrushDC = SelectObject(hDC, hBrush) 627 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen) 628 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush) 629 565 630 Dim radi2 As Long 566 Dim sw As Long567 Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long568 569 Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))570 If bFill Then571 hBrush=CreateSolidBrush(GetBasicColor(BrushColor))572 Else573 hBrush=GetStockObject(NULL_BRUSH)574 End If575 576 Dim hDC=GetDC(_PromptSys_hWnd)577 SelectObject(hDC,hPen)578 SelectObject(hDC,hBrush)579 Dim hOldPen=SelectObject(_PromptSys_hMemDC,hPen)580 Dim hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)581 582 631 If Aspect<1 Then 583 632 radi2=(CDbl(radius)*Aspect) As Long … … 591 640 Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2) 592 641 Else 642 Dim sw As Long 593 643 StartPos *=StartPos 594 644 EndPos *=EndPos … … 654 704 End If 655 705 656 ReleaseDC(_PromptSys_hWnd,hDC) 657 SelectObject(_PromptSys_hMemDC,hOldPen) 658 SelectObject(_PromptSys_hMemDC,hOldBrush) 706 SelectObject(hDC, hOldPenDC) 707 SelectObject(hDC, hOldBrushDC) 708 ReleaseDC(_PromptSys_hWnd, hDC) 709 SelectObject(_PromptSys_hMemDC, hOldPen) 710 SelectObject(_PromptSys_hMemDC, hOldBrush) 659 711 DeleteObject(hPen) 660 712 If bFill Then DeleteObject(hBrush) … … 666 718 Dim temp As Long 667 719 668 If sx=&H80000000 And sy=&H80000000 Then 669 sx=_PromptSys_GlobalPos.x 670 sy=_PromptSys_GlobalPos.y 720 If sx = &H80000000 And sy = &H80000000 Then 721 With _PromptSys_GlobalPos 722 sx = .x 723 sy = .y 724 End With 671 725 End If 672 726 … … 694 748 Dim hBrush As HBRUSH 695 749 If fType=2 Then 696 hBrush =CreateSolidBrush(GetBasicColor(BrushColor))750 hBrush = CreateSolidBrush(GetBasicColor(BrushColor)) 697 751 Else 698 hBrush =GetStockObject(NULL_BRUSH)699 End If 700 701 SelectObject(hDC, hPen)702 SelectObject(hDC, hBrush)703 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)704 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)752 hBrush = GetStockObject(NULL_BRUSH) 753 End If 754 755 SelectObject(hDC, hPen) 756 SelectObject(hDC, hBrush) 757 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen) 758 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush) 705 759 706 760 Select Case fType … … 723 777 SelectObject(_PromptSys_hMemDC,hOldBrush) 724 778 DeleteObject(hPen) 725 If fType=2 Then DeleteObject(hBrush) 726 727 _PromptSys_GlobalPos.x=ex 728 _PromptSys_GlobalPos.y=ey 779 If fType = 2 Then DeleteObject(hBrush) 780 With _PromptSys_GlobalPos 781 .x = ex 782 .y = ey 783 End With 729 784 End Macro 730 785 … … 733 788 'PSet (x,y),ColorCode 734 789 735 Dim hDC=GetDC(_PromptSys_hWnd) 736 SetPixel(hDC,x,y,GetBasicColor(ColorCode)) 737 SetPixel(_PromptSys_hMemDC,x,y,GetBasicColor(ColorCode)) 738 ReleaseDC(_PromptSys_hWnd,hDC) 739 740 _PromptSys_GlobalPos.x=x 741 _PromptSys_GlobalPos.y=y 790 Dim hDC = GetDC(_PromptSys_hWnd) 791 SetPixel(hDC, x, y, GetBasicColor(ColorCode)) 792 SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode)) 793 ReleaseDC(_PromptSys_hWnd, hDC) 794 With _PromptSys_GlobalPos 795 .x = x 796 .y = y 797 End With 742 798 End Macro 743 799 … … 746 802 'Paint (x,y),BrushColor,LineColor 747 803 748 Dim hDC As HDC 749 Dim hBrush As HBRUSH, hOldBrush As VoidPtr 750 751 hBrush=CreateSolidBrush(GetBasicColor(BrushColor)) 752 753 hDC=GetDC(_PromptSys_hWnd) 754 SelectObject(hDC,hBrush) 755 hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush) 756 757 ExtFloodFill(hDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER) 758 ExtFloodFill(_PromptSys_hMemDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER) 759 760 ReleaseDC(_PromptSys_hWnd,hDC) 761 SelectObject(_PromptSys_hMemDC,hOldBrush) 804 Dim hBrush = CreateSolidBrush(GetBasicColor(BrushColor)) 805 806 Dim hDC = GetDC(_PromptSys_hWnd) 807 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush) 808 Dim hOldBrushWndDC = SelectObject(hDC, hBrush) 809 810 ExtFloodFill(hDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER) 811 ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER) 812 813 ReleaseDC(_PromptSys_hWnd, hDC) 814 SelectObject(_PromptSys_hMemDC, hOldBrush) 815 SelectObject(hDC, hOldBrushWndDC) 762 816 DeleteObject(hBrush) 763 817 End Macro … … 791 845 _PromptSys_KeyChar=0 792 846 i++ 793 If i >=length Then847 If i >= length Then 794 848 Exit While 795 849 End If
Note:
See TracChangeset
for help on using the changeset viewer.
