source: trunk/Include/basic/prompt.sbp@ 301

Last change on this file since 301 was 288, checked in by dai, 17 years ago

いくつかタイプミスを修正。
エラーになるコードを排除、
enumクラスのビット演算メソッドをコメントアウト(仕様未確定なため)。

File size: 27.3 KB
Line 
1'prompt.sbp
2
3
4#ifndef _INC_PROMPT
5#define _INC_PROMPT
6
7#require <api_imm.sbp>
8#require <Classes/System/Math.ab>
9#require <Classes/System/Environment.ab>
10
11Namespace ActiveBasic
12Namespace Prompt
13Namespace Detail
14
15Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCSTR, cb As Long, ByRef Size As SIZE) As Long
16 _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32A(hdc, psz, cb, Size)
17End Function
18
19Function _PromptSys_GetTextExtentPoint32(hdc As HDC, psz As PCWSTR, cb As Long, ByRef Size As SIZE) As Long
20 _PromptSys_GetTextExtentPoint32 = GetTextExtentPoint32W(hdc, psz, cb, Size)
21End Function
22
23Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCSTR, cb As Long) As Long
24 _PromptSys_TextOut = TextOutA(hdc, x, y, psz, cb)
25End Function
26
27Function _PromptSys_TextOut(hdc As HDC, x As Long, y As Long, psz As PCWSTR, cb As Long) As Long
28 _PromptSys_TextOut = TextOutW(hdc, x, y, psz, cb)
29End Function
30
31Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PSTR, bufLen As DWord) As Long
32 _PromptSys_ImmGetCompositionString = ImmGetCompositionStringA(himc, index, pBuf, bufLen)
33End Function
34
35Function _PromptSys_ImmGetCompositionString(himc As HIMC, index As DWord, pBuf As PWSTR, bufLen As DWord) As Long
36 _PromptSys_ImmGetCompositionString = ImmGetCompositionStringW(himc, index, pBuf, bufLen)
37End Function
38
39Dim _PromptSys_hWnd As HWND
40Dim _PromptSys_dwThreadID As DWord
41Dim _PromptSys_hInitFinish As HANDLE
42
43'text
44Type _PromptSys_CharacterInformation
45 ForeColor As COLORREF
46 BackColor As COLORREF
47 StartPos As Long
48End Type
49
50Type _PromptSys_LineInformation
51 Length As Long
52 Text As *StrChar
53 CharInfo As *_PromptSys_CharacterInformation
54End Type
55
56Dim _PromptSys_hFont As HFONT
57Dim _PromptSys_FontSize As SIZE
58Dim _PromptSys_InputStr[255] As StrChar
59Dim _PromptSys_InputLen = -1 As Long
60Dim _PromptSys_KeyChar As Byte
61Dim _PromptSys_CurPos As POINTAPI
62Dim _PromptSys_TextLine[100] As _PromptSys_LineInformation
63Dim _PromptSys_NowTextColor As COLORREF
64Dim _PromptSys_NowBackColor As COLORREF
65Dim _PromptSys_SectionOfBufferAccess As CRITICAL_SECTION
66
67Dim _System_OSVersionInfo As OSVERSIONINFO
68
69
70'graphic
71Dim _PromptSys_hBitmap As HBITMAP
72Dim _PromptSys_hMemDC As HDC
73Dim _PromptSys_ScreenSize As SIZE
74Dim _PromptSys_GlobalPos As POINTAPI
75
76Sub _PromptSys_Initialize()
77 _PromptSys_hInitFinish = CreateEvent(0, FALSE, FALSE, 0)
78 Dim _PromptSys_hThread = CreateThread(0, 0, AddressOf(PromptMain), 0, 0, _PromptSys_dwThreadID)
79 If _PromptSys_hThread = 0 Then
80 Debug
81 ExitProcess(1)
82 End If
83 WaitForSingleObject(_PromptSys_hInitFinish, INFINITE)
84End Sub
85
86Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
87 Dim i As Long, i2 As Long, i3 As Long
88
89 Dim hOldFont = SelectObject(hDC, _PromptSys_hFont) As HFONT
90
91 'Scroll
92 Dim rc As RECT
93 GetClientRect(_PromptSys_hWnd, rc)
94 While (_PromptSys_CurPos.y+1) * _PromptSys_FontSize.cy > rc.bottom and _PromptSys_CurPos.y > 0
95 _System_free(_PromptSys_TextLine[0].Text)
96 _System_free(_PromptSys_TextLine[0].CharInfo)
97 For i = 0 To 100 - 1
98 _PromptSys_TextLine[i].Length = _PromptSys_TextLine[i+1].Length
99 _PromptSys_TextLine[i].Text = _PromptSys_TextLine[i+1].Text
100 _PromptSys_TextLine[i].CharInfo = _PromptSys_TextLine[i+1].CharInfo
101 Next
102 _PromptSys_TextLine[100].Length = 0
103 _PromptSys_TextLine[100].Text = _System_calloc(SizeOf (StrChar) * 255)
104 _PromptSys_TextLine[100].CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
105 _PromptSys_CurPos.y--
106
107 'Redraw
108 StartLine = -1
109 Wend
110
111 i = 0' : Debug
112 While i * _PromptSys_FontSize.cy < rc.bottom and i <= 100
113 If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
114 Dim currentLineCharInfo = _PromptSys_TextLine[i].CharInfo
115
116 Dim sz As SIZE
117 i3 = _PromptSys_TextLine[i].Length
118 _PromptSys_GetTextExtentPoint32(hDC, _PromptSys_TextLine[i].Text, i3, sz)
119
120 BitBlt(hDC,_
121 sz.cx, i * _PromptSys_FontSize.cy, _
122 rc.right, _PromptSys_FontSize.cy, _
123 _PromptSys_hMemDC, sz.cx, i * _PromptSys_FontSize.cy, SRCCOPY)
124
125 While i2 < i3
126 SetTextColor(hDC, currentLineCharInfo[i2].ForeColor)
127 If currentLineCharInfo[i2].BackColor = -1 Then
128 SetBkMode(hDC, TRANSPARENT)
129 Else
130 SetBkMode(hDC, OPAQUE)
131 SetBkColor(hDC, currentLineCharInfo[i2].BackColor)
132 End If
133
134 Dim tempLen As Long
135 If _System_IsDoubleUnitChar(_PromptSys_TextLine[i].Text[i2], _PromptSys_TextLine[i].Text[i2+1]) Then
136 tempLen = 2
137 Else
138 tempLen = 1
139 End If
140 With _PromptSys_FontSize
141 _PromptSys_TextOut(hDC, currentLineCharInfo[i2].StartPos, i * .cy, VarPtr(_PromptSys_TextLine[i].Text[i2]) As *StrChar, tempLen)
142 End With
143 i2 += tempLen
144 Wend
145 End If
146
147 i++
148 Wend
149
150 SelectObject(hDC, hOldFont)
151End Sub
152
153Sub PRINT_ToPrompt(buf As String)
154 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
155 With _PromptSys_CurPos
156 Dim hdc = GetDC(_PromptSys_hWnd)
157 Dim hOldFont = SelectObject(hdc, _PromptSys_hFont)
158 Dim StartLine As Long : StartLine = .y
159 Dim bufLen = buf.Length
160 Dim doubleUnitChar = False As Boolean
161 'Addition
162 Dim i2 = 0 As Long, i3 As Long
163 For i2 = 0 To ELM(bufLen)
164 If buf[i2] = &h0d Then 'CR \r
165 _PromptSys_TextLine[.y].Length = .x
166 .x = 0
167 ElseIf buf[i2] = &h0a Then 'LF \n
168 _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
169 .y++
170 Else
171 Dim currentLineCharInfo = _PromptSys_TextLine[.y].CharInfo
172 _PromptSys_TextLine[.y].Text[.x] = buf[i2]
173 currentLineCharInfo[.x].ForeColor = _PromptSys_NowTextColor
174 currentLineCharInfo[.x].BackColor = _PromptSys_NowBackColor
175
176 If buf[i2] = &h09 Then 'tab
177 Dim tabStop = _PromptSys_FontSize.cx * 8
178 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + _
179 tabStop - currentLineCharInfo[.x].StartPos Mod tabStop
180 Else
181 If doubleUnitChar <> False Then
182 doubleUnitChar = False
183 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos
184 Else
185 Dim sz As SIZE
186 Dim charLen As Long
187 If _System_IsDoubleUnitChar(buf[i2], buf[i2 + 1]) Then
188 charLen = 2
189 doubleUnitChar = True
190 Else
191 charLen = 1
192 EndIf
193 Dim p = buf.StrPtr
194 _PromptSys_GetTextExtentPoint32(hdc, VarPtr(p[i2]) As *StrChar, charLen, sz)
195 currentLineCharInfo[.x + 1].StartPos = currentLineCharInfo[.x].StartPos + sz.cx
196/*
197 Dim buf[1023] As Char
198 wsprintf(buf, Ex"%d %d\r\n", currentLineCharInfo[.x + 1].StartPos, currentLineCharInfo[.x].StartPos + sz.cx)
199 OutputDebugString(buf)
200*/
201 End If
202 End If
203 .x++
204 End If
205 Next
206 _PromptSys_TextLine[.y].Length = System.Math.Max(_PromptSys_TextLine[.y].Length, .x)
207
208 'Draw the text buffer added
209 DrawPromptBuffer(hdc, StartLine, .y)
210 SelectObject(hdc, hOldFont)
211 ReleaseDC(_PromptSys_hWnd, hdc)
212 End With
213 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
214End Sub
215
216Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT
217 Select Case message
218 Case WM_CREATE
219 Return _PromptWnd_OnCreate(hWnd, ByVal lParam As *CREATESTRUCT)
220 Case WM_PAINT
221 _PromptWnd_OnPaint(hWnd)
222 Case WM_SETFOCUS
223 _PromptWnd_OnSetFocus(hWnd, wParam As HWND)
224 Case WM_KILLFOCUS
225 _PromptWnd_OnKillForcus(hWnd, wParam As HWND)
226 Case WM_KEYDOWN
227 _PromptWnd_OnKeyDown(wParam As DWord, LOWORD(lParam) As DWord, HIWORD(lParam) As DWord)
228 Case WM_CHAR
229 _PromptWnd_OnChar(hWnd, wParam, lParam)
230 Case WM_IME_COMPOSITION
231 Return _PromptWnd_OnImeCompostion(hWnd, wParam, lParam)
232 Case WM_DESTROY
233 _PromptWnd_OnDestroy(hWnd)
234 Case Else
235 PromptProc = DefWindowProc(hWnd, message, wParam, lParam)
236 Exit Function
237 End Select
238 PromptProc = 0
239End Function
240
241Function _PromptWnd_OnCreate(hwnd As HWND, ByRef cs As CREATESTRUCT) As LRESULT
242 Dim hdc = GetDC(hwnd)
243 With _PromptSys_ScreenSize
244 _PromptSys_hBitmap = CreateCompatibleBitmap(hdc, .cx, .cy)
245 End With
246 _PromptSys_hMemDC = CreateCompatibleDC(hdc)
247 SelectObject(_PromptSys_hMemDC, _PromptSys_hBitmap)
248
249 'Initialize for Win9x
250 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH)) As HBRUSH
251 With _PromptSys_ScreenSize
252 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
253 End With
254 SelectObject(_PromptSys_hMemDC, hOldBrush)
255
256 Dim tm As TEXTMETRIC
257 Dim hOldFont = SelectObject(_PromptSys_hMemDC, _PromptSys_hFont) As HFONT
258 GetTextMetrics(_PromptSys_hMemDC, tm)
259 SelectObject(_PromptSys_hMemDC, hOldFont)
260 With _PromptSys_FontSize
261 .cx = tm.tmAveCharWidth
262 .cy = tm.tmHeight
263 End With
264
265 ReleaseDC(hwnd, hdc)
266
267 _PromptWnd_OnCreate = 0
268End Function
269
270Sub _PromptWnd_OnPaint(hwnd As HWND)
271 Dim ps As PAINTSTRUCT
272 Dim hdc = BeginPaint(hwnd, ps)
273 With _PromptSys_ScreenSize
274 BitBlt(hdc, 0, 0, .cx, .cy, _PromptSys_hMemDC, 0, 0, SRCCOPY)
275' With ps.rcPaint
276' BitBlt(hdc, .left, .top, .right - .left, .bottom - .top, _PromptSys_hMemDC, .left, .top, SRCCOPY)
277 End With
278 DrawPromptBuffer(hdc, -1, 0)
279 EndPaint(hwnd, ps)
280End Sub
281
282Sub _PromptWnd_OnSetFocus(hwnd As HWND, hwndOldFocus As HWND)
283 If _PromptSys_InputLen <> -1 Then
284 Dim himc = ImmGetContext(hwnd)
285 If himc Then
286 Dim CompForm As COMPOSITIONFORM
287 With CompForm
288 .dwStyle = CFS_POINT
289 .ptCurrentPos.x = _PromptSys_CurPos.x * _PromptSys_FontSize.cx
290 .ptCurrentPos.y = _PromptSys_CurPos.y * _PromptSys_FontSize.cy
291 End With
292 ImmSetCompositionWindow(himc, CompForm)
293
294 Dim lf As LOGFONT
295 GetObject(_PromptSys_hFont, Len(lf), lf)
296 ImmSetCompositionFont(himc, lf)
297 End If
298 ImmReleaseContext(hwnd, himc)
299
300 CreateCaret(hwnd, 0, 9, 6)
301 With _PromptSys_CurPos
302 SetCaretPos(_PromptSys_TextLine[.y].CharInfo[.x].StartPos, (.y + 1) * _PromptSys_FontSize.cy - 7)
303 End With
304 ShowCaret(hwnd)
305 End If
306End Sub
307
308Sub _PromptWnd_OnKillForcus(hwnd As HWND, hwndNewFocus As HWND)
309 HideCaret(hwnd)
310 DestroyCaret()
311End Sub
312
313Sub _PromptWnd_OnKeyDown(vk As DWord, repeat As DWord, flags As DWord)
314 If _PromptSys_InputLen = -1 Then
315 _PromptSys_KeyChar = vk As Byte
316 End If
317End Sub
318
319Sub _PromptWnd_OnDestroy(hwnd As HWND)
320 DeleteDC(_PromptSys_hMemDC)
321 DeleteObject(_PromptSys_hBitmap)
322
323 PostQuitMessage(0)
324End Sub
325
326Sub _PromptWnd_OnChar(hwnd As HWND, wParam As WPARAM, lParam As LPARAM)
327 Dim TempStr As String
328 If _PromptSys_InputLen <> -1 Then
329 If wParam = VK_BACK Then
330 If _PromptSys_InputLen Then
331 _PromptSys_InputLen--
332 _PromptSys_InputStr[_PromptSys_InputLen] = 0
333
334 _PromptSys_CurPos.x--
335 With _PromptSys_CurPos
336 _PromptSys_TextLine[.y].Text[.x] = 0
337 End With
338 End If
339 ElseIf wParam = VK_RETURN Then
340 _PromptSys_InputStr[_PromptSys_InputLen] = 0
341 _PromptSys_InputLen = -1
342 TempStr = Ex"\r\n"
343 ElseIf wParam = &H16 Then
344/*
345 'Paste Command(Use Clippboard)
346 OpenClipboard(hwnd)
347 Dim hGlobal = GetClipboardData(CF_TEXT) As HGLOBAL
348 If hGlobal = 0 Then Exit Sub
349 Dim pTemp = GlobalLock(hGlobal) As PCSTR
350#ifdef UNICODE 'A版ウィンドウプロシージャ用
351 Dim tempSizeA = lstrlenA(pTemp)
352 Dim tempSizeW = MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, 0, 0) + 1
353 TempStr = ZeroString(tempSizeW)
354 MultiByteToWideChar(CP_ACP, 0, pTemp, tempSizeA, StrPtr(TempStr), tempSizeW)
355#else
356 TempStr = ZeroString(lstrlen(pTemp) + 1)
357 lstrcpy(StrPtr(TempStr), pTemp)
358#endif
359 memcpy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), TempStr.Chars, SizeOf (Char) * TempStr.Length)
360 _PromptSys_InputLen += TempStr.Length
361
362 GlobalUnlock(hGlobal)
363 CloseClipboard()
364*/
365 Else
366 Dim t = wParam As TCHAR
367 TempStr = New String(VarPtr(t), 1)
368 _PromptSys_InputStr[_PromptSys_InputLen] = TempStr[0]
369 _PromptSys_InputLen++
370 End If
371
372 SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
373 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(TempStr)
374 SendMessage(hwnd, WM_SETFOCUS, 0, 0)
375 End If
376End Sub
377
378Function _PromptWnd_GetCompositionStringW(himc As HIMC, ByRef rpsz As PWSTR) As Long
379 Dim size = ImmGetCompositionStringW(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
380 rpsz = _System_malloc(size) As PWSTR
381 If rpsz = 0 Then
382 'Debug
383 Return 0
384 End If
385 Return ImmGetCompositionStringW(himc, GCS_RESULTSTR, rpsz, size)
386End Function
387
388Function _PromptWnd_GetCompositionStringA(himc As HIMC, ByRef rpsz As PSTR) As Long
389 Dim size = ImmGetCompositionStringA(himc, GCS_RESULTSTR, 0, 0) 'sizeはバイト単位
390 rpsz = _System_malloc(size) As PSTR
391 If rpsz = 0 Then
392 'Debug
393 Return 0
394 End If
395 Return ImmGetCompositionStringA(himc, GCS_RESULTSTR, rpsz, size)
396End Function
397
398Function _PromptWnd_OnImeCompostion(hwnd As HWND, wp As WPARAM, lp As LPARAM) As LRESULT
399 If (lp And GCS_RESULTSTR) <> 0 Then
400 Dim himc = ImmGetContext(hwnd)
401 If himc = 0 Then
402 'Debug
403 Return 0
404 End If
405 Dim tempStr = Nothing As String
406 Dim str As *StrChar
407#ifdef __STRING_IS_NOT_UNICODE
408 Dim size = _PromptWnd_GetCompositionStringA(himc, str)
409 tempStr = New String(str, size As Long)
410#else
411 Dim osver = System.Environment.OSVersion
412 With osver
413 ' GetCompositionStringW is not implimented in Windows 95
414 If .Version.Major = 4 And .Version.Minor = 0 And .Platform = System.PlatformID.Win32Windows Then
415 Dim strA As PCSTR
416 Dim sizeA = _PromptWnd_GetCompositionStringA(himc, strA)
417 tempStr = New String(strA, sizeA As Long)
418 Else
419 Dim size = _PromptWnd_GetCompositionStringW(himc, str)
420 tempStr = New String(str, (size \ SizeOf (WCHAR)) As Long)
421 End If
422 End With
423#endif
424 ImmReleaseContext(hwnd, himc)
425 _System_free(str)
426
427 ActiveBasic.Strings.ChrCopy(VarPtr(_PromptSys_InputStr[_PromptSys_InputLen]), tempStr.StrPtr, tempStr.Length As SIZE_T)
428 _PromptSys_InputLen += tempStr.Length
429
430 SendMessage(hwnd, WM_KILLFOCUS, 0, 0)
431 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(tempStr)
432 SendMessage(hwnd, WM_SETFOCUS, 0, 0)
433
434 _PromptWnd_OnImeCompostion = 0
435 Else
436 _PromptWnd_OnImeCompostion = DefWindowProc(hwnd, WM_IME_COMPOSITION, wp, lp)
437 End If
438End Function
439
440Function PromptMain(dwData As Long) As Long
441 GetVersionEx(_System_OSVersionInfo)
442
443 Dim i As Long
444 'Allocate
445 For i = 0 To 100
446 With _PromptSys_TextLine[i]
447 .Length = 0
448 .Text = _System_calloc(SizeOf (StrChar) * 255)
449 .CharInfo = _System_calloc(SizeOf (_PromptSys_CharacterInformation) * 255)
450 End With
451 Next
452
453 'Current Colors initialize
454 _PromptSys_NowTextColor = RGB(255, 255, 255)
455 _PromptSys_NowBackColor = RGB(0, 0, 0)
456
457 'Setup
458 With _PromptSys_ScreenSize
459 .cx = GetSystemMetrics(SM_CXSCREEN)
460 .cy = GetSystemMetrics(SM_CYSCREEN)
461 End With
462
463 '_PromptSys_hFont initialize
464 Dim lf As LOGFONT
465 With lf
466 .lfHeight = -16
467 .lfWidth = 0
468 .lfEscapement = 0
469 .lfOrientation = 0
470 .lfWeight = 0
471 .lfItalic = 0
472 .lfUnderline = 0
473 .lfStrikeOut = 0
474 .lfCharSet = SHIFTJIS_CHARSET
475 .lfOutPrecision = OUT_DEFAULT_PRECIS
476 .lfClipPrecision = CLIP_DEFAULT_PRECIS
477 .lfQuality = DEFAULT_QUALITY
478 .lfPitchAndFamily = FIXED_PITCH
479 lstrcpy(.lfFaceName, ToTCStr("MS 明朝"))
480 End With
481
482 _PromptSys_hFont = CreateFontIndirect(lf)
483
484 'Critical Section
485 InitializeCriticalSection(_PromptSys_SectionOfBufferAccess)
486
487 'Regist Prompt Class
488 Dim wcl As WNDCLASSEX
489 ZeroMemory(VarPtr(wcl), Len(wcl))
490 With wcl
491 .cbSize = Len(wcl)
492 .hInstance = GetModuleHandle(0)
493 .style = CS_HREDRAW Or CS_VREDRAW' or CS_DBLCLKS
494 .hIcon = LoadImage(0, MAKEINTRESOURCE(IDI_APPLICATION), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
495 .hIconSm = LoadImage(0, MAKEINTRESOURCE(IDI_WINLOGO), IMAGE_ICON, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HICON
496 .hCursor = LoadImage(0, MAKEINTRESOURCE(IDC_ARROW), IMAGE_CURSOR, 0, 0, LR_DEFAULTSIZE Or LR_SHARED) As HCURSOR
497 .lpszClassName = ToTCStr("PROMPT")
498 .lpfnWndProc = AddressOf(PromptProc)
499 .hbrBackground = GetStockObject(BLACK_BRUSH)
500 End With
501 Dim atom = RegisterClassEx(wcl)
502
503 'Create Prompt Window
504 _PromptSys_hWnd = CreateWindowEx(WS_EX_CLIENTEDGE, atom As ULONG_PTR As LPCTSTR, ToTCStr("BASIC PROMPT"), _
505 WS_OVERLAPPEDWINDOW, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, CW_USEDEFAULT, _
506 0, 0, wcl.hInstance, 0)
507 ShowWindow(_PromptSys_hWnd, SW_SHOW)
508 UpdateWindow(_PromptSys_hWnd)
509 SetEvent(_PromptSys_hInitFinish)
510 Dim msg As MSG
511 Do
512 Dim iResult = GetMessage(msg, 0, 0, 0)
513 If iResult = 0 Then
514 System.Environment.ExitCode = msg.wParam As Long
515 Exit Do
516 ElseIf iResult = -1 Then
517 Exit Do
518 End If
519 TranslateMessage(msg)
520 DispatchMessage(msg)
521 Loop
522
523 '強制的に終了する
524 End
525
526 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
527
528 For i = 0 to 100
529 _System_free(_PromptSys_TextLine[i].Text)
530 _System_free(_PromptSys_TextLine[i].CharInfo)
531 Next
532
533 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
534
535 DeleteCriticalSection(_PromptSys_SectionOfBufferAccess)
536
537 End
538End Function
539
540'Prompt text command functoins
541
542Sub Cls(n As Long)
543 Dim i As Long
544
545 'When parameter was omitted, num is set to 1
546 If n = 0 Then n = 1
547
548 If n = 1 Or n = 3 Then
549 'Clear the text screen
550 For i = 0 To 100
551 With _PromptSys_TextLine[i]
552 .Text[0] = 0 '_System_FillChar(_PromptSys_TextLine[i].Text, -1 As StrChar, 0)
553 .Length = 0
554 End With
555 Next
556 With _PromptSys_CurPos
557 .x = 0
558 .y = 0
559 End With
560 End If
561
562 If n = 2 Or n = 3 Then
563 'Clear the graphics screen
564 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, GetStockObject(BLACK_BRUSH))
565 With _PromptSys_ScreenSize
566 PatBlt(_PromptSys_hMemDC, 0, 0, .cx, .cy, PATCOPY)
567 End With
568 SelectObject(_PromptSys_hMemDC, hOldBrush)
569 End If
570
571 'Redraw
572 InvalidateRect(_PromptSys_hWnd, ByVal 0, 0)
573End Sub
574
575Sub Color(textColorCode As Long, backColorCode As Long)
576 _PromptSys_NowTextColor = GetBasicColor(textColorCode)
577 If backColorCode = -1 Then
578 _PromptSys_NowBackColor = -1
579 Else
580 _PromptSys_NowBackColor = GetBasicColor(backColorCode)
581 End If
582End Sub
583
584Sub INPUT_FromPrompt(showStr As String)
585*InputReStart
586
587 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(showStr)
588
589 'Input by keyboard
590 _PromptSys_InputLen = 0
591 SendMessage(_PromptSys_hWnd, WM_SETFOCUS, 0, 0)
592 While _PromptSys_InputLen <> -1
593 Sleep(10)
594 Wend
595 SendMessage(_PromptSys_hWnd, WM_KILLFOCUS, 0, 0)
596
597 'Set value to variable
598 Const comma = &h2c As StrChar 'Asc(",")
599 Dim broken = ActiveBasic.Strings.Detail.Split(New String(_PromptSys_InputStr), comma)
600 Dim i As Long
601 For i = 0 To ELM(broken.Count)
602 If _System_InputDataPtr[i] = 0 Then
603 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
604 Goto *InputReStart
605 End If
606 _System_Input_SetArgument(_System_InputDataPtr[i], _System_InputDataType[i], broken[i].ToString)
607 Next
608
609 If _System_InputDataPtr[i]<>0 Then
610 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
611 Goto *InputReStart
612 End If
613End Sub
614
615Sub Locate(x As Long, y As Long)
616 If x < 0 Then x = 0
617 If y < 0 Then y = 0
618 If y > 100 Then y = 100
619 With _PromptSys_CurPos
620 .x = x
621 .y = y
622 End With
623
624 Dim i = _PromptSys_TextLine[y].Length
625 If i < x Then
626 _System_FillChar(VarPtr(_PromptSys_TextLine[y].Text[i]), x - i, &h20 As StrChar) 'Asc(" ")
627 Dim i2 As Long
628 For i2 = i To ELM(x)
629 _PromptSys_TextLine[y].CharInfo[i2].BackColor = -1
630 Next
631 _PromptSys_TextLine[y].Length = x
632 End If
633End Sub
634
635'Prompt graphic command functions
636
637Sub Circle(x As Long , y As Long, radius As Long, ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
638 Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
639
640 Dim hPen = CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
641 Dim hBrush As HBRUSH
642 If bFill Then
643 hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
644 Else
645 hBrush = GetStockObject(NULL_BRUSH)
646 End If
647
648 Dim hDC = GetDC(_PromptSys_hWnd)
649 Dim hOldPenDC = SelectObject(hDC, hPen)
650 Dim hOldBrushDC = SelectObject(hDC, hBrush)
651 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
652 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
653
654 Dim radi2 As Long
655 If Aspect<1 Then
656 radi2=(CDbl(radius)*Aspect) As Long
657 Else
658 radi2=radius
659 radius=(CDbl(radius)/Aspect) As Long
660 End If
661
662 If StartPos=0 And EndPos=0 Then
663 Ellipse(hDC,x-radius,y-radi2,x+radius,y+radi2)
664 Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2)
665 Else
666 Dim sw As Long
667 StartPos *=StartPos
668 EndPos *=EndPos
669
670 If StartPos<0 Or EndPos<0 Then
671 sw=1
672 Else
673 sw=0
674 End If
675
676 StartPos = Abs(StartPos)
677 EndPos = Abs(EndPos)
678
679 If StartPos<=78.5 Then
680 i1=78
681 i2=Int(StartPos)
682 ElseIf StartPos<=235.5 Then
683 StartPos -= 78.5
684 i1=78-Int(StartPos)
685 i2=78
686 ElseIf StartPos<=392.5 Then
687 StartPos -= 235.5
688 i1=-78
689 i2=78-Int(StartPos)
690 ElseIf StartPos<=549.5 Then
691 StartPos -= 392.5
692 i1=-78+Int(StartPos)
693 i2=-78
694 ElseIf StartPos<=628 Then
695 StartPos -= 549.5
696 i1=78
697 i2=-78+Int(StartPos)
698 End If
699
700 If EndPos<=78.5 Then
701 i3=78
702 i4=Int(EndPos)
703 ElseIf EndPos<=235.5 Then
704 EndPos -= 78.5
705 i3=78-Int(EndPos)
706 i4=78
707 ElseIf EndPos<=392.5 Then
708 EndPos -= 235.5
709 i3=-78
710 i4=78-Int(EndPos)
711 ElseIf EndPos<=549.5 Then
712 EndPos -= 392.5
713 i3=-78+Int(EndPos)
714 i4=-78
715 ElseIf EndPos<=628 Then
716 EndPos -= 549.5
717 i3=78
718 i4=-78+Int(EndPos)
719 End If
720
721 If sw Then
722 Pie(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
723 Pie(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
724 Else
725 Arc(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
726 Arc(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
727 End If
728 End If
729
730 SelectObject(hDC, hOldPenDC)
731 SelectObject(hDC, hOldBrushDC)
732 ReleaseDC(_PromptSys_hWnd, hDC)
733 SelectObject(_PromptSys_hMemDC, hOldPen)
734 SelectObject(_PromptSys_hMemDC, hOldBrush)
735 DeleteObject(hPen)
736 If bFill Then DeleteObject(hBrush)
737End Sub
738
739Sub Line(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long, ColorCode As Long, fType As Long, BrushColor As Long)
740 Dim temp As Long
741
742 If sx = &H80000000 And sy = &H80000000 Then
743 With _PromptSys_GlobalPos
744 sx = .x
745 sy = .y
746 End With
747 End If
748
749 If bStep Then
750 ex += sx
751 ey += sy
752 Else
753 If fType Then
754 'ラインの場合(四角形でない場合)
755 If sx>ex Then
756 temp=ex
757 ex=sx
758 sx=temp
759 End If
760 If sy>ey Then
761 temp=ey
762 ey=sy
763 sy=temp
764 End If
765 End If
766 End If
767
768 Dim hdc = GetDC(_PromptSys_hWnd)
769 Dim hPen = CreatePen(PS_SOLID, 1, GetBasicColor(ColorCode))
770 Dim hBrush As HBRUSH
771 If fType=2 Then
772 hBrush = CreateSolidBrush(GetBasicColor(BrushColor))
773 Else
774 hBrush = GetStockObject(NULL_BRUSH)
775 End If
776
777 SelectObject(hdc, hPen)
778 SelectObject(hdc, hBrush)
779 Dim hOldPen = SelectObject(_PromptSys_hMemDC, hPen)
780 Dim hOldBrush = SelectObject(_PromptSys_hMemDC, hBrush)
781
782 Select Case fType
783 Case 0
784 'line
785 MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
786 LineTo(_PromptSys_hMemDC,ex,ey)
787 SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
788 MoveToEx(hdc,sx,sy,ByVal NULL)
789 LineTo(hdc,ex,ey)
790 SetPixel(hdc,ex,ey,GetBasicColor(ColorCode))
791 Case Else
792 'Rectangle
793 Rectangle(hdc,sx,sy,ex+1,ey+1)
794 Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1)
795 End Select
796
797 ReleaseDC(_PromptSys_hWnd,hdc)
798 SelectObject(_PromptSys_hMemDC,hOldPen)
799 SelectObject(_PromptSys_hMemDC,hOldBrush)
800 DeleteObject(hPen)
801 If fType = 2 Then DeleteObject(hBrush)
802 With _PromptSys_GlobalPos
803 .x = ex
804 .y = ey
805 End With
806End Sub
807
808Sub PSet(x As Long, y As Long, ColorCode As Long)
809 Dim hdc = GetDC(_PromptSys_hWnd)
810 SetPixel(hdc, x, y, GetBasicColor(ColorCode))
811 SetPixel(_PromptSys_hMemDC, x, y, GetBasicColor(ColorCode))
812 ReleaseDC(_PromptSys_hWnd, hdc)
813 With _PromptSys_GlobalPos
814 .x = x
815 .y = y
816 End With
817End Sub
818
819Sub Paint(x As Long, y As Long, BrushColor As Long, LineColor As Long)
820 Dim hbr = CreateSolidBrush(GetBasicColor(BrushColor))
821
822 Dim hdc = GetDC(_PromptSys_hWnd)
823 Dim hbrOld = SelectObject(_PromptSys_hMemDC, hbr)
824 Dim hbrOldWndDC = SelectObject(hdc, hbr)
825
826 ExtFloodFill(hdc, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
827 ExtFloodFill(_PromptSys_hMemDC, x, y, GetBasicColor(LineColor), FLOODFILLBORDER)
828
829 ReleaseDC(_PromptSys_hWnd, hdc)
830 SelectObject(_PromptSys_hMemDC, hbrOld)
831 SelectObject(hdc, hbrOldWndDC)
832 DeleteObject(hbr)
833End Sub
834
835Function Inkey$() As String
836 If _PromptSys_KeyChar=0 Then
837 Inkey$=""
838 Else
839 Inkey$=Chr$(_PromptSys_KeyChar)
840 End If
841 _PromptSys_KeyChar=0
842End Function
843
844Function Input$(length As Long) As String
845 Dim i = 0 As Long
846
847 If length<=0 Then
848 Input$=""
849 Exit Function
850 End If
851
852 While 1
853 If _PromptSys_KeyChar Then
854 Input$=Input$+Chr$(_PromptSys_KeyChar)
855 _PromptSys_KeyChar=0
856 i++
857 If i >= length Then
858 Exit While
859 End If
860 End If
861 Sleep(1)
862 Wend
863End Function
864
865End Namespace 'Detail
866
867Function OwnerWnd() As HWND
868 Return Detail._PromptSys_hWnd
869End Function
870
871End Namespace 'Prompt
872End Namespace 'ActiveBasic
873
874'----------------------
875' Prompt text Commands
876'----------------------
877
878Sub PRINT_ToPrompt(s As String)
879 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(s)
880End Sub
881
882Macro CLS()(num As Long)
883 ActiveBasic.Prompt.Detail.Cls(num)
884End Macro
885
886Macro COLOR(TextColorCode As Long)(BackColorCode As Long)
887 ActiveBasic.Prompt.Detail.Color(TextColorCode, BackColorCode)
888End Macro
889
890'---------- Defined in "command.sbp" ----------
891'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr
892'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord
893'----------------------------------------------
894Sub INPUT_FromPrompt(ShowStr As String)
895 ActiveBasic.Prompt.Detail.INPUT_FromPrompt(ShowStr)
896End Sub
897
898/* TODO: _System_GetUsingFormatを用意して実装する
899Sub PRINTUSING_ToPrompt(UsingStr As String)
900 ActiveBasic.Prompt.Detail.PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
901End Sub
902*/
903
904Macro LOCATE(x As Long, y As Long)
905 ActiveBasic.Prompt.Detail.Locate(x, y)
906End Macro
907
908
909'-------------------
910' Graphics Commands
911'-------------------
912
913Macro CIRCLE(x As Long , y As Long, radius As Long)(ColorCode As Long, StartPos As Double, EndPos As Double, Aspect As Double, bFill As Long, BrushColor As Long)
914 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
915 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
916 ActiveBasic.Prompt.Detail.Circle(x, y, radius, ColorCode, StartPos, EndPos, Aspect, bFill, BrushColor)
917End Macro
918
919Macro LINE(sx As Long, sy As Long, bStep As Long, ex As Long, ey As Long)(ColorCode As Long, fType As Long, BrushColor As Long)
920 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
921 'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor]
922 ActiveBasic.Prompt.Detail.Line(sx, sy, bStep, ex, ey, ColorCode, fType, BrushColor)
923End Macro
924
925Macro PSET(x As Long, y As Long)(ColorCode As Long)
926 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
927 'PSet (x,y),ColorCode
928 ActiveBasic.Prompt.Detail.PSet(x, y, ColorCode)
929End Macro
930
931Macro PAINT(x As Long, y As Long, BrushColor As Long)(ByVal LineColor As Long)
932 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
933 'Paint (x,y),BrushColor,LineColor
934 ActiveBasic.Prompt.Detail.Paint(x, y, BrushColor, LineColor)
935End Macro
936
937
938'-----------
939' Functions
940'-----------
941
942Function Inkey$() As String
943 Return ActiveBasic.Prompt.Detail.Inkey$()
944End Function
945
946Function Input$(length As Long) As String
947 Return ActiveBasic.Prompt.Detail.Input$(length)
948End Function
949
950ActiveBasic.Prompt.Detail._PromptSys_Initialize()
951
952#endif '_INC_PROMPT
Note: See TracBrowser for help on using the repository browser.