На главную Наши проекты:
Журнал   ·   Discuz!ML   ·   Wiki   ·   DRKB   ·   Помощь проекту
ПРАВИЛА FAQ Помощь Участники Календарь Избранное RSS
msm.ru
! ПРАВИЛА РАЗДЕЛА · FAQ раздела Delphi · Книги по Delphi
Пожалуйста, выделяйте текст программы тегом [сode=pas] ... [/сode]. Для этого используйте кнопку [code=pas] в форме ответа или комбобокс, если нужно вставить код на языке, отличном от Дельфи/Паскаля.
Следующие вопросы задаются очень часто, подробно разобраны в FAQ и, поэтому, будут безжалостно удаляться:
1. Преобразовать переменную типа String в тип PChar (PAnsiChar)
2. Как "свернуть" программу в трей.
3. Как "скрыться" от Ctrl + Alt + Del (заблокировать их и т.п.)
4. Как прочитать список файлов, поддиректорий в директории?
5. Как запустить программу/файл?
... (продолжение следует) ...

Вопросы, подробно описанные во встроенной справочной системе Delphi, не несут полезной тематической нагрузки, поэтому будут удаляться.
Запрещается создавать темы с просьбой выполнить какую-то работу за автора темы. Форум является средством общения и общего поиска решения. Вашу работу за Вас никто выполнять не будет.


Внимание
Попытки открытия обсуждений реализации вредоносного ПО, включая различные интерпретации спам-ботов, наказывается предупреждением на 30 дней.
Повторная попытка - 60 дней. Последующие попытки бан.
Мат в разделе - бан на три месяца...
Модераторы: jack128, D[u]fa, Shaggy, Rouse_
  
