source: Include/basic/prompt.sbp@ 17

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

×ボタンがクリックされた場合は強制的にプログラムを終了するよう、変更。

File size: 20.4 KB
Line 
1'prompt.sbp
2
3
4#ifndef _INC_PROMPT
5#define _INC_PROMPT
6
7
8#include <api_imm.sbp>
9
10Dim _PromptSys_hWnd As HWND
11Dim _PromptSys_dwThreadID As DWord
12Dim _PromptSys_bInitFinish As Long
13
14'text
15Dim _PromptSys_LogFont As LOGFONT
16Dim _PromptSys_hFont As HFONT
17Dim _PromptSys_FontSize As SIZE
18Dim _PromptSys_InputStr[255] As Byte
19Dim _PromptSys_InputLen As Long
20Dim _PromptSys_KeyChar As Byte
21Dim _PromptSys_CurPos As POINTAPI
22Dim _PromptSys_Buffer[100] As BytePtr
23Dim _PromptSys_TextColor[100] As DWordPtr
24Dim _PromptSys_BackColor[100] As DWordPtr
25Dim _PromptSys_NowTextColor As DWord
26Dim _PromptSys_NowBackColor As DWord
27Dim _PromptSys_SectionOfBufferAccess As CRITICAL_SECTION
28
29
30_PromptSys_InputLen=-1
31
32'graphic
33Dim _PromptSys_hBitmap As HBITMAP
34Dim _PromptSys_hMemDC As HDC
35Dim _PromptSys_ScreenSize As SIZE
36Dim _PromptSys_GlobalPos As POINTAPI
37
38
39_PromptSys_bInitFinish=0
40CreateThread(
41 0,
42 0,
43 AddressOf(PromptMain) As LPTHREAD_START_ROUTINE,
44 0 As VoidPtr,
45 0,
46 _PromptSys_dwThreadID)
47Do
48 Sleep(20)
49Loop Until _PromptSys_bInitFinish
50
51Sub DrawPromptBuffer(hDC As HDC, StartLine As Long, EndLine As Long)
52 Dim i As Long, i2 As Long, i3 As Long
53 Dim hOldFont As HFONT
54 Dim sz As SIZE
55 Dim temporary[2] As Byte
56
57 hOldFont=SelectObject(hDC,_PromptSys_hFont)
58
59 'Scroll
60 Dim rc As RECT
61 GetClientRect(_PromptSys_hWnd,rc)
62 While (_PromptSys_CurPos.y+1)*_PromptSys_FontSize.cy>rc.bottom and _PromptSys_CurPos.y>0
63 HeapFree(_System_hProcessHeap,0,_PromptSys_Buffer[0])
64 HeapFree(_System_hProcessHeap,0,_PromptSys_TextColor[0])
65 HeapFree(_System_hProcessHeap,0,_PromptSys_BackColor[0])
66 For i=0 To 100-1
67 _PromptSys_Buffer[i]=_PromptSys_Buffer[i+1]
68 _PromptSys_TextColor[i]=_PromptSys_TextColor[i+1]
69 _PromptSys_BackColor[i]=_PromptSys_BackColor[i+1]
70 Next
71 _PromptSys_Buffer[100]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255)
72 _PromptSys_TextColor[100]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255*SizeOf(LONG_PTR))
73 _PromptSys_BackColor[100]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255*SizeOf(LONG_PTR))
74
75 _PromptSys_CurPos.y=_PromptSys_CurPos.y-1
76
77 'Redraw
78 StartLine=-1
79 Wend
80
81 i=0
82 While i*_PromptSys_FontSize.cy<rc.bottom and i<=100
83 If StartLine=-1 or (StartLine<=i and i<=EndLine) Then
84 GetTextExtentPoint32(hDC,_PromptSys_Buffer[i],lstrlen(_PromptSys_Buffer[i]),sz)
85 BitBlt(hDC,_
86 sz.cx, i*_PromptSys_FontSize.cy, _
87 rc.right, _PromptSys_FontSize.cy, _
88 _PromptSys_hMemDC,sz.cx,i*_PromptSys_FontSize.cy,SRCCOPY)
89
90 i3=lstrlen(_PromptSys_Buffer[i])
91 For i2=0 To i3-1
92 SetTextColor(hDC,_PromptSys_TextColor[i][i2])
93 If _PromptSys_BackColor[i][i2]=-1 Then
94 SetBkMode(hDC,TRANSPARENT)
95 Else
96 SetBkMode(hDC,OPAQUE)
97 SetBkColor(hDC,_PromptSys_BackColor[i][i2])
98 End If
99
100 temporary[0]=_PromptSys_Buffer[i][i2]
101 If IsDBCSLeadByte(temporary[0]) Then
102 temporary[1]=_PromptSys_Buffer[i][i2+1]
103 temporary[2]=0
104 Else
105 temporary[1]=0
106 End If
107 TextOut(hDC,i2*_PromptSys_FontSize.cx,i*_PromptSys_FontSize.cy,_
108 temporary,lstrlen(temporary))
109
110 If IsDBCSLeadByte(temporary[0]) Then i2=i2+1
111 Next
112 End If
113
114 i=i+1
115 Wend
116
117 SelectObject(hDC,hOldFont)
118End Sub
119
120Sub PRINT_ToPrompt(buf As String)
121 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
122
123 Dim hDC As HDC
124 Dim StartLine As Long
125 Dim i2 As Long, i3 As Long
126
127 StartLine=_PromptSys_CurPos.y
128
129 'Addition
130 i2=0
131 Do
132 If buf[i2]=9 Then 'tab
133 i3=8-(_PromptSys_CurPos.x mod 8)
134
135 FillMemory(_PromptSys_Buffer[_PromptSys_CurPos.y]+_PromptSys_CurPos.x,i3,Asc(" "))
136
137 i2=i2+1
138 _PromptSys_CurPos.x=_PromptSys_CurPos.x+i3
139 Continue
140 End If
141
142 If buf[i2]=13 and buf[i2+1]=10 Then '\r\n
143 i2=i2+2
144 _PromptSys_CurPos.y=_PromptSys_CurPos.y+1
145 _PromptSys_CurPos.x=0
146 Continue
147 End If
148
149 If buf[i2]=0 Then Exit Do
150 _PromptSys_Buffer[_PromptSys_CurPos.y][_PromptSys_CurPos.x]=buf[i2]
151 _PromptSys_TextColor[_PromptSys_CurPos.y][_PromptSys_CurPos.x]=_PromptSys_NowTextColor
152 _PromptSys_BackColor[_PromptSys_CurPos.y][_PromptSys_CurPos.x]=_PromptSys_NowBackColor
153
154 i2=i2+1
155 _PromptSys_CurPos.x=_PromptSys_CurPos.x+1
156 Loop
157
158 'Draw the text buffer added
159 hDC=GetDC(_PromptSys_hWnd)
160 DrawPromptBuffer(hDC,StartLine,_PromptSys_CurPos.y)
161 ReleaseDC(_PromptSys_hWnd,hDC)
162
163 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
164End Sub
165
166Function PromptProc(hWnd As HWND, message As DWord, wParam As WPARAM, lParam As LPARAM) As LRESULT
167 Dim hIMC As HIMC
168 Dim hDC As HDC
169 Dim ps As PAINTSTRUCT
170 Dim TempStr As String
171 Dim temporary[255] As Byte
172 Dim CompForm As COMPOSITIONFORM
173 Dim hGlobal As HGLOBAL
174 Dim pTemp As BytePtr
175
176 Select Case message
177 Case WM_CREATE
178 hDC=GetDC(hWnd)
179 _PromptSys_hBitmap=CreateCompatibleBitmap(hDC,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy)
180 _PromptSys_hMemDC=CreateCompatibleDC(hDC)
181 SelectObject(_PromptSys_hMemDC,_PromptSys_hBitmap)
182
183 'Initialize for Win9x
184 Dim hOldBrush As HBRUSH
185 hOldBrush=SelectObject(_PromptSys_hMemDC,GetStockObject(BLACK_BRUSH))
186 PatBlt(_PromptSys_hMemDC,0,0,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy,PATCOPY)
187 SelectObject(_PromptSys_hMemDC,hOldBrush)
188
189 Dim hOldFont As HFONT
190 Dim tm As TEXTMETRIC
191 hOldFont=SelectObject(_PromptSys_hMemDC,_PromptSys_hFont)
192 GetTextExtentPoint32(_PromptSys_hMemDC," ",1,_PromptSys_FontSize)
193 GetTextMetrics(_PromptSys_hMemDC,tm)
194 SelectObject(_PromptSys_hMemDC,hOldFont)
195 _PromptSys_FontSize.cy=tm.tmHeight
196
197 ReleaseDC(hWnd,hDC)
198 Case WM_PAINT
199 hDC=BeginPaint(hWnd,ps)
200 BitBlt(hDC,0,0,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy,_PromptSys_hMemDC,0,0,SRCCOPY)
201 DrawPromptBuffer(hDC,-1,0)
202 EndPaint(hWnd,ps)
203
204 _PromptSys_bInitFinish=1
205 Case WM_SETFOCUS
206 If _PromptSys_InputLen<>-1 Then
207 hIMC=ImmGetContext(hWnd)
208 If hIMC Then
209 CompForm.dwStyle=CFS_POINT
210 CompForm.ptCurrentPos.x=_PromptSys_CurPos.x*_PromptSys_FontSize.cx
211 CompForm.ptCurrentPos.y=_PromptSys_CurPos.y*_PromptSys_FontSize.cy
212 ImmSetCompositionWindow(hIMC,CompForm)
213 ImmSetCompositionFont(hIMC,_PromptSys_LogFont)
214 End If
215 ImmReleaseContext(hWnd,hIMC)
216
217 CreateCaret(hWnd,NULL,9,6)
218 SetCaretPos(_PromptSys_CurPos.x*_PromptSys_FontSize.cx, _
219 (_PromptSys_CurPos.y+1)*_PromptSys_FontSize.cy-7)
220 ShowCaret(hWnd)
221 End If
222 Case WM_KILLFOCUS
223 HideCaret(hWnd)
224 DestroyCaret()
225 Case WM_KEYDOWN
226 If _PromptSys_InputLen=-1 Then
227 _PromptSys_KeyChar=wParam As Byte
228 End If
229 Case WM_CHAR
230 If _PromptSys_InputLen<>-1 Then
231 If wParam=VK_BACK Then
232 If _PromptSys_InputLen Then
233 _PromptSys_InputLen=_PromptSys_InputLen-1
234 _PromptSys_InputStr[_PromptSys_InputLen]=0
235
236 _PromptSys_CurPos.x=_PromptSys_CurPos.x-1
237 _PromptSys_Buffer[_PromptSys_CurPos.y][_PromptSys_CurPos.x]=0
238 End If
239 ElseIf wParam=VK_RETURN Then
240 _PromptSys_InputStr[_PromptSys_InputLen]=0
241 _PromptSys_InputLen=-1
242 TempStr=Ex"\r\n"
243 ElseIf wParam=&H16 Then
244 'Paste Command(Use Clippboard)
245 OpenClipboard(hWnd)
246 hGlobal=GetClipboardData(CF_TEXT)
247 If hGlobal=0 Then PromptProc=0:Exit Function
248 pTemp=GlobalLock(hGlobal) As *Byte
249
250 TempStr=ZeroString(lstrlen(pTemp)+1)
251 lstrcpy(StrPtr(TempStr),pTemp)
252
253 lstrcpy((VarPtr(_PromptSys_InputStr[0])+_PromptSys_InputLen) As *Byte,pTemp)
254 _PromptSys_InputLen=_PromptSys_InputLen+lstrlen(pTemp)
255
256 GlobalUnlock(hGlobal)
257 CloseClipboard()
258 Else
259 _PromptSys_InputStr[_PromptSys_InputLen]=wParam As Byte
260 _PromptSys_InputLen=_PromptSys_InputLen+1
261
262 temporary[0]=wParam As Byte
263 temporary[1]=0
264 TempStr=temporary
265 End If
266
267 SendMessage(hWnd,WM_KILLFOCUS,0,0)
268 PRINT_ToPrompt(TempStr)
269 SendMessage(hWnd,WM_SETFOCUS,0,0)
270 End If
271 Case WM_DESTROY
272 DeleteDC(_PromptSys_hMemDC)
273 DeleteObject(_PromptSys_hBitmap)
274
275 PostQuitMessage(0)
276 Case Else
277 PromptProc=DefWindowProc(hWnd,message,wParam,lParam)
278 Exit Function
279 End Select
280 PromptProc=0
281End Function
282
283Function PromptMain(dwData As Long) As Long
284 Dim i As Long
285
286 'Allocate
287 For i=0 To 100
288 _PromptSys_Buffer[i]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255)
289 _PromptSys_TextColor[i]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255*SizeOf(LONG_PTR))
290 _PromptSys_BackColor[i]=HeapAlloc(_System_hProcessHeap,HEAP_ZERO_MEMORY,255*SizeOf(LONG_PTR))
291 Next
292
293 'Current Colors initialize
294 _PromptSys_NowTextColor=RGB(255,255,255)
295 _PromptSys_NowBackColor=RGB(0,0,0)
296
297 'Setup
298 _PromptSys_ScreenSize.cx=GetSystemMetrics(SM_CXSCREEN)
299 _PromptSys_ScreenSize.cy=GetSystemMetrics(SM_CYSCREEN)
300
301 'LogFont initialize
302 _PromptSys_LogFont.lfHeight=-16
303 _PromptSys_LogFont.lfWidth=0
304 _PromptSys_LogFont.lfEscapement=0
305 _PromptSys_LogFont.lfOrientation=0
306 _PromptSys_LogFont.lfWeight=0
307 _PromptSys_LogFont.lfItalic=0
308 _PromptSys_LogFont.lfUnderline=0
309 _PromptSys_LogFont.lfStrikeOut=0
310 _PromptSys_LogFont.lfCharSet=SHIFTJIS_CHARSET
311 _PromptSys_LogFont.lfOutPrecision=OUT_DEFAULT_PRECIS
312 _PromptSys_LogFont.lfClipPrecision=CLIP_DEFAULT_PRECIS
313 _PromptSys_LogFont.lfQuality=DEFAULT_QUALITY
314 _PromptSys_LogFont.lfPitchAndFamily=FIXED_PITCH
315 lstrcpy(_PromptSys_LogFont.lfFaceName,"MS 明朝")
316
317 _PromptSys_hFont=CreateFontIndirect(_PromptSys_LogFont)
318
319 'Critical Section
320 InitializeCriticalSection(_PromptSys_SectionOfBufferAccess)
321
322 'Regist Prompt Class
323 Dim wcl As WNDCLASSEX
324 FillMemory(VarPtr(wcl),Len(wcl),0)
325 wcl.cbSize=Len(wcl)
326 wcl.hInstance=GetModuleHandle(0)
327 wcl.style=CS_HREDRAW or CS_VREDRAW or CS_DBLCLKS
328 wcl.hIcon=LoadIcon(NULL,MAKEINTRESOURCE(IDI_APPLICATION))
329 wcl.hIconSm=LoadIcon(NULL,MAKEINTRESOURCE(IDI_WINLOGO))
330 wcl.hCursor=LoadCursor(NULL,MAKEINTRESOURCE(IDC_ARROW))
331 wcl.lpszClassName="PROMPT"
332 wcl.lpfnWndProc=AddressOf(PromptProc)
333 wcl.hbrBackground=GetStockObject(BLACK_BRUSH)
334 RegisterClassEx(wcl)
335
336 'Create Prompt Window
337 _PromptSys_hWnd=CreateWindowEx(WS_EX_CLIENTEDGE,"PROMPT","BASIC PROMPT",WS_OVERLAPPEDWINDOW,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,CW_USEDEFAULT,0,0,GetModuleHandle(0),0)
338 ShowWindow(_PromptSys_hWnd,SW_SHOW)
339
340 Dim msg As MSG, iResult As Long
341 Do
342 iResult=GetMessage(msg,0,0,0)
343 If iResult=0 or iResult=-1 Then Exit Do
344 TranslateMessage(msg)
345 DispatchMessage(msg)
346 Loop
347
348 EnterCriticalSection(_PromptSys_SectionOfBufferAccess)
349 For i=0 to 100
350 HeapFree(_System_hProcessHeap,0,_PromptSys_Buffer[i])
351 HeapFree(_System_hProcessHeap,0,_PromptSys_TextColor[i])
352 HeapFree(_System_hProcessHeap,0,_PromptSys_BackColor[i])
353 Next
354
355 '強制的に終了する
356 ExitProcess(0)
357
358 LeaveCriticalSection(_PromptSys_SectionOfBufferAccess)
359
360 DeleteCriticalSection(_PromptSys_SectionOfBufferAccess)
361
362 ExitProcess(0)
363End Function
364
365
366'----------------------
367' Prompt text Commands
368'----------------------
369
370Macro CLS()(num As Long)
371 Dim i As Long
372 Dim hOldBrush As HBRUSH
373
374 'When parameter was omitted, num is set to 1
375 If num=0 Then num=1
376
377 If num=1 or num=3 Then
378 'Clear the text screen
379 For i=0 To 100
380 FillMemory(_PromptSys_Buffer[i],255,0)
381 Next
382 _PromptSys_CurPos.x=0
383 _PromptSys_CurPos.y=0
384 End If
385
386 If num=2 or num=3 Then
387 'Clear the graphics screen
388 hOldBrush=SelectObject(_PromptSys_hMemDC,GetStockObject(BLACK_BRUSH))
389 PatBlt(_PromptSys_hMemDC,0,0,_PromptSys_ScreenSize.cx,_PromptSys_ScreenSize.cy,PATCOPY)
390 SelectObject(_PromptSys_hMemDC,hOldBrush)
391 End If
392
393 'Redraw
394 InvalidateRect(_PromptSys_hWnd,ByVal 0,0)
395End Macro
396
397Macro COLOR(TextColorCode As Long)(BackColorCode As Long)
398 _PromptSys_NowTextColor=GetBasicColor(TextColorCode)
399 If BackColorCode=-1 Then
400 _PromptSys_NowBackColor=-1
401 Else
402 _PromptSys_NowBackColor=GetBasicColor(BackColorCode)
403 End If
404End Macro
405
406'---------- Defined in "command.sbp" ----------
407'Dim _System_InputDataPtr[_System_MAX_PARMSNUM] As VoidPtr
408'Dim _System_InputDataType[_System_MAX_PARMSNUM] As DWord
409'----------------------------------------------
410Sub INPUT_FromPrompt(ShowStr As String)
411 Dim i As Long ,i2 As Long, i3 As Long
412 Dim buf As String
413
414*InputReStart
415
416 PRINT_ToPrompt(ShowStr)
417
418 'Input by keyboard
419 _PromptSys_InputLen=0
420 SendMessage(_PromptSys_hWnd,WM_SETFOCUS,0,0)
421 While _PromptSys_InputLen<>-1
422 Sleep(10)
423 Wend
424 SendMessage(_PromptSys_hWnd,WM_KILLFOCUS,0,0)
425
426 'Set value to variable
427 i=0
428 i2=0
429 buf=ZeroString(lstrlen(_PromptSys_InputStr))
430 While 1
431 i3=0
432 While 1
433 If _PromptSys_InputStr[i2]=Asc(",") Then
434 buf.Chars[i3]=0
435 Exit While
436 End If
437
438 buf.Chars[i3]=_PromptSys_InputStr[i2]
439
440 If _PromptSys_InputStr[i2]=0 Then Exit While
441
442 i2=i2+1
443 i3=i3+1
444 Wend
445
446 Select Case _System_InputDataType[i]
447 Case _System_Type_Double
448 SetDouble(_System_InputDataPtr[i],Val(buf))
449 Case _System_Type_Single
450 SetSingle(_System_InputDataPtr[i],Val(buf))
451 Case _System_Type_Int64,_System_Type_QWord
452 SetQWord(_System_InputDataPtr[i],Val(buf))
453 Case _System_Type_Long,_System_Type_DWord
454 SetDWord(_System_InputDataPtr[i],Val(buf))
455 Case _System_Type_Integer,_System_Type_Word
456 SetWord(_System_InputDataPtr[i],Val(buf))
457 Case _System_Type_Char,_System_Type_Byte
458 SetByte(_System_InputDataPtr[i],Val(buf))
459
460 Case _System_Type_String
461 Dim pTempStr As *String
462 pTempStr=_System_InputDataPtr[i] As *String
463
464 pTempStr->Length=i3
465 pTempStr->Chars=_System_realloc(pTempStr->Chars,pTempStr->Length+1)
466 memcpy(pTempStr->Chars,buf.Chars,pTempStr->Length)
467 pTempStr->Chars[pTempStr->Length]=0
468 End Select
469
470 i=i+1
471 If _System_InputDataPtr[i]=0 and _PromptSys_InputStr[i2]=Asc(",") Then
472 PRINT_ToPrompt(Ex"入力データの個数が多すぎます\r\n")
473 Goto *InputReStart
474 ElseIf _PromptSys_InputStr[i2]=0 Then
475 If _System_InputDataPtr[i]<>0 Then
476 PRINT_ToPrompt(Ex"入力データの個数が足りません\r\n")
477 Goto *InputReStart
478 Else
479 Exit While
480 End If
481 End If
482
483 i2=i2+1
484 Wend
485End Sub
486
487Sub PRINTUSING_ToPrompt(UsingStr As String)
488 PRINT_ToPrompt(_System_GetUsingFormat(UsingStr))
489End Sub
490
491Macro LOCATE(x As Long, y As Long)
492 Dim i As Long, i2 As Long
493
494 If x<0 Then x=0
495 If y<0 Then y=0
496 If y>100 Then y=100
497
498 _PromptSys_CurPos.x=x
499 _PromptSys_CurPos.y=y
500
501 i=0
502 While _PromptSys_Buffer[y][i]
503 i=i+1
504 Wend
505
506 If i<x Then
507 FillMemory(_PromptSys_Buffer[y]+i,x-i,Asc(" "))
508 For i2=i To x-1
509 _PromptSys_BackColor[y][i2]=-1
510 Next
511 End If
512End Macro
513
514
515'-------------------
516' Graphics Commands
517'-------------------
518
519Macro 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)
520 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
521 'Circle (x, y), radius [, color] [, start] [, end] [, aspect] [, f] [, color2]
522
523 Dim hDC As Long
524 Dim hPen As Long, hOldPen As Long
525 Dim hBrush As Long, hOldBrush As Long
526 Dim radi2 As Long
527 Dim sw As Long
528 Dim i1 As Long, i2 As Long, i3 As Long, i4 As Long
529
530 hPen=CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
531 If bFill Then
532 hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
533 Else
534 hBrush=GetStockObject(NULL_BRUSH)
535 End If
536
537 hDC=GetDC(_PromptSys_hWnd)
538 SelectObject(hDC,hPen)
539 SelectObject(hDC,hBrush)
540 hOldPen=SelectObject(_PromptSys_hMemDC,hPen)
541 hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)
542
543 If Aspect<1 Then
544 radi2=CDbl(radius)*Aspect
545 Else
546 radi2=radius
547 radius=CDbl(radius)/Aspect
548 End If
549
550 If StartPos=0 And EndPos=0 Then
551 Ellipse(hDC,x-radius,y-radi2,x+radius,y+radi2)
552 Ellipse(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2)
553 Else
554 StartPos=StartPos*100
555 EndPos=EndPos*100
556
557 If StartPos<0 Or EndPos<0 Then
558 sw=1
559 Else
560 sw=0
561 End If
562
563 If StartPos<0 Then StartPos=StartPos*-1
564 If EndPos<0 Then EndPos=EndPos*-1
565
566 If StartPos<=78.5 Then
567 i1=78
568 i2=Int(StartPos)
569 ElseIf StartPos<=235.5 Then
570 StartPos=StartPos-78.5
571 i1=78-Int(StartPos)
572 i2=78
573 ElseIf StartPos<=392.5 Then
574 StartPos=StartPos-235.5
575 i1=-78
576 i2=78-Int(StartPos)
577 ElseIf StartPos<=549.5 Then
578 StartPos=StartPos-392.5
579 i1=-78+Int(StartPos)
580 i2=-78
581 ElseIf StartPos<=628 Then
582 StartPos=StartPos-549.5
583 i1=78
584 i2=-78+Int(StartPos)
585 End If
586
587 If EndPos<=78.5 Then
588 i3=78
589 i4=Int(EndPos)
590 ElseIf EndPos<=235.5 Then
591 EndPos=EndPos-78.5
592 i3=78-Int(EndPos)
593 i4=78
594 ElseIf EndPos<=392.5 Then
595 EndPos=EndPos-235.5
596 i3=-78
597 i4=78-Int(EndPos)
598 ElseIf EndPos<=549.5 Then
599 EndPos=EndPos-392.5
600 i3=-78+Int(EndPos)
601 i4=-78
602 ElseIf EndPos<=628 Then
603 EndPos=EndPos-549.5
604 i3=78
605 i4=-78+Int(EndPos)
606 End If
607
608 If sw Then
609 Pie(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
610 Pie(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
611 Else
612 Arc(hDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
613 Arc(_PromptSys_hMemDC,x-radius,y-radi2,x+radius,y+radi2, x+i1,y-i2,x+i3,y-i4)
614 End If
615 End If
616
617 ReleaseDC(_PromptSys_hWnd,hDC)
618 SelectObject(_PromptSys_hMemDC,hOldPen)
619 SelectObject(_PromptSys_hMemDC,hOldBrush)
620 DeleteObject(hPen)
621 If bFill Then DeleteObject(hBrush)
622End Macro
623
624Macro 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)
625 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
626 'Line (sx,sy)-[STEP](ex,ey),[ColorCode],[B/Bf],[BrushColor]
627 Dim temp As Long
628
629 If sx=&H80000000 And sy=&H80000000 Then
630 sx=_PromptSys_GlobalPos.x
631 sy=_PromptSys_GlobalPos.y
632 End If
633
634 If bStep Then
635 ex=sx+ex
636 ey=sy+ey
637 Else
638 If fType Then
639 'ラインの場合(四角形でない場合)
640 If sx>ex Then
641 temp=ex
642 ex=sx
643 sx=temp
644 End If
645 If sy>ey Then
646 temp=ey
647 ey=sy
648 sy=temp
649 End If
650 End If
651 End If
652
653 Dim hDC As Long
654 Dim hPen As Long, hOldPen As Long
655 Dim hBrush As Long, hOldBrush As Long
656
657 hDC=GetDC(_PromptSys_hWnd)
658 hPen=CreatePen(PS_SOLID,1,GetBasicColor(ColorCode))
659 If fType=2 Then
660 hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
661 Else
662 hBrush=GetStockObject(NULL_BRUSH)
663 End If
664
665 SelectObject(hDC,hPen)
666 SelectObject(hDC,hBrush)
667 hOldPen=SelectObject(_PromptSys_hMemDC,hPen)
668 hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)
669
670 Select Case fType
671 Case 0
672 'line
673 MoveToEx(_PromptSys_hMemDC,sx,sy,ByVal NULL)
674 LineTo(_PromptSys_hMemDC,ex,ey)
675 SetPixel(_PromptSys_hMemDC,ex,ey,GetBasicColor(ColorCode))
676 MoveToEx(hDC,sx,sy,ByVal NULL)
677 LineTo(hDC,ex,ey)
678 SetPixel(hDC,ex,ey,GetBasicColor(ColorCode))
679 Case Else
680 'Rectangle
681 Rectangle(hDC,sx,sy,ex+1,ey+1)
682 Rectangle(_PromptSys_hMemDC,sx,sy,ex+1,ey+1)
683 End Select
684
685 ReleaseDC(_PromptSys_hWnd,hDC)
686 SelectObject(_PromptSys_hMemDC,hOldPen)
687 SelectObject(_PromptSys_hMemDC,hOldBrush)
688 DeleteObject(hPen)
689 If fType=2 Then DeleteObject(hBrush)
690
691 _PromptSys_GlobalPos.x=ex
692 _PromptSys_GlobalPos.y=ey
693End Macro
694
695Macro PSET(x As Long, y As Long)(ColorCode As Long)
696 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
697 'PSet (x,y),ColorCode
698
699 Dim hDC As Long
700
701 hDC=GetDC(_PromptSys_hWnd)
702 SetPixel(hDC,x,y,GetBasicColor(ColorCode))
703 SetPixel(_PromptSys_hMemDC,x,y,GetBasicColor(ColorCode))
704 ReleaseDC(_PromptSys_hWnd,hDC)
705
706 _PromptSys_GlobalPos.x=x
707 _PromptSys_GlobalPos.y=y
708End Macro
709
710Macro PAINT(x As Long, y As Long, BrushColor As Long)(ByVal LineColor As Long)
711 '呼び出し方法は以下のようになります(コンパイラがパラメータの並びを最適化します)
712 'Paint (x,y),BrushColor,LineColor
713
714 Dim hDC As Long
715 Dim hBrush As Long, hOldBrush As Long
716
717 hBrush=CreateSolidBrush(GetBasicColor(BrushColor))
718
719 hDC=GetDC(_PromptSys_hWnd)
720 SelectObject(hDC,hBrush)
721 hOldBrush=SelectObject(_PromptSys_hMemDC,hBrush)
722
723 ExtFloodFill(hDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER)
724 ExtFloodFill(_PromptSys_hMemDC,x,y,GetBasicColor(LineColor),FLOODFILLBORDER)
725
726 ReleaseDC(_PromptSys_hWnd,hDC)
727 SelectObject(_PromptSys_hMemDC,hOldBrush)
728 DeleteObject(hBrush)
729End Macro
730
731
732'-----------
733' Functions
734'-----------
735
736Function Inkey$() As String
737 If _PromptSys_KeyChar=0 Then
738 Inkey$=""
739 Else
740 Inkey$=Chr$(_PromptSys_KeyChar)
741 End If
742 _PromptSys_KeyChar=0
743End Function
744
745Function Input$(length As Long) As String
746 Dim i As Long
747
748 If length<=0 Then
749 Input$=""
750 Exit Function
751 End If
752
753 i=0
754 While 1
755 If _PromptSys_KeyChar Then
756 Input$=Input$+Chr$(_PromptSys_KeyChar)
757 _PromptSys_KeyChar=0
758 i=i+1
759 If i>=length Then
760 Exit While
761 End If
762 End If
763 Sleep(1)
764 Wend
765End Function
766
767
768#endif '_INC_PROMPT
Note: See TracBrowser for help on using the repository browser.