Преобразование PAS-файла в HTML-файл

Советы » Другое » Преобразование PAS-файла в HTML-файл

unit

Convert; interface

uses

Classes, NewParse; type

KeywordType = (ktPascal, ktDfm); TCodeParser = class

(TNewParser) public

constructor

Create (SSource, SDest: TStream); procedure

SetKeywordType (Kt: KeywordType); // conversion procedure

Convert; protected

// virtual methods (mostly virtual abstract) procedure

BeforeString; virtual

; abstract

; procedure

AfterString; virtual

; abstract

; procedure

BeforeKeyword; virtual

; abstract

; procedure

AfterKeyword; virtual

; abstract

; procedure

BeforeComment; virtual

; abstract

; procedure

AfterComment; virtual

; abstract

; procedure

InitFile; virtual

; abstract

; procedure

EndFile; virtual

; abstract

; function

CheckSpecialToken (Ch1: char): string

; virtual

; function

MakeStringLegal (S: String

): string

; virtual

; function

MakeCommentLegal (S: String

): string

; virtual

; protected

Source, Dest: TStream; OutStr: string

; FKeywords: TStrings; Line, Pos: Integer; end

; THtmlParser = class

(TCodeParser) public

FileName: string

; Copyright: string

; Alone: Boolean; procedure

AddFileHeader (FileName: string

); class

function

HtmlHead (Filename: string

): string

; class

function

HtmlTail (Copyright: string

): string

; protected

// virtual methods procedure

BeforeString; override

; procedure

AfterString; override

; procedure

BeforeKeyword; override

; procedure

AfterKeyword; override

; procedure

BeforeComment; override

; procedure

AfterComment; override

; procedure

InitFile; override

; procedure

EndFile; override

; function

CheckSpecialToken (Ch1: char): string

; override

; end

; // functions to be used by a Wizard function

OpenProjectToHTML (Filename, Copyright: string

): string

; function

CurrProjectToHTML (Copyright: string

): string

; implementation

uses

ExptIntf, SysUtils, ToolIntf; var

PascalKeywords: TStrings; DfmKeywords: TStrings; const