> Аналог модуля CRT
    Есть ли в Delphi какой-нибудь аналог модуля CRT из Pascal'я?
      По-любому должен быть у ZieglerSoft'a. :yes:
      Ещё здесь ты сможешь найти много полезного (и не только "аналог CRT") ;)
        ExpandedWrap disabled
          {$IfDef VER130}
            {$Define NEW_STYLES}
          {$EndIf}
          {$IfDef VER140}
            {$Define NEW_STYLES}
          {$EndIf}
           
          {..$Define HARD_CRT}      {Redirect STD_...}
          {..$Define CRT_EVENT}     {CTRL-C,...}
          {$Define MOUSE_IS_USED}   {Handle mouse or not}
          {..$Define OneByOne}      {Block or byte style write}
          unit CRT32;
           
          Interface
            {$IfDef Win32}
            Const
              { CRT modes of original CRT unit }
              BW40 = 0;     { 40x25 B/W on Color Adapter }
              CO40 = 1;     { 40x25 Color on Color Adapter }
              BW80 = 2;     { 80x25 B/W on Color Adapter }
              CO80 = 3;     { 80x25 Color on Color Adapter }
              Mono = 7;     { 80x25 on Monochrome Adapter }
              Font8x8 = 256;{ Add-in for ROM font }
              { Mode constants for 3.0 compatibility of original CRT unit }
              C40 = CO40;
              C80 = CO80;
              { Foreground and background color constants of original CRT unit }
              Black = 0;
              Blue = 1;
              Green = 2;
              Cyan = 3;
              Red = 4;
              Magenta = 5;
              Brown  6;
              LightGray = 7;
              { Foreground color constants of original CRT unit }
              DarkGray = 8;
              LightBlue = 9;
              LightGreen = 10;
              LightCyan = 11;
              LightRed = 12;
              LightMagenta = 13;
              Yellow = 14;
              White = 15;
              { Add-in for blinking of original CRT unit }
              Blink = 128;
              {  }
              {  New constans there are not in original CRT unit }
              {  }
              MouseLeftButton = 1;
              MouseRightButton = 2;
              MouseCenterButton = 4;
           
          var
            { Interface variables of original CRT unit }
            CheckBreak: Boolean;    { Enable Ctrl-Break }
            CheckEOF: Boolean;      { Enable Ctrl-Z }
            DirectVideo: Boolean;   { Enable direct video addressing }
            CheckSnow: Boolean;     { Enable snow filtering }
            LastMode: Word;         { Current text mode }
            TextAttr: Byte;         { Current text attribute }
            WindMin: Word;          { Window upper left coordinates }
            WindMax: Word;          { Window lower right coordinates }
            {  }
            {  New variables there are not in original CRT unit }
            {  }
            MouseInstalled: boolean;
            MousePressedButtons: word;
           
          { Interface functions & procedures of original CRT unit }
          procedure AssignCrt(var F: Text);
          function KeyPressed: Boolean;
          function ReadKey: char;
          procedure TextMode(Mode: Integer);
          procedure Window(X1, Y1, X2, Y2: Byte);
          procedure GotoXY(X, Y: Byte);
          function WhereX: Byte;
          function WhereY: Byte;
          procedure ClrScr;
          procedure ClrEol;
          procedure InsLine;
          procedure DelLine;
          procedure TextColor(Color: Byte);
          procedure TextBackground(Color: Byte);
          procedure LowVideo;
          procedure HighVideo;
          procedure NormVideo;
          procedure Delay(MS: Word);
          procedure Sound(Hz: Word);
          procedure NoSound;
          { New functions & procedures there are not in original CRT unit }
          procedure FillerScreen(FillChar: Char);
          procedure FlushInputBuffer;
          function GetCursor: Word;
          procedure SetCursor(NewCursor: Word);
          function MouseKeyPressed: Boolean;
          procedure MouseGotoXY(X, Y: Integer);
          function MouseWhereY: Integer;
          function MouseWhereX: Integer;
          procedure MouseShowCursor;
          procedure MouseHideCursor;
          { These functions & procedures are for inside use only }
          function MouseReset: Boolean;
          procedure WriteChrXY(X, Y: Byte; Chr: char);
          procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
          procedure OverwriteChrXY(X, Y: Byte; Chr: char);
          {$EndIf Win32}
           
          implementation
          {$IfDef Win32}
           
          uses Windows, SysUtils;
           
          type
            POpenText = ^TOpenText;
            TOpenText = function(var F: Text; Mode: Word): Integer; far;
           
          var
            IsWinNT: boolean;
            PtrOpenText: POpenText;
            hConsoleInput: THandle;
            hConsoleOutput: THandle;
            ConsoleScreenRect: TSmallRect;
            StartAttr: word;
            LastX, LastY: byte;
            SoundDuration: integer;
            SoundFrequency: integer;
            OldCP: integer;
            MouseRowWidth, MouseColWidth: word;
            MousePosX, MousePosY: smallInt;
            MouseButtonPressed: boolean;
            MouseEventTime: TDateTime;
          {  }
          {  This function handles the Write and WriteLn commands }
          {  }
           
          function TextOut(var F: Text): Integer; far;
            {$IfDef OneByOne}
          var
            dwSize: DWORD;
            {$EndIf}
          begin
            with TTExtRec(F) do
            begin
              if BufPos > 0 then
              begin
                LastX := WhereX;
                LastY := WhereY;
                {$IfDef OneByOne}
                dwSize := 0;
                while (dwSize < BufPos) do
                begin
                  WriteChrXY(LastX, LastY, BufPtr[dwSize]);
                  Inc(dwSize);
                end;
                {$Else}
                WriteStrXY(LastX, LastY, BufPtr, BufPos);
                FillChar(BufPtr^, BufPos + 1, #0);
                {$EndIf}
                BufPos := 0;
              end;
            end;
            Result := 0;
          end;
          {  }
          {  This function handles the exchanging of Input or Output }
          {  }
           
          function OpenText(var F: Text; Mode: Word): Integer; far;
          var
            OpenResult: integer;
          begin
            OpenResult := 102; { Text not assigned }
            if Assigned(PtrOpenText) then
            begin
              TTextRec(F).OpenFunc := PtrOpenText;
              OpenResult := PtrOpenText^(F, Mode);
              if OpenResult = 0 then
              begin
                if Mode = fmInput then
                  hConsoleInput := TTextRec(F).Handle
                else
                begin
                  hConsoleOutput := TTextRec(F).Handle;
                  TTextRec(Output).InOutFunc := @TextOut;
                  TTextRec(Output).FlushFunc := @TextOut;
                end;
              end;
            end;
            Result := OpenResult;
          end;
          {  }
          {  Fills the current window with special character }
          {  }
           
          procedure FillerScreen(FillChar: Char);
          var
            Coord: TCoord;
            dwSize, dwCount: DWORD;
            Y: integer;
          begin
            Coord.X := ConsoleScreenRect.Left;
            dwSize := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
            for Y := ConsoleScreenRect.Top to ConsoleScreenRect.Bottom do
            begin
              Coord.Y := Y;
              FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
              FillConsoleOutputCharacter(hConsoleOutput, FillChar, dwSize, Coord, dwCount);
            end;
            GotoXY(1,1);
          end;
          {  }
          {  Write one character at the X,Y position }
          {  }
           
          procedure WriteChrXY(X, Y: Byte; Chr: char);
          var
            Coord: TCoord;
            dwSize, dwCount: DWORD;
          begin
            LastX := X;
            LastY := Y;
            case Chr of
              #13: LastX := 1;
              #10:
                begin
                  LastX := 1;
                  Inc(LastY);
                end;
              else
                begin
                  Coord.X := LastX - 1 + ConsoleScreenRect.Left;
                  Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
                  dwSize := 1;
                  FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
                  FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
                  Inc(LastX);
                end;
            end;
            if (LastX + ConsoleScreenRect.Left) > (ConsoleScreenRect.Right + 1) then
            begin
              LastX := 1;
              Inc(LastY);
            end;
            if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
            begin
              Dec(LastY);
              GotoXY(1,1);
              DelLine;
            end;
            GotoXY(LastX, LastY);
          end;
          {  }
          {  Write string into the X,Y position }
          {  }
          (* !!! The WriteConsoleOutput does not write into the last line !!!
            Procedure WriteStrXY(X,Y: byte; Str: PChar; dwSize: integer );
            {$IfDef OneByOne}
              Var
                dwCount: integer;
            {$Else}
              Type
                PBuffer= ^TBuffer;
                TBUffer= packed array [0..16384] of TCharInfo;
              Var
                I: integer;
                dwCount: DWORD;
                WidthHeight,Coord: TCoord;
                hTempConsoleOutput: THandle;
                SecurityAttributes: TSecurityAttributes;
                Buffer: PBuffer;
                DestinationScreenRect,SourceScreenRect: TSmallRect;
            {$EndIf}
            Begin
              If dwSize>0 Then Begin
                {$IfDef OneByOne}
                  LastX:=X;
                  LastY:=Y;
                  dwCount:=0;
                  While dwCount < dwSize Do Begin
                    WriteChrXY(LastX,LastY,Str[dwCount]);
                    Inc(dwCount);
                  End;
                {$Else}
                  SecurityAttributes.nLength:=SizeOf(SecurityAttributes)-SizeOf(DWORD);
                  SecurityAttributes.lpSecurityDescriptor:=NIL;
                  SecurityAttributes.bInheritHandle:=TRUE;
                  hTempConsoleOutput:=CreateConsoleScreenBuffer(
                   GENERIC_READ OR GENERIC_WRITE,
                   FILE_SHARE_READ OR FILE_SHARE_WRITE,
                   @SecurityAttributes,
                   CONSOLE_TEXTMODE_BUFFER,
                   NIL
                  );
                  If dwSize<=(ConsoleScreenRect.Right-ConsoleScreenRect.Left+1) Then Begin
                    WidthHeight.X:=dwSize;
                    WidthHeight.Y:=1;
                  End Else Begin
                    WidthHeight.X:=ConsoleScreenRect.Right-ConsoleScreenRect.Left+1;
                    WidthHeight.Y:=dwSize DIV WidthHeight.X;
                    If (dwSize MOD WidthHeight.X) > 0 Then Inc(WidthHeight.Y);
                  End;
                  SetConsoleScreenBufferSize(hTempConsoleOutput,WidthHeight);
                  DestinationScreenRect.Left:=0;
                  DestinationScreenRect.Top:=0;
                  DestinationScreenRect.Right:=WidthHeight.X-1;
                  DestinationScreenRect.Bottom:=WidthHeight.Y-1;
                  SetConsoleWindowInfo(hTempConsoleOutput,FALSE,DestinationScreenRect);
                  Coord.X:=0;
                  For I:=1 To WidthHeight.Y Do Begin
                    Coord.Y:=I-0;
                    FillConsoleOutputAttribute(hTempConsoleOutput,TextAttr,WidthHeight.X,Coord,dwCount);
                    FillConsoleOutputCharacter(hTempConsoleOutput,' '     ,WidthHeight.X,Coord,dwCount);
                  End;
                  WriteConsole(hTempConsoleOutput,Str,dwSize,dwCount,NIL);
                  {  }
                  New(Buffer);
                  Coord.X:= 0;
                  Coord.Y:= 0;
                  SourceScreenRect.Left:=0;
                  SourceScreenRect.Top:=0;
                  SourceScreenRect.Right:=WidthHeight.X-1;
                  SourceScreenRect.Bottom:=WidthHeight.Y-1;
                  ReadConsoleOutputA(hTempConsoleOutput,Buffer,WidthHeight,Coord,SourceScreenRect);
                  Coord.X:=X-1;
                  Coord.Y:=Y-1;
                  DestinationScreenRect:=ConsoleScreenRect;
                  WriteConsoleOutputA(hConsoleOutput,Buffer,WidthHeight,Coord,DestinationScreenRect);
                  GotoXY((dwSize MOD WidthHeight.X)-1,WidthHeight.Y+1);
                  Dispose(Buffer);
                  {  }
                  CloseHandle(hTempConsoleOutput);
                {$EndIf}
              End;
            End;
          *)
           
          procedure WriteStrXY(X, Y: Byte; Str: PChar; dwSize: Integer);
            {$IfDef OneByOne}
          var
            dwCount: integer;
            {$Else}
          var
            I: integer;
            LineSize, dwCharCount, dwCount, dwWait: DWORD;
            WidthHeight: TCoord;
            OneLine: packed array [0..131] of char;
            Line, TempStr: PChar;
           
            procedure NewLine;
            begin
              LastX := 1;
              Inc(LastY);
              if (LastY + ConsoleScreenRect.Top) > (ConsoleScreenRect.Bottom + 1) then
              begin
                Dec(LastY);
                GotoXY(1,1);
                DelLine;
              end;
              GotoXY(LastX, LastY);
            end;
           
            {$EndIf}
          begin
            if dwSize > 0 then
            begin
              {$IfDef OneByOne}
              LastX := X;
              LastY := Y;
              dwCount := 0;
              while dwCount < dwSize do
              begin
                WriteChrXY(LastX, LastY, Str[dwCount]);
                Inc(dwCount);
              end;
              {$Else}
              LastX := X;
              LastY := Y;
              GotoXY(LastX, LastY);
              dwWait  := dwSize;
              TempStr := Str;
              while (dwWait > 0) and (Pos(#13#10, StrPas(TempStr)) = 1) do
              begin
                Dec(dwWait, 2);
                Inc(TempStr, 2);
                NewLine;
              end;
              while (dwWait > 0) and (Pos(#10, StrPas(TempStr)) = 1) do
              begin
                Dec(dwWait);
                Inc(TempStr);
                NewLine;
              end;
              if dwWait > 0 then
              begin
                if dwSize <= (ConsoleScreenRect.Right - ConsoleScreenRect.Left - LastX + 1) then
                begin
                  WidthHeight.X := dwSize + LastX - 1;
                  WidthHeight.Y := 1;
                end
                else
                begin
                  WidthHeight.X := ConsoleScreenRect.Right - ConsoleScreenRect.Left + 1;
                  WidthHeight.Y := dwSize div WidthHeight.X;
                  if (dwSize mod WidthHeight.X) > 0 then Inc(WidthHeight.Y);
                end;
                for I := 1 to WidthHeight.Y do
                begin
                  FillChar(OneLine, SizeOf(OneLine), #0);
                  Line := @OneLine;
                  LineSize := WidthHeight.X - LastX + 1;
                  if LineSize > dwWait then LineSize := dwWait;
                  Dec(dwWait, LineSize);
                  StrLCopy(Line, TempStr, LineSize);
                  Inc(TempStr, LineSize);
                  dwCharCount := Pos(#13#10, StrPas(Line));
                  if dwCharCount > 0 then
                  begin
                    OneLine[dwCharCount - 1] := #0;
                    OneLine[dwCharCount]     := #0;
                    WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
                    Inc(Line, dwCharCount + 1);
                    NewLine;
                    LineSize := LineSize - (dwCharCount + 1);
                  end
                  else
                  begin
                    dwCharCount := Pos(#10, StrPas(Line));
                    if dwCharCount > 0 then
                    begin
                      OneLine[dwCharCount - 1] := #0;
                      WriteConsole(hConsoleOutput, Line, dwCharCount - 1,dwCount, nil);
                      Inc(Line, dwCharCount);
                      NewLine;
                      LineSize := LineSize - dwCharCount;
                    end;
                  end;
                  if LineSize <> 0 then
                  begin
                    WriteConsole(hConsoleOutput, Line, LineSize, dwCount, nil);
                  end;
                  if dwWait > 0 then
                  begin
                    NewLine;
                  end;
                end;
              end;
              {$EndIf}
            end;
          end;
          {  }
          {  Empty the buffer }
          {  }
           
          procedure FlushInputBuffer;
          begin
            FlushConsoleInputBuffer(hConsoleInput);
          end;
          {  }
          {  Get size of current cursor }
          {  }
           
          function GetCursor: Word;
          var
            CCI: TConsoleCursorInfo;
          begin
            GetConsoleCursorInfo(hConsoleOutput, CCI);
            GetCursor := CCI.dwSize;
          end;
          {  }
          {  Set size of current cursor }
          {  }
           
          procedure SetCursor(NewCursor: Word);
          var
            CCI: TConsoleCursorInfo;
          begin
            if NewCursor = $0000 then
            begin
              CCI.dwSize := GetCursor;
              CCI.bVisible := False;
            end
            else
            begin
              CCI.dwSize := NewCursor;
              CCI.bVisible := True;
            end;
            SetConsoleCursorInfo(hConsoleOutput, CCI);
          end;
          {  }
          { --- Begin of Interface functions & procedures of original CRT unit --- }
           
          procedure AssignCrt(var F: Text);
          begin
            Assign(F, '');
            TTextRec(F).OpenFunc := @OpenText;
          end;
           
          function KeyPressed: Boolean;
          var
            NumberOfEvents: DWORD;
            NumRead: DWORD;
            InputRec: TInputRecord;
            Pressed: boolean;
          begin
            Pressed := False;
            GetNumberOfConsoleInputEvents(hConsoleInput, NumberOfEvents);
            if NumberOfEvents > 0 then
            begin
              if PeekConsoleInput(hConsoleInput, InputRec, 1,NumRead) then
              begin
                if (InputRec.EventType = KEY_EVENT) and
                  (InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.bKeyDown) then
                begin
                  Pressed := True;
                  {$IfDef MOUSE_IS_USED}
                  MouseButtonPressed := False;
                  {$EndIf}
                end
                else
                begin
                  {$IfDef MOUSE_IS_USED}
                  if (InputRec.EventType = _MOUSE_EVENT) then
                  begin
                    with InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.MouseEvent do
                    begin
                      MousePosX := dwMousePosition.X;
                      MousePosY := dwMousePosition.Y;
                      if dwButtonState = FROM_LEFT_1ST_BUTTON_PRESSED then
                      begin
                        MouseEventTime := Now;
                        MouseButtonPressed := True;
                        {If (dwEventFlags AND DOUBLE_CLICK)<>0 Then Begin}
                        {End;}
                      end;
                    end;
                  end;
                  ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
                  {$Else}
                  ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
                  {$EndIf}
                end;
              end;
            end;
            Result := Pressed;
          end;
           
          function ReadKey: char;
          var
            NumRead: DWORD;
            InputRec: TInputRecord;
          begin
            repeat
              repeat
              until KeyPressed;
              ReadConsoleInput(hConsoleInput, InputRec, 1,NumRead);
            until InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar > #0;
            Result := InputRec{$IfDef NEW_STYLES}.Event{$EndIf}.KeyEvent.AsciiChar;
          end;
           
          procedure TextMode(Mode: Integer);
          begin
          end;
           
          procedure Window(X1, Y1, X2, Y2: Byte);
          begin
            ConsoleScreenRect.Left := X1 - 1;
            ConsoleScreenRect.Top := Y1 - 1;
            ConsoleScreenRect.Right := X2 - 1;
            ConsoleScreenRect.Bottom := Y2 - 1;
            WindMin := (ConsoleScreenRect.Top shl 8) or ConsoleScreenRect.Left;
            WindMax := (ConsoleScreenRect.Bottom shl 8) or ConsoleScreenRect.Right;
            {$IfDef WindowFrameToo}
            SetConsoleWindowInfo(hConsoleOutput, True, ConsoleScreenRect);
            {$EndIf}
            GotoXY(1,1);
          end;
           
          procedure GotoXY(X, Y: Byte);
          var
            Coord: TCoord;
          begin
            Coord.X := X - 1 + ConsoleScreenRect.Left;
            Coord.Y := Y - 1 + ConsoleScreenRect.Top;
            if not SetConsoleCursorPosition(hConsoleOutput, Coord) then
            begin
              GotoXY(1, 1);
              DelLine;
            end;
          end;
           
          function WhereX: Byte;
          var
            CBI: TConsoleScreenBufferInfo;
          begin
            GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
            Result := TCoord(CBI.dwCursorPosition).X + 1 - ConsoleScreenRect.Left;
          end;
           
          function WhereY: Byte;
          var
            CBI: TConsoleScreenBufferInfo;
          begin
            GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
            Result := TCoord(CBI.dwCursorPosition).Y + 1 - ConsoleScreenRect.Top;
          end;
           
          procedure ClrScr;
          begin
            FillerScreen(' ');
          end;
           
          procedure ClrEol;
          var
            Coord: TCoord;
            dwSize, dwCount: DWORD;
          begin
            Coord.X := WhereX - 1 + ConsoleScreenRect.Left;
            Coord.Y := WhereY - 1 + ConsoleScreenRect.Top;
            dwSize  := ConsoleScreenRect.Right - Coord.X + 1;
            FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
            FillConsoleOutputCharacter(hConsoleOutput, ' ', dwSize, Coord, dwCount);
          end;
           
          procedure InsLine;
          var
            SourceScreenRect: TSmallRect;
            Coord: TCoord;
            CI: TCharInfo;
            dwSize, dwCount: DWORD;
          begin
            SourceScreenRect := ConsoleScreenRect;
            SourceScreenRect.Top := WhereY - 1 + ConsoleScreenRect.Top;
            SourceScreenRect.Bottom := ConsoleScreenRect.Bottom - 1;
            CI.AsciiChar := ' ';
            CI.Attributes := TextAttr;
            Coord.X := SourceScreenRect.Left;
            Coord.Y := SourceScreenRect.Top + 1;
            dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
            ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
            Dec(Coord.Y);
            FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
          end;
           
          procedure DelLine;
          var
            SourceScreenRect: TSmallRect;
            Coord: TCoord;
            CI: TCharinfo;
            dwSize, dwCount: DWORD;
          begin
            SourceScreenRect := ConsoleScreenRect;
            SourceScreenRect.Top := WhereY + ConsoleScreenRect.Top;
            CI.AsciiChar := ' ';
            CI.Attributes := TextAttr;
            Coord.X := SourceScreenRect.Left;
            Coord.Y := SourceScreenRect.Top - 1;
            dwSize := SourceScreenRect.Right - SourceScreenRect.Left + 1;
            ScrollConsoleScreenBuffer(hConsoleOutput, SourceScreenRect, nil, Coord, CI);
            FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
          end;
           
          procedure TextColor(Color: Byte);
          begin
            LastMode := TextAttr;
            TextAttr := (Color and $0F) or (TextAttr and $F0);
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
          end;
           
          procedure TextBackground(Color: Byte);
          begin
            LastMode := TextAttr;
            TextAttr := (Color shl 4) or (TextAttr and $0F);
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
          end;
           
          procedure LowVideo;
          begin
            LastMode := TextAttr;
            TextAttr := TextAttr and $F7;
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
          end;
           
          procedure HighVideo;
          begin
            LastMode := TextAttr;
            TextAttr := TextAttr or $08;
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
          end;
           
          procedure NormVideo;
          begin
            LastMode := TextAttr;
            TextAttr := StartAttr;
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
          end;
           
          procedure Delay(MS: Word);
            {
            Const
              Magic= $80000000;
            var
             StartMS,CurMS,DeltaMS: DWORD;
             }
          begin
            Windows.SleepEx(MS, False);  // Windows.Sleep(MS);
              {
              StartMS:= GetTickCount;
              Repeat
                CurMS:= GetTickCount;
                If CurMS >= StartMS Then
                   DeltaMS:= CurMS - StartMS
                Else DeltaMS := (CurMS + Magic) - (StartMS - Magic);
              Until MS<DeltaMS;
              }
          end;
           
          procedure Sound(Hz: Word);
          begin
            {SetSoundIOPermissionMap(LocalIOPermission_ON);}
            SoundFrequency := Hz;
            if IsWinNT then
            begin
              Windows.Beep(SoundFrequency, SoundDuration)
            end
            else
            begin
              asm
                  mov  BX,Hz
                  cmp  BX,0
                  jz   @2
                  mov  AX,$34DD
                  mov  DX,$0012
                  cmp  DX,BX
                  jnb  @2
                  div  BX
                  mov  BX,AX
                  { Sound is On ? }
                  in   Al,$61
                  test Al,$03
                  jnz  @1
                  { Set Sound On }
                  or   Al,03
                  out  $61,Al
                  { Timer Command }
                  mov  Al,$B6
                  out  $43,Al
                  { Set Frequency }
              @1: mov  Al,Bl
                  out  $42,Al
                  mov  Al,Bh
                  out  $42,Al
              @2:
              end;
            end;
          end;
           
          procedure NoSound;
          begin
            if IsWinNT then
            begin
              Windows.Beep(SoundFrequency, 0);
            end
            else
            begin
                asm
                  { Set Sound On }
                  in   Al,$61
                  and  Al,$FC
                  out  $61,Al
                end;
            end;
            {SetSoundIOPermissionMap(LocalIOPermission_OFF);}
          end;
          { --- End of Interface functions & procedures of original CRT unit --- }
          {  }
           
          procedure OverwriteChrXY(X, Y: Byte; Chr: char);
          var
            Coord: TCoord;
            dwSize, dwCount: DWORD;
          begin
            LastX := X;
            LastY := Y;
            Coord.X := LastX - 1 + ConsoleScreenRect.Left;
            Coord.Y := LastY - 1 + ConsoleScreenRect.Top;
            dwSize := 1;
            FillConsoleOutputAttribute(hConsoleOutput, TextAttr, dwSize, Coord, dwCount);
            FillConsoleOutputCharacter(hConsoleOutput, Chr, dwSize, Coord, dwCount);
            GotoXY(LastX, LastY);
          end;
           
          {  --------------------------------------------------  }
          {  Console Event Handler }
          {  }
          {$IfDef CRT_EVENT}
          function ConsoleEventProc(CtrlType: DWORD): Bool; stdcall; far;
          var
            S: {$IfDef Win32}ShortString{$Else}String{$EndIf};
            Message: PChar;
          begin
            case CtrlType of
              CTRL_C_EVENT: S        := 'CTRL_C_EVENT';
              CTRL_BREAK_EVENT: S    := 'CTRL_BREAK_EVENT';
              CTRL_CLOSE_EVENT: S    := 'CTRL_CLOSE_EVENT';
              CTRL_LOGOFF_EVENT: S   := 'CTRL_LOGOFF_EVENT';
              CTRL_SHUTDOWN_EVENT: S := 'CTRL_SHUTDOWN_EVENT';
              else
                S := 'UNKNOWN_EVENT';
            end;
            S := S + ' detected, but not handled.';
            Message := @S;
            Inc(Message);
            MessageBox(0, Message, 'Win32 Console', MB_OK);
            Result := True;
          end;
            {$EndIf}
           
          function MouseReset: Boolean;
          begin
            MouseColWidth := 1;
            MouseRowWidth := 1;
            Result := True;
          end;
           
          procedure MouseShowCursor;
          const
            ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
          var
            cMode: DWORD;
          begin
            GetConsoleMode(hConsoleInput, cMode);
            if (cMode and ShowMouseConsoleMode) <> ShowMouseConsoleMode then
            begin
              cMode := cMode or ShowMouseConsoleMode;
              SetConsoleMode(hConsoleInput, cMode);
            end;
          end;
           
          procedure MouseHideCursor;
          const
            ShowMouseConsoleMode = ENABLE_MOUSE_INPUT;
          var
            cMode: DWORD;
          begin
            GetConsoleMode(hConsoleInput, cMode);
            if (cMode and ShowMouseConsoleMode) = ShowMouseConsoleMode then
            begin
              cMode := cMode and ($FFFFFFFF xor ShowMouseConsoleMode);
              SetConsoleMode(hConsoleInput, cMode);
            end;
          end;
           
          function MouseKeyPressed: Boolean;
            {$IfDef MOUSE_IS_USED}
          const
            MouseDeltaTime = 200;
          var
            ActualTime: TDateTime;
            HourA, HourM, MinA, MinM, SecA, SecM, MSecA, MSecM: word;
            MSecTimeA, MSecTimeM: longInt;
            MSecDelta: longInt;
            {$EndIf}
          begin
            MousePressedButtons := 0;
            {$IfDef MOUSE_IS_USED}
            Result := False;
            if MouseButtonPressed then
            begin
              ActualTime := NOW;
              DecodeTime(ActualTime, HourA, MinA, SecA, MSecA);
              DecodeTime(MouseEventTime, HourM, MinM, SecM, MSecM);
              MSecTimeA := (3600 * HourA + 60 * MinA + SecA) * 100 + MSecA;
              MSecTimeM := (3600 * HourM + 60 * MinM + SecM) * 100 + MSecM;
              MSecDelta := Abs(MSecTimeM - MSecTimeA);
              if (MSecDelta < MouseDeltaTime) or (MSecDelta > (8784000 - MouseDeltaTime)) then
              begin
                MousePressedButtons := MouseLeftButton;
                MouseButtonPressed := False;
                Result := True;
              end;
            end;
            {$Else}
            Result := False;
            {$EndIf}
          end;
           
          procedure MouseGotoXY(X, Y: Integer);
          begin
            {$IfDef MOUSE_IS_USED}
            mouse_event(MOUSEEVENTF_ABSOLUTE or MOUSEEVENTF_MOVE,
              X - 1,Y - 1,WHEEL_DELTA, GetMessageExtraInfo());
            MousePosY := (Y - 1) * MouseRowWidth;
            MousePosX := (X - 1) * MouseColWidth;
            {$EndIf}
          end;
           
          function MouseWhereY: Integer;
            {$IfDef MOUSE_IS_USED}
              {Var
                lppt, lpptBuf: TMouseMovePoint;}
            {$EndIf}
          begin
            {$IfDef MOUSE_IS_USED}
                {GetMouseMovePoints(
                  SizeOf(TMouseMovePoint), lppt, lpptBuf,
                  7,GMMP_USE_DRIVER_POINTS
                );
                Result:=lpptBuf.Y DIV MouseRowWidth;}
            Result := (MousePosY div MouseRowWidth) + 1;
            {$Else}
            Result := -1;
            {$EndIf}
          end;
           
          function MouseWhereX: Integer;
            {$IfDef MOUSE_IS_USED}
              {Var
                lppt, lpptBuf: TMouseMovePoint;}
            {$EndIf}
          begin
            {$IfDef MOUSE_IS_USED}
                {GetMouseMovePoints(
                  SizeOf(TMouseMovePoint), lppt, lpptBuf,
                  7,GMMP_USE_DRIVER_POINTS
                );
                Result:=lpptBuf.X DIV MouseColWidth;}
            Result := (MousePosX div MouseColWidth) + 1;
            {$Else}
            Result := -1;
            {$EndIf}
          end;
            {  }
           
          procedure Init;
          const
            ExtInpConsoleMode = ENABLE_WINDOW_INPUT or ENABLE_PROCESSED_INPUT or ENABLE_MOUSE_INPUT;
            ExtOutConsoleMode = ENABLE_PROCESSED_OUTPUT or ENABLE_WRAP_AT_EOL_OUTPUT;
          var
            cMode: DWORD;
            Coord: TCoord;
            OSVersion: TOSVersionInfo;
            CBI: TConsoleScreenBufferInfo;
          begin
            OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfo);
            GetVersionEx(OSVersion);
            if OSVersion.dwPlatformId = VER_PLATFORM_WIN32_NT then
              IsWinNT := True
            else
              IsWinNT := False;
            PtrOpenText := TTextRec(Output).OpenFunc;
            {$IfDef HARD_CRT}
            AllocConsole;
            Reset(Input);
            hConsoleInput := GetStdHandle(STD_INPUT_HANDLE);
            TTextRec(Input).Handle := hConsoleInput;
            ReWrite(Output);
            hConsoleOutput := GetStdHandle(STD_OUTPUT_HANDLE);
            TTextRec(Output).Handle := hConsoleOutput;
            {$Else}
            Reset(Input);
            hConsoleInput := TTextRec(Input).Handle;
            ReWrite(Output);
            hConsoleOutput := TTextRec(Output).Handle;
            {$EndIf}
            GetConsoleMode(hConsoleInput, cMode);
            if (cMode and ExtInpConsoleMode) <> ExtInpConsoleMode then
            begin
              cMode := cMode or ExtInpConsoleMode;
              SetConsoleMode(hConsoleInput, cMode);
            end;
           
            TTextRec(Output).InOutFunc := @TextOut;
            TTextRec(Output).FlushFunc := @TextOut;
            GetConsoleScreenBufferInfo(hConsoleOutput, CBI);
            GetConsoleMode(hConsoleOutput, cMode);
            if (cMode and ExtOutConsoleMode) <> ExtOutConsoleMode then
            begin
              cMode := cMode or ExtOutConsoleMode;
              SetConsoleMode(hConsoleOutput, cMode);
            end;
            TextAttr  := CBI.wAttributes;
            StartAttr := CBI.wAttributes;
            LastMode  := CBI.wAttributes;
           
            Coord.X := CBI.srWindow.Left;
            Coord.Y := CBI.srWindow.Top;
            WindMin := (Coord.Y shl 8) or Coord.X;
            Coord.X := CBI.srWindow.Right;
            Coord.Y := CBI.srWindow.Bottom;
            WindMax := (Coord.Y shl 8) or Coord.X;
            ConsoleScreenRect := CBI.srWindow;
           
            SoundDuration := -1;
            OldCp := GetConsoleOutputCP;
            SetConsoleOutputCP(1250);
            {$IfDef CRT_EVENT}
            SetConsoleCtrlHandler(@ConsoleEventProc, True);
            {$EndIf}
            {$IfDef MOUSE_IS_USED}
            SetCapture(hConsoleInput);
            KeyPressed;
            {$EndIf}
            MouseInstalled := MouseReset;
            Window(1,1,80,25);
            ClrScr;
          end;
           
          {  }
           
          procedure Done;
          begin
            {$IfDef CRT_EVENT}
            SetConsoleCtrlHandler(@ConsoleEventProc, False);
            {$EndIf}
            SetConsoleOutputCP(OldCP);
            TextAttr := StartAttr;
            SetConsoleTextAttribute(hConsoleOutput, TextAttr);
            ClrScr;
            FlushInputBuffer;
            {$IfDef HARD_CRT}
            TTextRec(Input).Mode := fmClosed;
            TTextRec(Output).Mode := fmClosed;
            FreeConsole;
            {$Else}
            Close(Input);
            Close(Output);
            {$EndIf}
          end;
           
          initialization
            Init;
           
          finalization
            Done;
            {$Endif win32}
          end.
        0 пользователей читают эту тему (0 гостей и 0 скрытых пользователей)
        0 пользователей:


        Рейтинг@Mail.ru
        [ Script execution time: 0,3891 ]   [ 16 queries used ]   [ Generated: 1.10.22, 01:33 GMT ]