1 Unit MKWCrt;
2 {$R Keys.Res}
3
4 Interface
5
6 {
7 MKWCRT - Copyright 1993 by Mark May - MK Software
8 You are free to use this code in your programs, however
9 it may not be included in Source/TPU function libraries
10 without my permission.
11
12 Mythical Kingom Tech BBS (513)237-7737 HST/v32
13 FidoNet: 1:110/290
14 Rime: ->MYTHKING
15 You may also reach me at maym@dmapub.dma.org
16 }
17
18
19 Uses WinProcs, WinTypes, WinDos;
20
21 Const
22 Black = 0;
23 Blue = 1;
24 Green = 2;
25 Cyan = 3;
26 Red = 4;
27 Magenta = 5;
28 Brown = 6;
29 LightGray = 7;
30 DarkGray = 8;
31 LightBlue = 9;
32 LightGreen = 10;
33 LightCyan = 11;
34 LightRed = 12;
35 LightMagenta = 13;
36 Yellow = 14;
37 White = 15;
38 Blink = 128;
39
40
41 Const
42 TextAttr: Byte = $07;
43 TextChar: Char = ' ';
44 CheckBreak: Boolean = True;
45 CheckEOF: Boolean = False;
46 CheckSnow: Boolean = False;
47 DirectVideo: Boolean = False;
48 LastMode: Word = 3;
49 WindMin: Word = $0;
50 WindMax: Word = $184f;
51 ScreenWidth = 80;
52 ScreenHeight = 25;
53 KeyBufferSize = 20;
54
55 Const
56 AppName = 'AppName Here';
57
58 Procedure AssignWinCrt(Var F: Text);
59 Procedure Delay(DTime: LongInt);
60 Procedure TextColor(CL: Byte);
61 Procedure TextBackground(CL: Byte);
62 Procedure PutStr(Str: String);
63 Procedure PutChar(Ch: Char);
64 Procedure GoToXy(X: Byte; Y: Byte);
WhereXnull65 Function WhereX: Byte;
WhereYnull66 Function WhereY: Byte;
67 Procedure Window(X1, Y1, X2, Y2: Byte);
68 Procedure ClrScr;
69 Procedure ClrEol;
KeyPressednull70 Function KeyPressed: Boolean;
ReadKeynull71 Function ReadKey: Char;
SaveScrnRegionnull72 Function SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
73 Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
74 Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
75 Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
76 Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
GetScrnWordnull77 Function GetScrnWord(SX: Byte; SY: Byte): Word;
78 Procedure DelCharInLine(Sx: Byte; Sy: Byte);
79 Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
80 Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
WindowProcnull81 Function WindowProc(HWindow: HWnd; Message, WParam: Word;
82 LParam: Longint): Longint; export;
83 Procedure RedrawScrn;
84
85
86 Type ScrnArrayType = Array[0..(ScreenWidth * ScreenHeight)] of Word;
87
88 Type WordArray = Array[0..9999] of Word;
89
90 Type WordArrayPtr = ^WordArray;
91
92
93 Var
94 HWindow: HWnd;
95 Accels: THandle;
96 Message: TMsg;
97 TVert: Word;
98 THorz: Word;
99 ScrnArray: ^ScrnArrayType;
100 KeyBuffer: Array[1..KeyBufferSize] of Char;
101 KeyPut: Byte;
102 KeySend: Byte;
103 ScrnWidth: Byte;
104 ScrnHeight: Byte;
105
106
107
108 Const
109 WindowClass: TWndClass = (
110 style: 0;
111 lpfnWndProc: @WindowProc;
112 cbClsExtra: 0;
113 cbWndExtra: 0;
114 hInstance: 0;
115 hIcon: 0;
116 hCursor: 0;
117 hbrBackground: 0;
118 lpszMenuName: AppName;
119 lpszClassName: AppName);
120
121
122 Const
123 CurrX: Byte = 1;
124 CurrY: Byte = 1;
125
126 Implementation
127
128
129 Const ColorArray: Array[0..15] of LongInt = (0, 1141120, 43520, 11184640,
130 170, 11141290, 43690, 11184810, 5592405, 16733525, 5635925,
131 16777045, 5592575, 16733695, 5636095, 16777215);
132
133 Procedure Delay(DTime: LongInt);
134 Const
135 TimerId = 1989;
136 Var
137 DDone: Boolean;
138
139 Begin
140 DDone := False;
141 If SetTimer(HWindow,TimerId, DTime, nil) <> 0 Then
142 Begin
143 While Not DDone Do
144 Begin
145 WaitMessage;
146 If PeekMessage(Message, HWindow, 0, 0, pm_Remove) Then
147 Begin
148 If Message.Message = wm_Timer Then
149 DDone := True
150 Else
151 If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
152 Begin
153 TranslateMessage(Message);
154 DispatchMessage(Message);
155 End;
156 End;
157 End;
158 KillTimer(HWindow, TimerId);
159 End;
160 End;
161
162 Procedure TextColor(CL: Byte);
163 Begin
164 TextAttr := TextAttr and $F0;
165 TextAttr := TextAttr or (CL and $0F);
166 End;
167
168
169 Procedure TextBackground(CL: Byte);
170 Begin
171 TextAttr := TextAttr and $0F;
172 TextAttr := TextAttr or (CL shl 4);
173 End;
174
175
176 Procedure GoToXy(X: Byte; Y: Byte);
177 Begin
178 CurrX := X + (WindMin and $ff);
179 CurrY := Y + (WindMin shr 8);
180 If (CurrX > ((WindMax and $ff) + 1)) Then
181 CurrX := (WindMax and $ff) + 1;
182 If (CurrY > ((WindMax shr 8) + 1)) Then
183 CurrY := (WindMax shr 8) + 1;
184 End;
185
186
187 Procedure Window(X1, Y1, X2, Y2: Byte);
188 Begin
189 WindMin := (Y1 - 1);
190 WindMin := (WindMin Shl 8) + (X1 - 1);
191 WindMax := (Y2 - 1);
192 WindMax := (WindMax Shl 8) + (X2 - 1);
193 End;
194
195
196 Procedure ClrScr;
197 Var
198 CX, CY: Byte;
199 TmpStr: String;
200 NumRows, NumCols: Byte;
201 DC: HDC;
202 Metrics: TTextMetric;
203
204 Begin
205 DC := GetDC(HWindow);
206 SetTextColor(DC,ColorArray[TextAttr and $0f]);
207 SetBkColor(DC, ColorArray[TextAttr shr 4]);
208 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
209 TmpStr := '';
210 Cx := (WindMin and $ff);
211 While (Cx <= (WindMax and $ff)) Do
212 Begin
213 TmpStr := TmpStr + TextChar;
214 Inc(Cx);
215 End;
216 Cy := (WindMin shr 8) + 1;
217 While (Cy <= ((WindMax shr 8) + 1)) Do
218 Begin
219 Cx := WindMin and $ff;
220 While Cx <= (WindMax and $ff) Do
221 Begin
222 ScrnArray^[(Cy - 1) * ScreenWidth + (Cx)] := Ord(TextChar) + (TextAttr shl 8);
223 Inc(Cx);
224 End;
225 TextOut(DC, (WindMin and $ff) * THorz, (CY - 1) * TVert, PChar(@TmpStr[1]),
226 Length(TmpStr));
227 Inc(Cy);
228 End;
229 TextChar := ' ';
230 ReleaseDC(HWindow,DC);
231 GoToXY(1, 1);
232 End;
233
234
235 Procedure ClrEol;
236 Var
237 CX: Byte;
238 TmpStr: String;
239 DC: HDC;
240 Metrics: TTextMetric;
241
242 Begin
243 DC := GetDC(HWindow);
244 SetTextColor(DC,ColorArray[TextAttr and $0f]);
245 SetBkColor(DC, ColorArray[TextAttr shr 4]);
246 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
247 CX := CurrX;
248 TmpStr := '';
249 While (CX <= ((WindMax and $ff)+ 1)) Do
250 Begin
251 TmpStr := TmpStr + TextChar;
252 Inc(Cx);
253 End;
254 TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@TmpStr[1]),
255 Length(TmpStr));
256 ReleaseDC(HWindow,DC);
257 End;
258
259
WhereXnull260 Function WhereX: Byte;
261 Begin
262 WhereX := CurrX - (WindMin and $ff);
263 End;
264
265
WhereYnull266 Function WhereY: Byte;
267 Begin
268 WhereY := CurrY - (WindMin shr 8);
269 End;
270
271
GetKeyCharnull272 Function GetKeyChar: Char;
273 Begin
274 If KeyPut <> KeySend Then
275 Begin
276 GetKeyChar := KeyBuffer[KeySend];
277 Inc(KeySend);
278 If KeySend > KeyBufferSize Then
279 KeySend := 1;
280 End
281 Else
282 GetKeyChar := #0;
283 End;
284
285
286 Procedure PutKeyChar(Ch: Char);
287 Var
288 Tmp: Byte;
289
290 Begin
291 Tmp := KeyPut;
292 Inc(KeyPut);
293 If KeyPut > KeyBufferSize Then
294 KeyPut := 1;
295 If KeyPut <> KeySend Then
296 KeyBuffer[Tmp] := Ch
297 Else
298 KeyPut := Tmp;
299 End;
300
301
302 Procedure CharMsg(Message: TMsg);
303 Var
304 Tmp: Byte;
305
306 Begin
307 PutKeyChar(Char(Message.wParam));
308 End;
309
310
WindowProcnull311 Function WindowProc(HWindow: HWnd; Message, WParam: Word;
312 LParam: Longint): Longint;
313 Var
314 PassOn: Boolean;
315
316 Begin
317 PassOn := True;
318 WindowProc := 0;
319 case Message of
320 wm_Char:
321 Begin
322 If (LParam and 256) <> 0 Then
323 Begin
324 PutKeyChar(#0);
325 PutKeyChar(Chr(LParam and 127));
326 End
327 Else
328 PutKeyChar(Chr(WParam));
329 PassOn := False;
330 End;
331 wm_Command:
332 Begin
333 PutKeyChar(#0);
334 PutKeyChar(Chr(Lo(WParam)));
335 PassOn := False;
336 End;
337 wm_Destroy:
338 Begin
339 PostQuitMessage(0);
340 Exit;
341 End;
342 wm_Paint: RedrawScrn;
343 End;
344 If PassOn Then
345 WindowProc := DefWindowProc(HWindow, Message, WParam, LParam)
346 Else
347 WindowProc := 1;
348 End;
349
350
351 Procedure PutChar(Ch: Char);
352 Var
353 DC: HDC;
354
355 Begin
356 Case Ch of
357 #07: ;
358 #08: If CurrX > ((WindMin and $ff) + 1) Then
359 Dec(CurrX);
360 #10: Begin
361 Inc(CurrY);
362 If CurrY > ((WindMax shr 8) + 1) Then
363 Begin
364 CurrY := ((WindMax shr 8) + 1);
365 ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight,1);
366 End;
367 End;
368 #13: CurrX := 1;
369 Else
370 Begin
371 DC := GetDC(HWindow);
372 SetTextColor(DC,ColorArray[TextAttr and $0f]);
373 SetBkColor(DC, ColorArray[TextAttr shr 4]);
374 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
375 ScrnArray^[(CurrX - 1) + (CurrY - 1) * ScreenWidth] := Ord(ch) + (TextAttr shl 8);
376 TextOut(DC, (CurrX - 1) * THorz, (CurrY - 1) * TVert, PChar(@Ch), 1);
377 ReleaseDC(HWindow,DC);
378 Inc(CurrX);
379 If CurrX > ((WindMax and $FF) + 1) Then
380 Begin
381 CurrX := (WindMin and $FF) + 1;
382 Inc(CurrY);
383 If CurrY >= ((WindMax shr 8) + 1) Then
384 Begin
385 CurrY := (WindMax shr 8) + 1;
386 ScrollScrnRegionUp(1, 1, ScreenWidth, ScreenHeight, 1);
387 End;
388 End;
389 End;
390 End;
391 End;
392
393
394 Procedure PutStr(Str: String);
395 Var
396 i: Word;
397
398 Begin
399 i := 1;
400 While i <= Length(Str) Do
401 Begin
402 PutChar(Str[i]);
403 Inc(i);
404 End;
405 End;
406
407
408 Procedure ScrollScrnRegionUp(xl,yl,xh,yh, count: Byte);
409 Var
410 Ty: Byte;
411 Tx: Byte;
412 Wdth: Byte;
413 DC: HDC;
414 Rect: TRect;
415 TempStr: String;
416
417
418 Begin
419 xl := xl + (WindMin and $ff);
420 yl := yl + (WindMin shr 8);
421 xh := xh + (WindMin and $ff);
422 yh := yh + (WindMin shr 8);
423 If yh > ((WindMax shr 8) + 1) Then
424 yh := ((WindMax shr 8) + 1);
425 If xh > ((WindMax and $ff) + 1) Then
426 xh := ((WindMax and $ff) + 1);
427 Wdth := Xh + 1 - Xl;
428 If Wdth > 0 Then
429 Begin
430 Ty := yl;
431 While Ty < yh Do
432 Begin
433 Move(ScrnArray^[(Ty * ScreenWidth) + XL - 1],
434 ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
435 Inc(Ty);
436 End;
437 For Tx := xl to xh Do
438 ScrnArray^[(Tx - 1) + (yh - 1) * ScreenWidth] := 32 + (TextAttr shl 8);
439 Rect.Left := (xl - 1) * THorz;
440 Rect.Right := (xh) * THorz;
441 Rect.Top := (yl - 1) * TVert;
442 Rect.Bottom := (yh) * TVert;
443 ScrollWindow(HWindow, 0, -TVert * Count, @Rect, @Rect);
444 DC := GetDC(HWindow);
445 SetTextColor(DC,ColorArray[TextAttr and $0f]);
446 SetBkColor(DC, ColorArray[TextAttr shr 4]);
447 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
448 TempStr := '';
449 For tx := xl to xh Do
450 TempStr := TempStr + ' ';
451 TextOut(DC, (Xl - 1) * THorz, (Yh - 1) * TVert, PChar(@TempStr[1]),
452 Length(TempStr));
453 ReleaseDC(HWindow,DC);
454 End;
455 End;
456
457
458 Procedure ScrollScrnRegionDown(xl,yl,xh,yh, count: Byte);
459 Var
460 Ty: Byte;
461 Tx: Byte;
462 Wdth: Byte;
463 DC: HDC;
464 Rect: TRect;
465 TempStr: String;
466
467 Begin
468 xl := xl + (WindMin and $ff);
469 yl := yl + (WindMin shr 8);
470 xh := xh + (WindMin and $ff);
471 yh := yh + (WindMin shr 8);
472 If yh > ((WindMax shr 8) + 1) Then
473 yh := ((WindMax shr 8) + 1);
474 If xh > ((WindMax and $ff) + 1) Then
475 xh := ((WindMax and $ff) + 1);
476 Wdth := Xh + 1 - Xl;
477 If Wdth > 0 Then
478 Begin
479 Ty := yh;
480 While Ty > yl Do
481 Begin
482 Move(ScrnArray^[((Ty - 2) * ScreenWidth) + XL - 1],
483 ScrnArray^[((Ty - 1) * ScreenWidth) + XL - 1], Wdth);
484 Dec(Ty);
485 End;
486 For Tx := xl to xh Do
487 ScrnArray^[(Tx - 1) + (yl - 1) * ScreenWidth] := 32 + (TextAttr shl 8);
488 Rect.Left := (xl - 1) * THorz;
489 Rect.Right := (xh) * THorz;
490 Rect.Top := (yl - 1) * TVert;
491 Rect.Bottom := (yh) * TVert;
492 ScrollWindow(HWindow, 0, Count * TVert, @Rect, @Rect);
493 DC := GetDC(HWindow);
494 SetTextColor(DC,ColorArray[TextAttr and $0f]);
495 SetBkColor(DC, ColorArray[TextAttr shr 4]);
496 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
497 TempStr := '';
498 For tx := xl to xh Do
499 TempStr := TempStr + ' ';
500 TextOut(DC, (Xl - 1) * THorz, (Yl - 1) * TVert, PChar(@TempStr[1]),
501 Length(TempStr));
502 ReleaseDC(HWindow,DC);
503 End;
504 End;
505
506
507 Procedure PutScrnWordDC(SX: Byte; SY: Byte; CA: Word; Var DC: HDC);
508 Var
509 Attr: Byte;
510 Ch: Char;
511
512 Begin
513 ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1] := CA;
514 Ch := Chr(Lo(CA));
515 Attr := CA shr 8;
516 SetTextColor(DC,ColorArray[Attr and $0f]);
517 SetBkColor(DC, ColorArray[Attr shr 4]);
518 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
519 TextOut(DC, (SX - 1) * THorz, (SY - 1) * TVert, PChar(@Ch), 1);
520 End;
521
522
523 Procedure RedrawScrn;
524 Var
525 DC: HDC;
526 Paint: TPaintStruct;
527 Tx, Ty: Word;
528 Mx, My: Word;
529 Attr: Byte;
530 LA: Byte;
531 Ch: Char;
532
533 Begin
534 If ((THorz > 0) and (TVert > 0)) Then
535 Begin
536 DC := BeginPaint(HWindow, Paint);
537 Tx := Paint.RcPaint.Left div THorz;
538 Ty := Paint.RcPaint.Top div TVert;
539 If ((Tx < (ScreenWidth - 1)) and (Ty < (ScreenHeight - 1))) Then
540 Begin
541 Mx := (Paint.RcPaint.Right div Thorz) + 1;
542 My := (Paint.RcPaint.Bottom div TVert) + 1;
543 If Mx > (ScreenWidth - 1) Then
544 Mx := ScreenWidth - 1;
545 If My > (ScreenHeight - 1) Then
546 My := ScreenHeight - 1;
547 Attr := ScrnArray^[Tx + (ScreenWidth * Ty)] Shr 8;
548 LA := Attr;
549 SetTextColor(DC,ColorArray[Attr and $0f]);
550 SetBkColor(DC, ColorArray[Attr shr 4]);
551 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
552 While Ty <= My Do
553 Begin
554 Tx := Paint.RcPaint.Left div THorz;
555 While Tx <= Mx Do
556 Begin
557 Attr := ScrnArray^[Tx + (TY * ScreenWidth)] shr 8;
558 If Attr <> LA Then
559 Begin
560 SetTextColor(DC,ColorArray[Attr and $0f]);
561 SetBkColor(DC, ColorArray[Attr shr 4]);
562 LA := Attr;
563 End;
564 Ch := Chr(ScrnArray^[Tx + (TY * ScreenWidth)] and $ff);
565 TextOut(DC, Tx * THorz, TY * TVert, PChar(@Ch), 1);
566 Inc(Tx);
567 End;
568 Inc(Ty);
569 End;
570 End;
571 EndPaint(HWindow, Paint);
572 End;
573 End;
574
575
576 Procedure PutScrnWord (SX: Byte; SY: Byte; CA: Word);
577 Var
578 DC: HDC;
579
580 Begin
581 DC := GetDC(HWindow);
582 PutScrnWordDC(SX, SY, CA, DC);
583 ReleaseDC(HWindow,DC);
584 End;
585
586
GetScrnWordnull587 Function GetScrnWord(SX: Byte; SY: Byte): Word;
588 Begin
589 GetScrnWord := ScrnArray^[((SY - 1) * ScreenWidth) + SX - 1];
590 End;
591
592
SaveScrnRegionnull593 Function SaveScrnRegion(xl,yl,xh,yh: Byte; Var Pt: Pointer):Boolean;
594 Var
595 Tx: Byte;
596 Ty: Byte;
597 Ctr: Word;
598
599 Begin
600 GetMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
601 If Pt = nil Then
602 SaveScrnRegion := False
603 Else
604 Begin
605 SaveScrnRegion := True;
606 Ctr := 0;
607 For Tx := xl to xh Do
608 Begin
609 For Ty := yl to yh Do
610 Begin
611 WordArrayPtr(PT)^[Ctr] := GetScrnWord(Tx, Ty);
612 Inc(Ctr);
613 End;
614 End;
615 End;
616 End;
617
618
619 Procedure RestoreScrnRegion(xl,yl,xh,yh: Byte; Pt: Pointer);
620 Var
621 Tx: Byte;
622 Ty: Byte;
623 Ctr: Word;
624
625 Begin
626 If Pt <> nil Then
627 Begin
628 Ctr := 0;
629 For Tx := xl to xh Do
630 Begin
631 For Ty := yl to yh Do
632 Begin
633 PutScrnWord(Tx, Ty, WordArrayPtr(PT)^[Ctr]);
634 Inc(Ctr);
635 End;
636 End;
637 FreeMem(Pt, ((xh + 1 - xl) * (yh +1 - yl) * 2));
638 End;
639 End;
640
641
642
643 Procedure DelCharInLine(Sx: Byte; Sy: Byte);
644 Var
645 Ex: Byte;
646 Cx: Byte;
647
648 Begin
649 Ex := Lo(WindMax) + 1;
650 Cx := Sx;
651 While (Cx < Ex) Do
652 Begin
653 PutScrnWord(Cx, Sy, GetScrnWord(Cx + 1, Sy));
654 Inc(Cx);
655 End;
656 PutScrnWord(Ex, Sy, 32 + (TextAttr shl 8));
657 End;
658
659
660 Procedure InsCharInLine(Sx: Byte; Sy: Byte; Ch: Char);
661 Var
662 Ex: Byte;
663 Cx: Byte;
664
665 Begin
666 Ex := Lo(WindMax) + 1;
667 Cx := Ex;
668 While (Cx > Sx) Do
669 Begin
670 PutScrnWord(Cx, Sy, GetScrnWord(Cx - 1, Sy));
671 Dec(Cx);
672 End;
673 PutScrnWord(Sx, Sy, Ord(Ch) + (TextAttr shl 8));
674 End;
675
676
677 Procedure InitializeScrnRegion(xl,yl,xh,yh: Byte; Ch: Char);
678 Var
679 Cx, Cy: Byte;
680
681 Begin
682 xl := xl + (WindMin and $ff);
683 yl := yl + (WindMin shr 8);
684 xh := xh + (WindMin and $ff);
685 yh := yh + (WindMin shr 8);
686 If yh > ((WindMax shr 8) + 1) Then
687 yh := ((WindMax shr 8) + 1);
688 If xh > ((WindMax and $ff) + 1) Then
689 xh := ((WindMax and $ff) + 1);
690 Cy := yl;
691 While (cy <= yh) Do
692 Begin
693 Cx := xl;
694 While (Cx <= xh) Do
695 Begin
696 PutScrnWord(Cx, Cy, Ord(ch) + (TextAttr shl 8));
697 Inc(Cx);
698 End;
699 Inc(Cy);
700 End;
701 End;
702
703
704
KeyPressednull705 Function KeyPressed: Boolean;
706 Begin
707 If PeekMessage(Message, HWindow, 0, 0, pm_NoRemove) Then
708 Begin
709 GetMessage(Message, HWindow, wm_KeyFirst, wm_KeyLast);
710 If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
711 Begin
712 TranslateMessage(Message);
713 DispatchMessage(Message);
714 End;
715 End;
716 KeyPressed := (KeyPut <> KeySend);
717 End;
718
719
ReadKeynull720 Function ReadKey: Char;
721 Begin
722 While KeySend = KeyPut Do
723 Begin
724 While PeekMessage(Message, HWindow, 0, 0, pm_NoRemove) Do
725 Begin
726 GetMessage(Message, HWindow, 0, 0);
727 If (TranslateAccelerator(HWindow, Accels, Message) = 0) Then
728 Begin
729 TranslateMessage(Message);
730 DispatchMessage(Message);
731 End;
732 End;
733 End;
734 ReadKey := GetKeyChar;
735 End;
736
737
738 Procedure WinMain;
739 Var
740 DC: HDC;
741 Metrics: TTextMetric;
742
743 Begin
744 if HPrevInst = 0 then
745 Begin
746 WindowClass.hInstance := HInstance;
747 WindowClass.hIcon := LoadIcon(0, idi_Application);
748 WindowClass.hCursor := LoadCursor(0, idc_Arrow);
749 WindowClass.hbrBackground := GetStockObject(white_Brush);
750 if not RegisterClass(WindowClass) then Halt(255);
751 End;
752 HWindow := CreateWindow(
753 AppName,
754 'MKWCrt Application',
755 ws_OverlappedWindow,
756 cw_UseDefault,
757 cw_UseDefault,
758 cw_UseDefault,
759 cw_UseDefault,
760 0,
761 0,
762 HInstance,
763 nil);
764 ShowWindow(HWindow, CmdShow);
765 UpdateWindow(HWindow);
766 DC := GetDC(HWindow);
767 SelectObject(DC, GetStockObject(OEM_Fixed_Font));
768 GetTextMetrics(DC, Metrics);
769 TVert := Metrics.tmHeight + Metrics.tmInternalLeading +
770 Metrics.tmExternalLeading;
771 THorz := Metrics.tmAveCharWidth;
772 ReleaseDC(HWindow,DC);
773 End;
774
775
776 {$F+}
WinWritenull777 Function WinWrite(Var F: TTextRec): Integer;
778 Var
779 i: Word;
780
781 Begin
782 i := 0;
783 While i < F.BufPos Do
784 Begin
785 PutChar(F.BufPtr^[i]);
786 Inc(i);
787 End;
788 F.BufPos := 0;
789 WinWrite := 0;
790 End;
791
792
793 {$F+}
WinCrtClosenull794 Function WinCrtClose(Var F: TTextRec): Integer;
795 Begin
796 F.Mode := fmClosed;
797 WinCrtClose := 0;
798 End;
799
800
801 {$F+}
WinCrtOpennull802 Function WinCrtOpen(Var F: TTextRec): Integer;
803 Begin
804 If F.Mode = fmOutput Then
805 WinCrtOpen := 0
806 Else
807 WinCrtOpen := 5;
808 End;
809
810
811 Procedure AssignWinCrt(Var F: Text);
812 Begin
813 TTextRec(F).Mode := fmClosed;
814 TTextRec(F).BufSize := SizeOf(TTextBuf);
815 TTextRec(F).BufPtr := @TTextRec(F).Buffer;
816 TTextRec(F).OpenFunc := @WinCrtOpen;
817 TTextRec(F).InOutFunc := @WinWrite;
818 TTextRec(F).FlushFunc := @WinWrite;
819 TTextRec(F).CloseFunc := @WinCrtClose;
820 TTextRec(F).Name[0] := #0;
821 End;
822
823
824 Begin
825 New(ScrnArray);
826 ScrnHeight := ScreenHeight;
827 ScrnWidth := ScreenWidth;
828 WinMain;
829 Accels :=LoadAccelerators(HInstance, 'A_RESOURCE');
830 If Accels = 0 Then
831 MessageBeep(0);
832 AssignWinCrt(Output);
833 Rewrite(Output);
834 KeyPut := 1;
835 KeySend := 1;
836 ClrScr;
837 End.
838