http://delphi.ktop.com.tw/board.php?cid=30&fid=70&tid=99044
1.type TDataProvider=class
2.private:
3. procedure _AppendData(SKey : String; SName : String; SValue1 : integer; SValue2 : String);
4.public:
5. procedure AppendData(SKey :String; SName : String);
6. procedure AppendData(SKey : String; SName : String; SValue2 : String);
7.end;
8.
9.//implementation;
10.
11.procedure TDataProvider._AppendData(SKey : String; SName : String; SValue1 : integer; SValue2 : String);
12.begin
13.//優先處理會被省略的參數
14.//原先的函式本體
15.end;
16.
17.procedure TDataProvider.AppendData(SKey : String; SName : String);
18.begin
19.self._AppendData(SKey, SName, nil, -1, nil);
20.end;
21.
22.procedure TDataProvider.AppendData(SKey : String; SName : String; SValue2 : String);
23.
24.begin
25.self._AppendData(SKey, SName, nil, -1, SValue2);
26.end;
2009年8月24日 星期一
ShellListView 選擇的檔案
procedure TForm1.ShellListView1MouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var i:integer;
begin
for i := 0 to ShellListView1.Items.Count-1 do
begin
if ShellListView1.Items[i].Selected then
ShowMessage(ShellListView1.Folders[i].PathName); // 這就是檔案全路徑
end;
end;
2009年8月20日 星期四
測試pas檔轉html 的功能
unit uMain;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,StrUtils;
const VK_RTN = chr(13)+ chr(10);
type
TMain = class(TForm)
Button1: TButton;
OpenDialog1: TOpenDialog;
Memo1: TMemo;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
ColorDialog1: TColorDialog;
procedure Button1Click(Sender: TObject);
procedure Label1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
TmpStyle=(mpReservedWord, mpSymbol , mpString , mpComment ,mpSpace );
TDataSec=record
DataString:String;
Style:TmpStyle;
end;
TPasFile=Class
Data,FFileName:String;
protected
ReservedWordList:TStringList;
public
function EncodeToHtml:String;
constructor Create(FileName:string);
destructor Destroy;override;
End;
var
Main: TMain;
implementation
{$R *.dfm}
procedure TMain.Button1Click(Sender: TObject);
var o:TPasFile;
s:String;
begin
s := '中文實驗<>'' '' ';
if OpenDialog1.Execute then
begin
o := TPasFile.Create(OpenDialog1.FileName);
Memo1.Lines.Clear;
Memo1.Lines.Add(o.EncodeToHtml);
Memo1.Lines.SaveToFile('C:\a.html');
Application.ProcessMessages;
winexec('explorer.exe C:\a.html',SW_SHOW );
o.Free;
end;
end;
{ TPasFile }
constructor TPasFile.Create(FileName:string);
var sl:TStringList;
begin
sl :=TStringList.Create;
FFileName :=FileName;
sl.LoadFromFile(FileName);
Data := sl.Text;
sl.Free;
ReservedWordList := TStringList.Create;
ReservedWordList.Add('constructor');
ReservedWordList.Add('destructor');
ReservedWordList.Add('begin');
ReservedWordList.Add('inherited');
ReservedWordList.Add('end');
ReservedWordList.Add('var');
ReservedWordList.Add('Integer');
ReservedWordList.Add('string');
ReservedWordList.Add('procedure');
ReservedWordList.Add('function');
ReservedWordList.Add('protected');
ReservedWordList.Add('public');
ReservedWordList.Add('if');
ReservedWordList.Add('then');
ReservedWordList.Add('While');
ReservedWordList.Add('do');
ReservedWordList.Add('for');
ReservedWordList.Add('to');
ReservedWordList.Add('in');
ReservedWordList.Add('else');
ReservedWordList.Add('override');
ReservedWordList.Add('type');
ReservedWordList.Add('record');
ReservedWordList.Add('class');
ReservedWordList.Add('implementation');
ReservedWordList.Add('private');
ReservedWordList.Add('case');
ReservedWordList.Add('of');
ReservedWordList.Add('array');
ReservedWordList.Add('unit');
ReservedWordList.Add('interface');
ReservedWordList.Text := UpperCase( ReservedWordList.Text);
end;
destructor TPasFile.Destroy;
begin
ReservedWordList.Free;
inherited;
end;
function TPasFile.EncodeToHtml: String;
var
I,oldPos: Integer;
htmlStr,sHead,sFoot:string;
oDs:TDataSec;
function GotoStr(sa:array of string):integer;
var ii,j:integer;
begin
Result := Length(Data);
for j := (i+1) to Length(Data) do
for ii := Low(sa) to High(sa) do
if data[j]=sa[ii] then
begin
Result := j ;
exit;
end;
end;
function GotoNextComm:integer;
var j:integer;
begin
Result := Length(Data);
for j := (i+1) to Length(Data) do
if (data[j]='''')and(data[j+1]<>'''') then
begin
Result := j ;
exit;
end;
end;
procedure SetDataSec(S:String;style:TmpStyle);
begin
//處理關鍵字
if ReservedWordList.IndexOf( UpperCase(s)) <> -1 then
style := mpReservedWord;
//處理 html 不能使用的字
s:= StringReplace(s,'<','<',[rfReplaceAll] );
s:= StringReplace(s,'>','>',[rfReplaceAll] );
oDs.DataString := s;
oDs.Style := style;
end;
function HtmlColorStr(Color:TColor):String;
begin
Result := format('#%.2x%.2x%.2x',[GetRValue(Color)
,GetGValue(Color),GetBValue(Color) ]);
end;
begin
i := 1;
while i < Length(Data) do
begin
oldPos := i;
case Data[i] of
' ' : SetDataSec(' ',mpSpace) ;
'{' :
begin
i := GotoStr(['}']);
SetDataSec(Copy(Data,oldPos,i - oldPos +1),mpComment );
end;
'/' :
begin
if Data[i+1]='/' then
begin
i := GotoStr( [ chr(10)]);
SetDataSec(Copy(Data,oldPos,i - oldPos +1 ),mpComment );
end
else
SetDataSec(string( data[i]),mpSymbol );
end;
':','=',';','.','[',']','(',')',',',chr(13),chr(10):
begin
SetDataSec(string( data[i]),mpSymbol );
end;
'''':
begin
i := GotoNextComm;
SetDataSec(Copy(Data,oldPos,i - oldPos +1),mpString );
end;
else
begin
i := GotoStr([' ','{','/',chr(13),chr(10),':','=',';','.','[',']','(',')',',' ]);
SetDataSec(Copy(Data,oldPos,i - oldPos ),mpString );
dec(i);
end;
end;
// <font color=#ff0000><b></b></font> 紅
// <font color=#009900></font> 綠
// <font color=#7d0000> 咖啡色
if (ods.Style = mpReservedWord) and(Main.Label1.Font.Color<>clBlack)then
htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label1.Font.Color)+'><b>' + ods.DataString +'</b></font>'
else if (ods.Style = mpComment) and(Main.Label2.Font.Color<>clBlack) then
htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label2.Font.Color)+'>' + ods.DataString +'</font>'
else if (ods.Style = mpSymbol)and(Main.Label3.Font.Color<>clBlack) then
htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label3.Font.Color)+'>' + ods.DataString +'</font>'
else if (Main.Label4.Font.Color<>clBlack) then
htmlStr := htmlStr +'<font color='+HtmlColorStr(Main.Label4.Font.Color)+'>' + ods.DataString +'</font>'
else
htmlStr := htmlStr + ods.DataString;
inc(i);
end;
sHead :=
'<html>' + VK_RTN +
'<head>' + VK_RTN +
'<meta http-equiv="Content-Type" content="text/html; charset=big5">' + VK_RTN +
'<title>'+FFileName+'</title>' + VK_RTN +
'</head>' + VK_RTN +
//'<body text="#000000" bgcolor="#FFFFFF" >'+ VK_RTN +
'<pre><code>' + VK_RTN ;
sFoot := VK_RTN +
'</code></pre>' + VK_RTN +
//'</body>' + VK_RTN +
'</html>' ;
Result := sHead + htmlStr + sFoot;
end;
procedure TMain.Label1Click(Sender: TObject);
begin
if ColorDialog1.Execute then
(Sender as TLabel).Font.Color := ColorDialog1.Color;
//Memo1.Text := ColorToString( ColorDialog1.Color );
// Memo1.Text := format('#%.2x%.2x%.2x',[GetRValue(ColorDialog1.Color)
// ,GetGValue(ColorDialog1.Color),GetBValue(ColorDialog1.Color) ]);
end;
end.
訂閱：
文章 (Atom)
