Current area: HOME ->

Zip File view

Dptool


This page allows you to view the contents of a file contained inside a ZIP archive available at Programmer's Heaven. This means you can view the code and find what you need from it without having to download the ZIP file first. If the file contains source code for a language we recognize, we have syntax highlighted it.

Filename displayed: CHAREDTV.PAS
Found in file: DPTOOLS.ZIP

Download: How to build a SCSI interface for the AMIGA
{
  programme de changement de font de caractere sous turbo vision
 d'apres des source trouve dans SWAG
     de MICHAEL HOENIE - Intelec Pascal Moderator.
   programme realise par
    charles vidal
    pour toutes suggestions
    email : [[Email Removed]]

 }
program Edit_char_TV;
uses Dos,Memory, Crt,MsgBox, Objects, Drivers,Views,Menus, Dialogs, App,InpLong,stddlg;

const
  cmAbout = 1000;
  cmLoad = 1001;
  cmsave = 1002;
  cmModifier = 1003;
  cmInverse = 1004;
  cmFill =1005;
  cmClear=1006;
  cmEnscar=1007;
  cmflip =1008;
  cmflop= 1009;
  cmcopie= 1010;
type
  TListboxRec = record
    PS : PStringCollection;
    Focused : Integer;
    end;
type
  TMyApp = object(TApplication)
    procedure InitMenuBar; virtual;
    procedure LoadFont;
    procedure saveasfont;
    procedure Modif_Car;
    procedure Inverse_car;
    procedure Fill_car;
    procedure clear_car;
    procedure flip_car;
    procedure flop_car;
    procedure copie_car;
    procedure HandleEvent(var Event: TEvent); virtual;
  end;
type charset = array[0..255,1..16] of byte;
var  newcharset, oldcharset : charset;
     fichier:file of charset;
     char:array[1..16] of byte;
     bingo:string;
var
  DataRecChar : record
    Field1 : Word;
    Field2 : Word;
    Field3 : Word;
    Field4 : Word;
    Field5 : Word;
    Field6 : Word;
    Field7 : Word;
    Field8 : Word;
  end;

var
  DataRec : record
    Field1 : TListBoxRec;
         end;
var
  MyApp: TMyApp;
  Cartab :record {les categories}
            Field1 : TListBoxRec;
            end;
  i:byte;
  chaine:string;
{ -------------------- fonction misc . --------------------}
procedure getoldcharset;
var
  b:byte;
  w:word;
begin
  for b := 0 to 255 do begin
    w := b * 32;
    inline($FA);
    PortW[$3C4] := $0402;
    PortW[$3C4] := $0704;
    PortW[$3CE] := $0204;
    PortW[$3CE] := $0005;
    PortW[$3CE] := $0006;
    Move(Ptr($A000, w)^, oldcharset[b,1], 16);
    PortW[$3C4] := $0302;
    PortW[$3C4] := $0304;
    PortW[$3CE] := $0004;
    PortW[$3CE] := $1005;
    PortW[$3CE] := $0E06;
    inline($FB);
  end;
end;

procedure restoreoldcharset;
var
  b:byte;
  w:word;
begin
  for b := 0 to 255 do begin
    w := b * 32;
    inline($FA);
    PortW[$3C4] := $0402;
    PortW[$3C4] := $0704;
    PortW[$3CE] := $0204;
    PortW[$3CE] := $0005;
    PortW[$3CE] := $0006;
    Move(oldcharset[b,1], Ptr($A000, w)^, 16);
    PortW[$3C4] := $0302;
    PortW[$3C4] := $0304;
    PortW[$3CE] := $0004;
    PortW[$3CE] := $1005;
    PortW[$3CE] := $0E06;
    inline($FB);
  end;
end;

procedure setasciichar(charnum : byte; var data);
var
   offset : Word;
begin
  offset := charNum * 32;
  inline($FA);
  PortW[$3C4] := $0402;
  PortW[$3C4] := $0704;
  PortW[$3CE] := $0204;
  PortW[$3CE] := $0005;
  PortW[$3CE] := $0006;
  Move(data, Ptr($A000, offset)^, 16);
  PortW[$3C4] := $0302;
  PortW[$3C4] := $0304;
  PortW[$3CE] := $0004;
  PortW[$3CE] := $1005;
  PortW[$3CE] := $0E06;
  inline($FB);
end;
function bit_a_un(a,pos:byte):Boolean;
BEGIN
 if ((a shr pos) and 1)=1 then bit_a_un:=true
    else bit_a_un:=false;