Quote = ''''; //////////// class TCodeParser //////////// constructor

TCodeParser.Create (SSource, SDest: TStream); begin

inherited

Create (SSource); Source := SSource; Dest := SDest; SetLength (OutStr, 10000); OutStr := ''; FKeywords := PascalKeywords; end

; procedure

TCodeParser.SetKeywordType (Kt: KeywordType); begin

case

Kt of

ktPascal: FKeywords := PascalKeywords; ktDfm: FKeywords := DfmKeywords; else

raise

Exception.Create ('Undefined keywords type'); end

; end

; procedure

TCodeParser.Convert; begin

InitFile; // virtual Line := 1; Pos := 0; // parse the entire source file while

Token <> toEOF do

begin

// if the source code line has changed, // add the proper newline character while

SourceLine > Line do

begin

AppendStr (OutStr, #13#10); Inc (Line); Pos := Pos + 2; // 2 characters, cr+lf end

; // add proper white spaces (formatting) while

SourcePos > Pos do

begin

AppendStr (OutStr, ' '); Inc (Pos); end

; // check the token case

Token of

toSymbol: begin

// if the token is not a keyword if

FKeywords.IndexOf (TokenString) < 0 then

// add the plain token AppendStr (OutStr, TokenString) else

begin

BeforeKeyword; // virtual AppendStr (OutStr, TokenString); AfterKeyword; // virtual end

; end

; toString: begin

BeforeString; // virtual if

(Length (TokenString) = 1) and

(Ord (TokenString [1]) < 32) then

begin

AppendStr (OutStr, '#' + IntToStr (Ord (TokenString [1]))); if

Ord (TokenString [1]) < 10 then

Pos := Pos + 1 else

Pos := Pos + 2; end

else

begin

AppendStr (OutStr, MakeStringLegal (TokenString)); Pos := Pos + 2; // 2 x hypen end

; AfterString; // virtual end

; toInteger: AppendStr (OutStr, TokenString); toFloat: AppendStr (OutStr, TokenString); toComment: begin

BeforeComment; // virtual AppendStr (OutStr, MakeCommentLegal (TokenString)); AfterComment; // virtual end

; else

// any other token AppendStr (OutStr, CheckSpecialToken (Token)); end

; // case Token of // increase the current position Pos := Pos + Length (TokenString); // move to the next token NextToken; end

; // while Token <> toEOF do // add final code EndFile; // virtual // add the string to the stream Dest.WriteBuffer (Pointer(OutStr)^, Length (OutStr)); end

; function

TCodeParser.CheckSpecialToken (Ch1: char): string

; begin

Result := Ch1; // do nothing end

; function

TCodeParser.MakeStringLegal (S: String

): string

; var

I: Integer; begin

if

Length (S) < 1 then

begin

Result := Quote + Quote; Exit; end

; // if the first character is not special, // add the open quote if

S[1] > #31 then

Result := Quote else

Result := ''; // for each character of the string for

I := 1 to

Length (S) do

case

S [I] of

// quotes must be doubled Quote: begin

AppendStr (Result, Quote + Quote); Pos := Pos + 1; end

; // special characters (characters below the value 32) #0..#31: begin

Pos := Pos + Length (IntToStr (Ord (S[I]))); // if preceeding characters are plain ones, // close the string if

(I > 1) and

(S[I-1] > #31) then

AppendStr (Result, Quote); // add the special character AppendStr (Result, '#' + IntToStr (Ord (S[I]))); // if the following characters are plain ones, // open the string if

(I < Length (S) - 1) and

(S[I+1] > #31) then

AppendStr (Result, Quote); end

; else

AppendStr (Result, CheckSpecialToken(S[I])); end

; // if the last character was not special, // add closing quote if

(S[Length (S)] > #31) then

AppendStr (Result, Quote); end

; function

TCodeParser.MakeCommentLegal (S: String

): string

; var

I: Integer; begin

Result := ''; // for each character of the string for

I := 1 to

Length (S) do

AppendStr (Result, CheckSpecialToken(S[I])); end

; //////////// class THtmlParser //////////// procedure

THtmlParser.InitFile; begin

if

Alone then

AppendStr (OutStr, HtmlHead (Filename)); AddFileHeader (Filename); AppendStr (OutStr, '<PRE>'#13#10); end

; procedure

THtmlParser.EndFile; begin

AppendStr (OutStr, '</PRE>'); if

Alone then

AppendStr (OutStr, HtmlTail (Copyright)) else

AppendStr (OutStr, #13#10'<HR>'#13#10#13#10); // separator end

; procedure

THtmlParser.BeforeComment; begin

AppendStr (OutStr, '<FONT COLOR="#000080"><I>'); end

; procedure

THtmlParser.AfterComment; begin

AppendStr (OutStr, '</I></FONT>'); end

; procedure

THtmlParser.BeforeKeyword; begin

AppendStr (OutStr, '<B>'); end

; procedure

THtmlParser.AfterKeyword; begin

AppendStr (OutStr, '</B>'); end

; procedure

THtmlParser.BeforeString; begin

// no special style... end

; procedure

THtmlParser.AfterString; begin

// no special style... end

; function

THtmlParser.CheckSpecialToken (Ch1: char): string

; begin

case

Ch1 of

'<': Result := '&lt;'; '>': Result := '&gt;'; '&': Result := '&amp;'; '"': Result := '&quot;'; else

Result := Ch1; end

; end

; procedure

THtmlParser.AddFileHeader (FileName: string

); var

FName: string

; begin

FName := Uppercase (ExtractFilename (FileName)); AppendStr (OutStr, Format ( '<A NAME=%s><H3>%s</H3></A>' + #13#10+#13#10, [FName, FName])); end

; class

function

THtmlParser.HtmlHead (Filename: string

): string

; begin

Result := '<HTML><HEAD>' + #13#10+ '<TITLE>File: ' + ExtractFileName(Filename) + '</TITLE>' + #13#10+ '<META NAME="GENERATOR" CONTENT="PasToWeb[Marco Cantщ]">'#13#10 + '</HEAD>'#13#10 + '<BODY BGCOLOR="#FFFFFF">'#13#10; end

; class

function

THtmlParser.HtmlTail (Copyright: string

): string

; begin

Result := '<HR><CENTER<I>Generated by PasToWeb,' + ' a tool by Marco Cant&ugrave;.<P>' + #13#10+ Copyright + '</CENTER></I>'#13#10 + '</BODY> </HTML>'; end

; // code for the HTML Wizard function

OpenProjectToHTML (Filename, Copyright: string

): string

; begin

// open the project and get the lists... ToolServices.OpenProject (FileName); Result := CurrProjectToHTML (Copyright); end

; function

CurrProjectToHTML (Copyright: string

): string

; var

Dest, Source, BinSource: TStream; HTML, FileName, Ext, FName: string

; I: Integer; Parser: THtmlParser; begin

// initialize FileName := ToolServices.GetProjectName; Result := ChangeFileExt (FileName, '_dpr') + '.htm'; Dest := TFileStream.Create (Result, fmCreate or

fmOpenWrite); try

// add head HTML := '<HTML><HEAD>' + #13#10+ '<TITLE>Project: ' + ExtractFileName (Filename) + '</TITLE>' + #13#10+ '<META NAME="GENERATOR" CONTENT="PasToHTML[Marco Cantщ]">' + #13#10+ '</HEAD>'#13#10 + '<BODY BGCOLOR="#FFFFFF">'#13#10 + '<H1><CENTER>Project: ' + FileName + '</CENTER></H1><BR><BR><HR>'#13#10; AppendStr (HTML, '<UL>'#13#10); // units list for

I := 0 to

ToolServices.GetUnitCount - 1 do

begin

Ext := Uppercase (ExtractFileExt( ToolServices.GetUnitName(I))); FName := Uppercase (ExtractFilename ( ToolServices.GetUnitName(I))); if

(Ext <> '.RES') and

(Ext <> '.DOF') then

AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' + FName + '</A>'#13#10); end

; // forms list for

I := 0 to

ToolServices.GetFormCount - 1 do

begin

FName := Uppercase (ExtractFilename ( ToolServices.GetFormName(I))); AppendStr (HTML, '<LI> <A HREF=#' + FName + '> ' + FName + '</A>'#13#10); end

; AppendStr (HTML, '</UL>'#13#10); AppendStr (HTML, '<HR>'#13#10); // add the HTML string to the output buffer Dest.WriteBuffer (Pointer(HTML)^, Length (HTML)); // generate the HTML code for the units for

I := 0 to

ToolServices.GetUnitCount - 1 do

begin

Ext := Uppercase (ExtractFileExt( ToolServices.GetUnitName(I))); if

(Ext <> '.RES') and

(Ext <> '.DOF') then

begin

Source := TFileStream.Create ( ToolServices.GetUnitName(I), fmOpenRead); Parser := THtmlParser.Create (Source, Dest); try

Parser.Alone := False; Parser.Filename := ToolServices.GetUnitName(I); Parser.Convert; finally

Parser.Free; Source.Free; end

; end

; // if end

; // for // generate the HTML code for forms for

I := 0 to

ToolServices.GetFormCount - 1 do

begin

// convert the DFM file to text BinSource := TFileStream.Create ( ToolServices.GetFormName(I), fmOpenRead); Source := TMemoryStream.Create; ObjectResourceToText (BinSource, Source); Source.Position := 0; Parser := THtmlParser.Create (Source, Dest); try

Parser.Alone := False; Parser.Filename := ToolServices.GetFormName(I); Parser.SetKeywordType (ktDfm); Parser.Convert; finally

Parser.Free; BinSource.Free; Source.Free; end

; end

; // for // add the tail of the HTML file HTML := '<BR><I><CENTER>HTML file generated by PasToWeb, a tool by Marco Cant&ugrave;<BR>'#13#10 + Copyright + '</CENTER></I>'#13#10 + '</BODY> </HTML>'; Dest.WriteBuffer (Pointer(HTML)^, Length (HTML)); finally

Dest.Free; end

; end

; initialization

PascalKeywords := TStringList.Create; DfmKeywords := TStringList.Create; // Pascal Keywords PascalKeywords.Add ('absolute'); PascalKeywords.Add ('abstract'); PascalKeywords.Add ('and'); PascalKeywords.Add ('array'); PascalKeywords.Add ('as'); PascalKeywords.Add ('asm'); PascalKeywords.Add ('assembler'); PascalKeywords.Add ('at'); PascalKeywords.Add ('automated'); PascalKeywords.Add ('begin'); PascalKeywords.Add ('case'); PascalKeywords.Add ('cdecl'); PascalKeywords.Add ('class'); PascalKeywords.Add ('const'); PascalKeywords.Add ('constructor'); PascalKeywords.Add ('contains'); PascalKeywords.Add ('default'); PascalKeywords.Add ('destructor'); PascalKeywords.Add ('dispid'); PascalKeywords.Add ('dispinterface'); PascalKeywords.Add ('div'); PascalKeywords.Add ('do'); PascalKeywords.Add ('downto'); PascalKeywords.Add ('dynamic'); PascalKeywords.Add ('else'); PascalKeywords.Add ('end'); PascalKeywords.Add ('except'); PascalKeywords.Add ('exports'); PascalKeywords.Add ('external'); PascalKeywords.Add ('file'); PascalKeywords.Add ('finalization'); PascalKeywords.Add ('finally'); PascalKeywords.Add ('for'); PascalKeywords.Add ('forward'); PascalKeywords.Add ('function'); PascalKeywords.Add ('goto'); PascalKeywords.Add ('if'); PascalKeywords.Add ('implementation'); PascalKeywords.Add ('in'); PascalKeywords.Add ('index'); PascalKeywords.Add ('inherited'); PascalKeywords.Add ('initialization'); PascalKeywords.Add ('inline'); PascalKeywords.Add ('interface'); PascalKeywords.Add ('is'); PascalKeywords.Add ('label'); PascalKeywords.Add ('library'); PascalKeywords.Add ('message'); PascalKeywords.Add ('mod'); // PascalKeywords.Add ('name'); PascalKeywords.Add ('nil'); PascalKeywords.Add ('nodefault'); PascalKeywords.Add ('not'); PascalKeywords.Add ('object'); PascalKeywords.Add ('of'); PascalKeywords.Add ('on'); PascalKeywords.Add ('or'); PascalKeywords.Add ('override'); PascalKeywords.Add ('packed'); PascalKeywords.Add ('pascal'); PascalKeywords.Add ('private'); PascalKeywords.Add ('procedure'); PascalKeywords.Add ('program'); PascalKeywords.Add ('property'); PascalKeywords.Add ('protected'); PascalKeywords.Add ('public'); PascalKeywords.Add ('published'); PascalKeywords.Add ('raise'); PascalKeywords.Add ('read'); PascalKeywords.Add ('record'); PascalKeywords.Add ('register'); PascalKeywords.Add ('repeat'); PascalKeywords.Add ('requires'); PascalKeywords.Add ('resident'); PascalKeywords.Add ('set'); PascalKeywords.Add ('shl'); PascalKeywords.Add ('shr'); PascalKeywords.Add ('stdcall'); PascalKeywords.Add ('stored'); PascalKeywords.Add ('string'); PascalKeywords.Add ('then'); PascalKeywords.Add ('threadvar'); PascalKeywords.Add ('to'); PascalKeywords.Add ('try'); PascalKeywords.Add ('type'); PascalKeywords.Add ('unit'); PascalKeywords.Add ('until'); PascalKeywords.Add ('uses'); PascalKeywords.Add ('var'); PascalKeywords.Add ('virtual'); PascalKeywords.Add ('while'); PascalKeywords.Add ('with'); PascalKeywords.Add ('write'); PascalKeywords.Add ('xor'); // DFm keywords DfmKeywords.Add ('object'); DfmKeywords.Add ('end'); finalization

PascalKeywords.Free; end

.

unit

NewParse; interface

uses

Classes, SysUtils, Consts; const

toComment = Char(5); type

TNewParser = class

(TObject) private

FStream: TStream; FOrigin: Longint; FBuffer: PChar; FBufPtr: PChar; FBufEnd: PChar; FSourcePtr: PChar; FSourceEnd: PChar; FTokenPtr: PChar; FStringPtr: PChar; FSourceLine: Integer; FSaveChar: Char; FToken: Char; procedure

ReadBuffer; procedure

SkipBlanks; public

constructor

Create(Stream: TStream); destructor

Destroy; override

; procedure

CheckToken(T: Char); procedure

CheckTokenSymbol(const

S: string

); procedure

Error(const

Ident: string

); procedure

ErrorFmt(const

Ident: string

; const

Args: array

of

const

); procedure

ErrorStr(const

Message

: string

); procedure

HexToBinary(Stream: TStream); function

NextToken: Char; function

SourcePos: Longint; function

TokenComponentIdent: String

; function

TokenFloat: Extended; function

TokenInt: Longint; function

TokenString: string

; function

TokenSymbolIs(const

S: string

): Boolean; property

SourceLine: Integer read

FSourceLine; property

Token: Char read

FToken; end

; implementation

const

ParseBufSize = 4096; procedure

BinToHex(Buffer, Text: PChar; BufSize: Integer); assembler

; asm

PUSH ESI PUSH EDI MOV ESI,EAX MOV EDI,EDX MOV EDX,0 JMP @@1 @@0: DB '0123456789ABCDEF' @@1: LODSB MOV DL,AL AND

DL,0FH MOV AH,@@0.Byte[EDX] MOV DL,AL SHR

DL,4 MOV AL,@@0.Byte[EDX] STOSW DEC ECX JNE @@1 POP EDI POP ESI end

; function

HexToBin(Text, Buffer: PChar; BufSize: Integer): Integer; assembler

; asm

PUSH ESI PUSH EDI PUSH EBX MOV ESI,EAX MOV EDI,EDX MOV EBX,EDX MOV EDX,0 JMP @@1 @@0: DB 0, 1, 2, 3, 4, 5, 6, 7, 8, 9,-1,-1,-1,-1,-1,-1 DB -1,10,11,12,13,14,15,-1,-1,-1,-1,-1,-1,-1,-1,-1 DB -1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1,-1 DB -1,10,11,12,13,14,15 @@1: LODSW CMP AL,'0' JB @@2 CMP AL,'f' JA @@2 MOV DL,AL MOV AL,@@0.Byte[EDX-'0'] CMP AL,-1 JE @@2 SHL

AL,4 CMP AH,'0' JB @@2 CMP AH,'f' JA @@2 MOV DL,AH MOV AH,@@0.Byte[EDX-'0'] CMP AH,-1 JE @@2 OR

AL,AH STOSB DEC ECX JNE @@1 @@2: MOV EAX,EDI SUB EAX,EBX POP EBX POP EDI POP ESI end

; constructor

TNewParser.Create(Stream: TStream); begin

FStream := Stream; GetMem(FBuffer, ParseBufSize); FBuffer[0] := #0; FBufPtr := FBuffer; FBufEnd := FBuffer + ParseBufSize; FSourcePtr := FBuffer; FSourceEnd := FBuffer; FTokenPtr := FBuffer; FSourceLine := 1; NextToken; end

; destructor

TNewParser.Destroy; begin

if

FBuffer <> nil

then

begin

FStream.Seek(Longint(FTokenPtr) - Longint(FBufPtr), 1); FreeMem(FBuffer, ParseBufSize); end

; end

; procedure

TNewParser.CheckToken(T: Char); begin

if

Token <> T then

case

T of

toSymbol: Error(SIdentifierExpected); toString: Error(SStringExpected); toInteger, toFloat: Error(SNumberExpected); else

ErrorFmt(SCharExpected, [T]); end

; end

; procedure

TNewParser.CheckTokenSymbol(const

S: string

); begin

if

not

TokenSymbolIs(S) then

ErrorFmt(SSymbolExpected, [S]); end

; procedure

TNewParser.Error(const

Ident: string

); begin

ErrorStr(Ident); end

; procedure

TNewParser.ErrorFmt(const

Ident: string

; const

Args: array

of

const

); begin

ErrorStr(Format(Ident, Args)); end

; procedure

TNewParser.ErrorStr(const

Message

: string

); begin

raise

EParserError.CreateFmt(SParseError, [Message

, FSourceLine]); end

; procedure

TNewParser.HexToBinary(Stream: TStream); var

Count: Integer; Buffer: array

[0..255] of

Char; begin

SkipBlanks; while

FSourcePtr^ <> '}' do

begin

Count := HexToBin(FSourcePtr, Buffer, SizeOf(Buffer)); if

Count = 0 then

Error(SInvalidBinary); Stream.Write

(Buffer, Count); Inc(FSourcePtr, Count * 2); SkipBlanks; end

; NextToken; end

; function

TNewParser.NextToken: Char; var

I: Integer; P, S: PChar; begin

SkipBlanks; P := FSourcePtr; FTokenPtr := P; case

P^ of

'A'..'Z', 'a'..'z', '_': begin

Inc(P); while

P^ in

['A'..'Z', 'a'..'z', '0'..'9', '_'] do

Inc(P); Result := toSymbol; end

; '#', '''': begin

