Autor |
Beitrag |
Gothicware
Beiträge: 77
Win 98, Win 2000, Win XP, BeOs-R5, Zeta 1.0(war nicht gut, also verkauft), KnoppiX, VM-Ware
D4 Client/Server, Turbo Basic, QBasic, Atari-Basic
|
Verfasst: Fr 11.02.05 00:28
Unit Console32.pas
Hey Delphianner,
Gestern, ist mir wiedermal mein alter QBasic Kramm in die Händegefallen,
und ich besinnte mich auf die guten alten Zeiten. Kurzer Hand, wie sich das für ein Delphianner gehört, gleich mal bisschen rum probieren mit Delphi. Hab dann bei mir auf der Platte nen Code gefunden, denn ich Irgentwo aus dem DelphiForum mal gefunden hatte. (Wenn jemanden einige Codeschnippsel bekannt vorkommen sollte, Bitte bei mir melden).
Hab dann Einiges rausgenommen, hinzugefügt, verbessert. Und Arbeite jetzt dran, eine sehr nützliche Unit zuerstellen.
Suche dringend Hilfe zu:
- Umgang, und Einbinndung der Maus in der Konsole
- Grafisches Zeichnen in der Konsole (muss doch hoffentlich möglich sein)
- Auf Tastendruck reagieren, ohne Programm lahm(pausieren) zulegen
Einige Funktion laufen nicht flüssig, oder so wie Sie es sollten unter W2K,
sollten aber zwischen 95 bis ME laufen.
Hier der Code:
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33: 34: 35: 36: 37: 38: 39: 40: 41: 42: 43: 44: 45: 46: 47: 48: 49: 50: 51: 52: 53: 54: 55: 56: 57: 58: 59: 60: 61: 62: 63: 64: 65: 66: 67: 68: 69: 70: 71: 72: 73: 74: 75: 76: 77: 78: 79: 80: 81: 82: 83: 84: 85: 86: 87: 88: 89: 90: 91: 92: 93: 94: 95: 96: 97: 98: 99: 100: 101: 102: 103: 104: 105: 106: 107: 108: 109: 110: 111: 112: 113: 114: 115: 116: 117: 118: 119: 120: 121: 122: 123: 124: 125: 126: 127: 128: 129: 130: 131: 132: 133: 134: 135: 136: 137: 138: 139: 140: 141: 142: 143: 144: 145: 146: 147: 148: 149: 150: 151: 152: 153: 154: 155: 156: 157: 158: 159: 160: 161: 162: 163: 164: 165: 166: 167: 168: 169: 170: 171: 172: 173: 174: 175: 176: 177: 178: 179: 180: 181: 182: 183: 184: 185: 186: 187: 188: 189: 190: 191: 192: 193: 194: 195: 196: 197: 198: 199: 200: 201: 202: 203: 204: 205: 206: 207: 208: 209: 210: 211: 212: 213: 214: 215: 216: 217: 218: 219: 220: 221: 222: 223: 224: 225: 226: 227: 228: 229: 230: 231: 232: 233:
| unit Console32;
{$WEAKPACKAGEUNIT}
interface
uses SysUtils, Classes, Windows;
const FG_STANDARD = $007; FG_BLACK = $000; FG_DARKBLUE = $001; FG_DARKGREEN = $002; FG_WEIRDBLUE = $003; FG_RED = $004; FG_ROSA = $005; FG_BROWN = $006; FG_LITEGRAY = $007; FG_DARKGRAY = $008; FG_BLUE = $009; FG_GREEN = $00A; FG_LITEBLUE = $00B; FG_LITERED = $00C; FG_LITEROSA = $00D; FG_YELLOW = $00E; FG_WHITE = $00F;
BG_STANDARD = $000; BG_BLACK = $000; BG_DARKBLUE = $010; BG_DKGREEN = $020; BG_WEIRDBLUE = $030; BG_RED = $040; BG_ROSA = $050; BG_BROWN = $060; BG_LITEGRAY = $070; BG_DARKGRAY = $080; BG_BLUE = $090; BG_GREEN = $0A0; BG_LITEBLUE = $0B0; BG_LITERED = $0C0; BG_LITEROSA = $0D0; BG_YELLOW = $0E0; BG_WHITE = $0F0;
procedure Clear; stdcall; procedure PaintLine(row: Integer; color: dword; char: char); stdcall; procedure SetCurPos(column,row:Integer); stdcall; function GetCurPos:Coord; stdcall; procedure SetColor(color:dword); stdcall; function GetColor:dword; stdcall; procedure SetCodepage(Codepage:dword); stdcall; function GetCodepage:dword; stdcall; procedure SetTitle(title:string); stdcall; function GetTitle:string; stdcall; procedure SetCurDir(Directory:string); stdcall; function GetCurDir:string; stdcall; procedure TextOut(column,row: integer; color: dword; text: string); stdcall; procedure TextOutLeft(row: integer; color: dword; text: string); stdcall; procedure TextOutCenter(row: integer; color: dword; text: string); stdcall; procedure TextOutRight(row: integer; color: dword; text: string); stdcall; function KeyPressed: boolean; stdcall; function ReadKey: Char; stdcall;
implementation
procedure Clear; var hConsole: THandle; coordScreen: Coord; bSuccess: boolean; cCharsWritten: dword; csbi: CONSOLE_SCREEN_BUFFER_INFO; dwConSize: dword; begin coordScreen.X := 0; coordScreen.Y := 0; hConsole := GetStdHandle(STD_OUTPUT_HANDLE); bSuccess := GetConsoleScreenBufferInfo(hConsole, csbi); dwConSize := csbi.dwSize.X * csbi.dwSize.Y; bSuccess := FillConsoleOutputCharacter(hConsole, ' ', dwConSize, coordScreen, cCharsWritten); bSuccess := GetConsoleScreenBufferInfo(hConsole, csbi); bSuccess := FillConsoleOutputAttribute(hConsole, csbi.wAttributes, dwConSize, coordScreen, cCharsWritten); bSuccess := SetConsoleCursorPosition(hConsole, coordScreen); end;
procedure PaintLine(row: Integer; color: dword; char: char); var oldcolor: dword; i: Integer; begin oldcolor:= getcolor; for i := 0 to 79 do TextOut(i,row,color,char); setcolor(oldcolor); end;
procedure SetCurPos(column,row:Integer); var coordScreen: Coord; begin coordScreen.X := column; coordScreen.Y := row; SetConsoleCursorPosition(GetStdHandle(STD_OUTPUT_HANDLE), coordScreen); end;
function GetCurPos:Coord; var csbi: CONSOLE_SCREEN_BUFFER_INFO; coordScreen: Coord; begin if GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),csbi) then coordScreen := csbi.dwCursorPosition; end;
procedure SetColor(color: dword); begin SetConsoleTextAttribute(GetStdHandle(STD_OUTPUT_HANDLE), color); end;
function GetColor: dWord; var csbi: CONSOLE_SCREEN_BUFFER_INFO; begin if GetConsoleScreenBufferInfo(GetStdHandle(STD_OUTPUT_HANDLE),csbi) then result := csbi.wAttributes; end;
procedure SetCodepage(Codepage: dword); begin SetConsoleCP(Codepage); end;
function GetCodepage:dword; begin result := GetConsoleCP; end;
procedure SetTitle(title: string); begin SetConsoleTitle(PChar(title)); end;
function GetTitle:string; begin GetConsoleTitle(PChar(result),255); end;
procedure SetCurDir(directory :string); begin SetCurrentDirectory(PChar(directory)); end;
function GetCurDir:string; begin GetCurrentDirectory(255,PChar(result)); end;
procedure TextOut(column,row: integer; color: dword; text: string); var oldcolor: dword; begin oldcolor := GetColor; SetCurPos(column,row); SetColor(color); Write(text); SetColor(oldcolor); end;
procedure TextOutLeft(row: integer; color: dword; text: string); var oldcolor: dword; begin oldcolor := GetColor; SetCurPos(0,row); SetColor(color); WriteLn(text); SetCurPos(0,row+1); SetColor(oldColor); end;
procedure TextOutCenter(row: integer; color: dword; text: string); var oldcolor: dword; begin oldcolor := GetColor; SetCurPos(39-(Length(text) div 2),row); SetColor(color); WriteLn(text); SetCurPos(0,row+1); SetColor(oldColor); end;
procedure TextOutRight(row: integer; color: dword; text: string); var oldcolor: dword; begin oldcolor := GetColor; SetCurPos(79-(Length(text)),row); SetColor(color); WriteLn(text); SetCurPos(0,row+1); SetColor(oldcolor); end;
function KeyPressed: boolean; var NumberOfEvents: Cardinal; begin GetNumberOfConsoleInputEvents(GetStdHandle(STD_INPUT_HANDLE), NumberOfEvents); result := NumberOfEvents > 0; end;
function ReadKey: Char; var NumRead: Cardinal; InputRec: TInputRecord; begin while ((not ReadConsoleInput(GetStdHandle(STD_INPUT_HANDLE), InputRec, 1, NumRead)) or (InputRec.EventType <> KEY_EVENT)) do ; Result := InputRec.Event.KeyEvent.AsciiChar; end;
end. |
Beispiel Anwendung:
1: 2: 3: 4: 5: 6: 7: 8: 9: 10: 11: 12: 13: 14: 15: 16: 17: 18: 19: 20: 21: 22: 23: 24: 25: 26: 27: 28: 29: 30: 31: 32: 33:
| program Console;
{$APPTYPE CONSOLE}
uses SysUtils, Classes, Windows, Console32;
var inputstr:string; begin Clear; SetTitle('Console Test - Gothicware, Inc.'); PaintLine(0,FG_YELLOW xor BG_RED,' '); TextOutCenter(0,FG_YELLOW xor BG_RED,'Welcome to Console Test Ultil'); TextOut(0,2,FG_GREEN,' CodePage: '); TextOut(GetCurPos.x,2,FG_YELLOW,IntToStr(GetCodepage)); SetColor(FG_STANDARD); TextOut(0,24,FG_STANDARD,GetCurDir); while Ord(ReadKey) <> 27 do begin Readln; Clear; SetTitle('Console Test - Gothicware, Inc.'); PaintLine(0,FG_YELLOW xor BG_RED,' '); TextOutCenter(0,FG_YELLOW xor BG_RED,'Welcome to Console Test Ultil'); TextOut(0,2,FG_GREEN,' CodePage: '); TextOut(GetCurPos.x,2,FG_YELLOW,IntToStr(GetCodepage)); SetColor(FG_STANDARD); TextOut(0,24,FG_STANDARD,GetCurDir); end; end. |
[highlight]
Viel Spass damit und Viele Grüsse,
Gothicware[/highlight]
|
|
retnyg
Beiträge: 2754
SNES, GB, GBA, CPC, A500, 486/66, P4/3.0HT: NintendOS, AmigaOS, DoS
Delphi 5, Delphi 7
|
Verfasst: Fr 11.02.05 05:13
wäre nett wenn du auch noch beschreibst was das programm macht. nicht jeder nimmt sich die zeit den source durchzulesen, so wie ich.
edit: OPENSOUCURE ? ein neuer sicherheitsstandard ?
edit2: "the therms of the GNU" - ne badeanstalt der huftiere ?
sorry das musste raus =)
Zuletzt bearbeitet von retnyg am Fr 11.02.05 06:57, insgesamt 1-mal bearbeitet
|
|
Luckie
Ehemaliges Mitglied
Erhaltene Danke: 1
|
Verfasst: Fr 11.02.05 06:52
Erstmal ist das ganze schlecht formatiert. Wenn man etwas veröffentlich mit Quellcode, sollte man sich zu mindest etwas an die offiziellen von Borland veröffentlichten Standards halten.
Zweitens: Warum sind die Funktionen und Prozeduren im Interfaceabschnitt alle als stdacll deklariert? Sie werden doch aus keiner DLL importiert oder exportiert. Delphi nutzt standardmäßig die performantere Register Aufrufkonvention. Hat es einen Grund dies auf stdcall umzubiegen? ich fareg mich, ob das überhaupt Sinn macht bzw. irgendwelche Einflüsse auf den Code hat.
Drittens: Wozu wird die Unit Classes eingebunden? beim schnellen überfliegen des Codes habe ich nichts gefunden, was die Unit Classes bräuchte. Der Code besteht aus reinem API und Pascal-System aufrufen (WriteLn zum Beispiel). Auf die Unit SysUtils könnte man bestimmt auch verzichten.
|
|
Gast
Gast
Erhaltene Danke: 1
|
Verfasst: Sa 12.02.05 12:40
Gothicware hat folgendes geschrieben: | Hab dann bei mir auf der Platte nen Code gefunden, denn ich Irgentwo aus dem DelphiForum mal gefunden hatte. (Wenn jemanden einige Codeschnippsel bekannt vorkommen sollte, Bitte bei mir melden). |
Bedenklicher finde ich, daß man fremden Code nimmt, modifiziert und unter eigenes Copyright und eigene Lizenz stellt.
|
|
AXMD
Beiträge: 4006
Erhaltene Danke: 7
Windows 10 64 bit
C# (Visual Studio 2019 Express)
|
Verfasst: Sa 12.02.05 14:40
Assarbad hat folgendes geschrieben: | Gothicware hat folgendes geschrieben: | Hab dann bei mir auf der Platte nen Code gefunden, denn ich Irgentwo aus dem DelphiForum mal gefunden hatte. (Wenn jemanden einige Codeschnippsel bekannt vorkommen sollte, Bitte bei mir melden). | Bedenklicher finde ich, daß man fremden Code nimmt, modifiziert und unter eigenes Copyright und eigene Lizenz stellt. |
Find ich auch, die Unit kommt mir nämlich - bis auf die retnyg hat folgendes geschrieben: | badeanstalt der huftiere |
( ) - sehr bekannt vor.
@Gothicware: deine !-Taste ist kaputt, EDIT-Funktion verwenden!
AXMD
|
|
Gast
Gast
Erhaltene Danke: 1
|
Verfasst: Sa 12.02.05 15:15
AXMD hat folgendes geschrieben: | Find ich auch, die Unit kommt mir nämlich - bis auf die retnyg hat folgendes geschrieben: | badeanstalt der huftiere | () - sehr bekannt vor. |
[OT]Von dir?[/OT] ... wenn du mindestens den Urheber kennst, schreib ihn doch mal an, oder nenne Gothicware den ursprünglichen Autor.
|
|
AXMD
Beiträge: 4006
Erhaltene Danke: 7
Windows 10 64 bit
C# (Visual Studio 2019 Express)
|
Verfasst: Sa 12.02.05 20:29
Assarbad hat folgendes geschrieben: | AXMD hat folgendes geschrieben: | Find ich auch, die Unit kommt mir nämlich - bis auf die retnyg hat folgendes geschrieben: | badeanstalt der huftiere | () - sehr bekannt vor. | [OT]Von dir?[/OT] ... wenn du mindestens den Urheber kennst, schreib ihn doch mal an, oder nenne Gothicware den ursprünglichen Autor. |
Dummerweise hab ich die Unit nicht mehr; hab sie mal in einem älteren Projekt eingesetzt und weiß, dass Sie - unter Garantie - ein anderes Copyright hat; das Projekt ist schon ein zwei Jahre her, und das Copyright war bestimmt nicht 2005, sondern 2001 oder 2002
@Gothicware: es ist strafbar, anderer Leute Code zu kopieren und unter eigenem Copyright veröffentlichen. Das sieht nicht einmal die <ironie> GNU-Therme </ironie> vor...
AXMD
|
|
JayEff
Beiträge: 2971
Windows Vista Ultimate
D7 Enterprise
|
Verfasst: Mi 11.05.05 16:50
wie auch immer, die find ich praktisch. ich werd sie mal speichern...
_________________ >+++[>+++[>++++++++<-]<-]<++++[>++++[>>>+++++++<<<-]<-]<<++
[>++[>++[>>++++<<-]<-]<-]>>>>>++++++++++++++++++.+++++++.>++.-.<<.>>--.<+++++..<+.
|
|
Grendel
Beiträge: 443
Gentoo Linux, MacOS X, Win 2000
D5 Ent, D7 Ent, Lazarus, Anjuta, MonoDevelop
|
Verfasst: Mi 11.05.05 17:05
Ist das ganze jetzt GPL oder LGPL?
btw: (L)GPL lizensiertes ist "FREE SOFTWARE" und nicht bloß "OPENSOURCE".
Bis neulich ...
|
|
JayEff
Beiträge: 2971
Windows Vista Ultimate
D7 Enterprise
|
Verfasst: Mi 18.05.05 21:07
BUG ENTDECKT!!!
"TextCenterOut" wird auch in der Unit Windows.pas deklariert, worauf hin man UNBEDINGT die console32 HINTER der Windows in die uses schreiben muss! Das ist schlecht, ich würde das beheben (z.B. name ändern.)
_________________ >+++[>+++[>++++++++<-]<-]<++++[>++++[>>>+++++++<<<-]<-]<<++
[>++[>++[>>++++<<-]<-]<-]>>>>>++++++++++++++++++.+++++++.>++.-.<<.>>--.<+++++..<+.
|
|
|