END;
procedure put_bit_a_un(var a:byte;pos:byte);
BEGIN
 a:=a or (1 shl pos);
END;
{ ------------------ les boites dialogues --------------------- }
function Ensenchar : PDialog;
var
  Dlg : PDialog;
  R : TRect;
  Control : PView;
begin
R.Assign(3, 2, 37, 12);
New(Dlg, Init(R, 'Ensenble caract?res'));
Dlg^.Flags := Dlg^.Flags {and not wfClose};

R.Assign(1, 1, 33, 9);
bingo:='';
for i:=1 to 254 do
     if (i<>13) and (i<>32) then
        bingo:=bingo+chr(i);
Control := New(PStaticText, Init(R, bingo));
Dlg^.Insert(Control);

Dlg^.SelectNext(False);
Ensenchar := Dlg;
end;
function MakeDialogC(titre:string) : PDialog;
var
  Dlg : PDialog;
  R : TRect;
  Control : PView;

begin
R.Assign(10, 2, 45, 22);
New(Dlg, Init(R, titre));

R.Assign(1, 1, 5, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('A',  NewSItem('b',  NewSItem('c ',  NewSItem('d',
  NewSItem('e',
  NewSItem('f',
  NewSItem('i',
  NewSItem('j',
  NewSItem('k',
  NewSItem('l',
  NewSItem('o',
  NewSItem('p',
  NewSItem('k',
  NewSItem('q',
  NewSItem('x', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(5, 1, 10, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a',
  NewSItem('a', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(9, 1, 14, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b',
  NewSItem('b', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(13, 1, 18, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c',
  NewSItem('c', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(17, 1, 22, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d',
  NewSItem('d', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(21, 1, 26, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e',
  NewSItem('e', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(25, 1, 30, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f',
  NewSItem('f', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(29, 1, 34, 16);
Control := New(PCheckboxes, Init(R,
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g',
  NewSItem('g', Nil)))))))))))))))));
Dlg^.Insert(Control);

R.Assign(3, 17, 13, 19);
Control := New(PButton, Init(R, 'O~k~', cmOK, bfDefault));
Dlg^.Insert(Control);

R.Assign(19, 17, 29, 19);
Control := New(PButton, Init(R, 'C~a~ncel', cmCancel, bfDefault));
Dlg^.Insert(Control);

Dlg^.SelectNext(False);
MakeDialogc:= Dlg;
end;

function MakeDialog : PDialog;
var
  Dlg : PDialog;
  R : TRect;
  Control : PView;

begin
R.Assign(47, 1, 62, 22);
New(Dlg, Init(R, ''));

R.Assign(11, 2, 12, 17);
Control := New(PScrollBar, Init(R));
Dlg^.Insert(Control);

R.Assign(3, 2, 11, 17);
Control := New(PListBox, Init(R, 1, PScrollbar(Control)));
Dlg^.Insert(Control);

  R.Assign(2, 1, 13, 2);
  Dlg^.Insert(New(PLabel, Init(R, 'caracteres', Control)));

R.Assign(3, 18, 13, 20);
Control := New(PButton, Init(R, 'O~k~', cmOK, bfDefault));
Dlg^.Insert(Control);

Dlg^.SelectNext(False);
MakeDialog := Dlg;
end;
{---------------------------------------}
procedure TMyApp.LoadFont;
var
  R: TRect;
  FileDialog: PFileDialog;
  TheFile: FNameStr;
  b:byte;
const
  FDOptions: Word = fdOKButton or fdOpenButton;
begin
  TheFile := '*.FNT';
  New(FileDialog, Init(TheFile, 'Open file', '~F~ile name',
    FDOptions, 1));
  if ExecuteDialog(FileDialog, @TheFile) <> cmCancel then
  begin
   assign(Fichier,TheFile);
   reset(Fichier);
   read(Fichier,newcharset);
   close(fichier);
     for b := 0 to 255 do setasciichar(b,newcharset[b,1]);
  end;
end;
procedure TMyApp.saveasFont;
var
  R: TRect;
  FileDialog: PFileDialog;
  TheFile: FNameStr;
const
  FDOptions: Word = fdOKButton or fdOpenButton;
begin
  TheFile := '*.FNT';
  New(FileDialog, Init(TheFile, 'Save file', '~F~ile name',
    FDOptions, 1));
  if ExecuteDialog(FileDialog, @TheFile) <> cmCancel then
  begin
   assign(Fichier,TheFile);
   rewrite(Fichier);
   write(Fichier,newcharset);
   close(fichier);
  end;
end;

procedure TMyApp.Modif_car;
var j:byte;
    k:word;
    b:byte;
    tempo:string;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  with Datarecchar do
   begin
    field1:=0;field2:=0;field3:=0;field4:=0;field5:=0;field6:=0;field7:=0;field8:=0;
    end;
    for i:=1 to 16 do
    begin
    for j:=0 to 7 do
    if ((newcharset[CarTab.Field1.focused+1][i] shl j) and 128) <> 0 then
    begin
     k:=1 shl (i-1) ;
     with Datarecchar do
     begin
      case j of
       0:field1:=field1 or k;
       1:field2:=field2 or k;
       2:field3:=field3 or k;
       3:field4:=field4 or k;
       4:field5:=field5 or k;
       5:field6:=field6 or k;
       6:field7:=field7 or k;
       7:field8:=field8 or k;
       end;
      end;
     end;
 end;
  str(CarTab.Field1.focused+1,tempo);
  if Application^.ExecuteDialog(MakeDialogC('Caractere :'+tempo),@Datarecchar) = cmOk then
  begin
   for i:=1 to 16 do
   begin
   k:=0;
   newcharset[CarTab.Field1.focused+1][i]:=0;
   for j:=0 to 7 do
   begin
    with Datarecchar do begin
      case j of
       0:if ((field1 shr (i-1)) and 1)=1 then k:=128;
       1:if ((field2 shr (i-1)) and 1)=1 then k:=64;
       2:if ((field3 shr (i-1)) and 1)=1 then k:=32;
       3:if ((field4 shr (i-1)) and 1)=1 then k:=16;
       4:if ((field5 shr (i-1)) and 1)=1 then k:=8;
       5:if ((field6 shr (i-1)) and 1)=1 then k:=4;
       6:if ((field7 shr (i-1)) and 1)=1 then k:=2;
       7:if ((field8 shr (i-1)) and 1)=1 then k:=1;
       end;
      newcharset[CarTab.Field1.focused+1][i]:=
         newcharset[CarTab.Field1.focused+1][i] or k;
     end;
   end;
  end;
 end;
end;
setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
end;
procedure TMyApp.Inverse_car;
var j:byte;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  for j:=1 to 16 do
  newcharset[CarTab.Field1.focused+1][j]:=
          newcharset[CarTab.Field1.focused+1][j] xor 255;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;
procedure TMyApp.Copie_car;
var j:byte;
    k:word;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  k:=CarTab.Field1.focused+1;
  if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
  begin
  for j:=1 to 16 do
  newcharset[CarTab.Field1.focused+1][j]:=newcharset[k][j];
  end;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;

procedure TMyApp.Clear_car;
var j:byte;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  for j:=1 to 16 do
  newcharset[CarTab.Field1.focused+1][j]:=0;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;
procedure TMyApp.Fill_car;
var j:byte;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  for j:=1 to 16 do
  newcharset[CarTab.Field1.focused+1][j]:=255;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;
procedure TMyApp.flip_car;
var j,k,tempo:byte;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  for j:=1 to 16 do
   begin
    tempo:=0;
    for k:=0 to 7 do
     begin
     if (bit_a_un(newcharset[CarTab.Field1.focused+1][j],k)) then
      put_bit_a_un(tempo,7-k);
     end;
   newcharset[CarTab.Field1.focused+1][j]:=tempo;
   end;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;
procedure TMyApp.flop_car;
var j,tempo:byte;
begin
if Application^.ExecuteDialog(MakeDialog,@Cartab) = cmOk then
 begin
  for j:=1 to 8 do
  begin
  tempo:=newcharset[CarTab.Field1.focused+1][j];
  newcharset[CarTab.Field1.focused+1][j]:=newcharset[CarTab.Field1.focused+1][17-j];
  newcharset[CarTab.Field1.focused+1][17-j]:=tempo;
  end;
 setasciichar(CarTab.Field1.focused+1,newcharset[CarTab.Field1.focused+1,1]);
 end;
end;

procedure TMyApp.HandleEvent(var Event: TEvent);
begin
TApplication.HandleEvent(Event);
case Event.What of
    evCommand:
      case Event.Command of
       cmabout:
        messagebox('         Char Edit                charles vidal 1994      [[Email Removed]]'
            ,nil,mfinformation);
       cmModifier:Modif_car;
       cmsave:saveasfont;
       cmload:loadfont;
       cmEnscar:
       MyApp.execview(Ensenchar);
       cmInverse:Inverse_car;
       cmFill:Fill_car;
       cmClear:Clear_car;
       cmFlip:flip_car;
       cmFlop:flop_car;
       cmcopie:copie_car;
      end;
    end;
ClearEvent(Event);
end;

Procedure TMyApp.InitMenuBar;
var
  R : TRect;

begin
  GetExtent(R);
  R.B.Y := R.A.Y + 1;

  MenuBar := New(PMenuBar, Init(R, NewMenu(
    NewSubMenu('#',hcNoContext,
    NewMenu(
      NewItem('About', '', kbNoKey, cmAbout, hcNoContext,
      NewItem('Ensenble caracteres', '', kbNoKey, cmEnscar, hcNoContext,
      nil))),
    NewSubMenu('~F~ile',hcNoContext,
    NewMenu(
      NewItem('Load', '', kbNoKey, cmLoad, hcNoContext,
      NewItem('save', '', kbNoKey, cmsave, hcNoContext,
      NewItem('~Q~uitter', '', kbNoKey, cmQuit, hcNoContext,
      nil)))),
    NewItem('~M~odifier', '', kbNoKey, cmModifier, hcNoContext,
    NewSubMenu('~E~ffect',hcNoContext,
    NewMenu(
      NewItem('Inverse', '', kbNoKey, cmInverse, hcNoContext,
      NewItem('Fill', '', kbNoKey, cmFill, hcNoContext,
      NewItem('Clear', '', kbNoKey, cmClear, hcNoContext,
      NewItem('Flip', '', kbNoKey, cmFlip, hcNoContext,
      NewItem('Flop', '', kbNoKey, cmFlop, hcNoContext,
      NewItem('copie', '', kbNoKey, cmcopie, hcNoContext,
    nil))))))),
    nil)))))
  ));
end;

begin
  getoldcharset;
  newcharset:=oldcharset;
  Cartab.field1.PS:=New(PstringCollection, Init(10,5));
  bingo:='';
  for i:=1 to 254 do
     if (i<>13) and (i<>32) then
        bingo:=bingo+chr(i);
  for i:=0 to 255 do Begin
                     str(i,chaine);
                     Cartab.field1.PS^.insert(newstr(chr(i)+':'+chaine));
                     End;
  Cartab.field1.PS^.atfree(0);
  MyApp.Init;
  MyApp.Run;
  MyApp.Done;
  restoreoldcharset;
end.


TMS32010 ADPCM source

 TScale Ver 0.9 for Delphi 2.0
TScale Component to scale your Form at different Screen Resolutions.
 How to build a SCSI interface for the AMIGA
Download TMS32010 ADPCM source Download TScale Ver 0.9 for Delphi 2.0 TScale Component to scale your Form at different Screen Resolutions. Download How to build a SCSI interface for the AMIGA







Sponsored links

Six Sigma Certification
100% Online-Six Sigma Certificate from Villanova - Find Out More Now.
Localize software in three simple steps
Localize .Net, C/C++ & Delphi apps visually. HTML, HTML Help, XML & databases. Try Sisulizer now!
Localize Delphi software in three simple steps
Localize Delphi VCL & .Net apps visually. Plus HTML, HTML Help, XML & databases. Try Sisulizer now!
Web based bug tracking - AdminiTrack.com
AdminiTrack offers an effective web-based bug tracking system designed for professional software development teams.
Computer Professionals: Are you owed Overtime?
Federal and State Laws may allow computer professionals to collect overtime. Our law firm is experienced, and has initiated class action lawsuits against some of the largest computer companies to collect back pay and overtime. Strictly Confidential.
Buy a link now

Members






Register
Why register?
Forgot Password?

Blogs new Blog section
Jobs
Webtools
Message Boards
FAQ
CodePedia
Free Magazines
User search
What's New
Top lists
RSS Feeds RSS Feeds

Submit content
Contact Us
Link To Us
Help



Advanced Search

Newsletter




More information


Newsletter | Submit Content | About | Advertising | Awards | Contact Us | Link to us |
© 1996-2008 Community Networks Ltd All rights reserved. Reproduction in whole or in part, in any form or medium without express written permission is prohibited. Violators of this policy may be subject to legal action. Please read Terms Of Use and Privacy Statement for more information. Development by Synchron Data - .NET development.