S := P; while

True do

case

P^ of

'#': begin

Inc(P); I := 0; while

P^ in

['0'..'9'] do

begin

I := I * 10 + (Ord(P^) - Ord('0')); Inc(P); end

; S^ := Chr(I); Inc(S); end

; '''': begin

Inc(P); while

True do

begin

case

P^ of

#0, #10, #13: Error(SInvalidString); '''': begin

Inc(P); if

P^ <> '''' then

Break; end

; end

; S^ := P^; Inc(S); Inc(P); end

; end

; else

Break; end

; FStringPtr := S; Result := toString; end

; '$': begin

Inc(P); while

P^ in

['0'..'9', 'A'..'F', 'a'..'f'] do

Inc(P); Result := toInteger; end

; '-', '0'..'9': begin

Inc(P); while

P^ in

['0'..'9'] do

Inc(P); Result := toInteger; while

P^ in

['0'..'9', '.', 'e', 'E', '+', '-'] do

begin

Inc(P); Result := toFloat; end

; end

; // new custom code!!!! '{': begin

// look for closing brace while

(P^ <> '}') and

(P^ <> toEOF) do

Inc(P); // move to the next if

(P^ <> toEOF) then

Inc(P); Result := toComment; end

; else

// updated if

(P^ = '/') and

(P^ <> toEOF) and

((P+1)^ = '/') then

begin

// single line comment while

P^ <> #13 do

Inc(P); Result := toComment; end

else

begin

Result := P^; if

Result <> toEOF then

Inc(P); end

; end

; FSourcePtr := P; FToken := Result; end

; procedure

TNewParser.ReadBuffer; var

Count: Integer; begin

Inc(FOrigin, FSourcePtr - FBuffer); FSourceEnd[0] := FSaveChar; Count := FBufPtr - FSourcePtr; if

Count <> 0 then

Move(FSourcePtr[0], FBuffer[0], Count); FBufPtr := FBuffer + Count; Inc(FBufPtr, FStream.Read

(FBufPtr[0], FBufEnd - FBufPtr)); FSourcePtr := FBuffer; FSourceEnd := FBufPtr; if

FSourceEnd = FBufEnd then

begin

FSourceEnd := LineStart(FBuffer, FSourceEnd - 1); if

FSourceEnd = FBuffer then

Error(SLineTooLong); end

; FSaveChar := FSourceEnd[0]; FSourceEnd[0] := #0; end

; procedure

TNewParser.SkipBlanks; begin

while

True do

begin

case

FSourcePtr^ of

#0: begin

ReadBuffer; if

FSourcePtr^ = #0 then

Exit; Continue; end

; #10: Inc(FSourceLine); '!'..'я' : Exit; end

; Inc(FSourcePtr); end

; end

; function

TNewParser.SourcePos: Longint; begin

Result := FOrigin + (FTokenPtr - FBuffer); end

; function

TNewParser.TokenFloat: Extended; begin

Result := StrToFloat(TokenString); end

; function

TNewParser.TokenInt: Longint; begin

Result := StrToInt(TokenString); end

; function

TNewParser.TokenString: string

; var

L: Integer; begin

if

FToken = toString then

L := FStringPtr - FTokenPtr else

L := FSourcePtr - FTokenPtr; SetString(Result, FTokenPtr, L); end

; function

TNewParser.TokenSymbolIs(const

S: string

): Boolean; begin

Result := (Token = toSymbol) and

(CompareText(S, TokenString) = 0); end

; function

TNewParser.TokenComponentIdent: String

; var

P: PChar; begin

CheckToken(toSymbol); P := FSourcePtr; while

P^ = '.' do

begin

Inc(P); if

not

(P^ in

['A'..'Z', 'a'..'z', '_']) then

Error(SIdentifierExpected); repeat

Inc(P) until

not

(P^ in

['A'..'Z', 'a'..'z', '0'..'9', '_']); end

; FSourcePtr := P; Result := TokenString; end

; end

.

unit

PasToWebForm; interface

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type

TForm1 = class

(TForm) EditSource: TEdit; BtnHTML: TButton; EditCopyr: TEdit; BtnInput: TButton; OpenDialog1: TOpenDialog; EditDest: TEdit; Label1: TLabel; Label2: TLabel; Label3: TLabel; BtnOpen: TButton; BtnInfo: TButton; procedure

BtnHTMLClick(Sender: TObject); procedure

BtnInputClick(Sender: TObject); procedure

EditDestChange(Sender: TObject); procedure

BtnOpenClick(Sender: TObject); procedure

BtnInfoClick(Sender: TObject); end

; var

Form1: TForm1; implementation

{$R *.DFM} uses

Convert, ShellApi; procedure

TForm1.BtnHTMLClick(Sender: TObject); var

Source, BinSource, Dest: TStream; Parser: THtmlParser; begin

// extract the target file name if

FileExists (EditDest.Text) then

if

MessageDlg ('Overwrite the existing file ' + EditDest.Text + '?', mtConfirmation, [mbYes, mbNo], 0) = idNo then

Exit; // create the two streams Dest := TFileStream.Create (EditDest.Text, fmCreate or

fmOpenWrite); if

ExtractFileExt(EditSource.Text) = '.dfm' then

begin

// convert the DFM file to text BinSource := TFileStream.Create (EditSource.Text, fmOpenRead); Source := TMemoryStream.Create; ObjectResourceToText (BinSource, Source); Source.Position := 0; end

else

begin

Source := TFileStream.Create (EditSource.Text, fmOpenRead); BinSource := nil

; end

; // parse the source code try

Parser := THtmlParser.Create (Source, Dest); try

Parser.Alone := True; Parser.Filename := EditSource.Text; Parser.Copyright := EditCopyr.Text; if

ExtractFileExt(EditSource.Text) = '.dfm' then

Parser.SetKeywordType (ktDfm); Parser.Convert; finally

Parser.Free; end

; finally

Dest.Free; Source.Free; BinSource.Free; end

; // enable the third button BtnOpen.Enabled := True; end

; procedure

TForm1.BtnInputClick(Sender: TObject); begin

with

OpenDialog1 do

if

Execute then

begin

EditSource.Text := Filename; EditDest.Text := ChangeFileExt(FileName, '_' + Copy (ExtractFileExt(Filename), 2, 3)) + '.HTM'; BtnHtml.Enabled := True; end

; end

; procedure

TForm1.EditDestChange(Sender: TObject); begin

BtnOpen.Enabled := False; end

; procedure

TForm1.BtnOpenClick(Sender: TObject); begin

ShellExecute (Handle, 'open', PChar (EditDest.Text), '', '', sw_ShowNormal); end

; procedure

TForm1.BtnInfoClick(Sender: TObject); begin

// this isn't true any more MessageDlg (Caption + #13#13+ 'from Delphi Developers Handbook', mtInformation, [mbOK], 0); end

; end

.

Другое по теме:

Категории

Статьи

Советы

Copyright © 2022 - All Rights Reserved - www.delphirus.com