calcunit.pas

好好的哦,包含各种科学函数,具有多种功能的计算器,而且还有源代码

unit CalcUnit;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, Buttons, Math, Registry;

type
  TCalcForm = class(TForm)
    Memo1: TMemo;
    FontDialog1: TFontDialog;
    ColorDialog1: TColorDialog;
    Timer1: TTimer;
    Panel1: TPanel;
    Panel2: TPanel;
    procedure Memo1KeyPress(Sender: TObject; var Key: Char);
    procedure FormShow(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Memo1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Memo1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Timer1Timer(Sender: TObject);
    procedure Memo1MouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
  private
    theAllList: TStringList;
    strResult: String;
    strCancel: String;
    function CalcNonoKh(theList: TStringList): Extended;
    function MemoLinesToStringList(var theList: TStringList; iCurPosition: Integer;
        bCalcOrCommond: Boolean = False): String;      // 返回值为被忽略的杂字
//**   theList 为传递变量，iCurPosition 为光标当前位置， bCalcOrCommond 区别是用做计算还是用做命令
    function CalcFormList(theList: TStringList): Extended;
    function IsInOperatorsArray(theStr: String): Boolean;
    function IsFloat(theStr: String): Boolean;
    function DowToWeekStr(Dow: Word): String;
    procedure WritePosition;
    procedure RevertSize;
  public
    { Public declarations }
  end;

Function FontStyleToString(FontStyle : TFontStyles) : String;
Function StringToFontStyle(strFontStyle : String) : TFontStyles;
procedure showTaskbar;
procedure hideTaskbar; //隐藏

var
  CalcForm: TCalcForm;

const
  TheOperators: array [0..36] of String = ('+','-','*','/','^','!','SQR','SQRT','%','ABS','INT','TRUNC','FRAC',
        'ARCTAN','COS','LN','PI','SIN','TAN','ROUND','LOG2','LOG10','SETFONT','BKCOLOR','ARCSIN','ARCCOS',
        'BACKCOLOR','CLEAR','CLOSE','QUIT','EXIT','(',')','FULLSCREEN','FULLSCR','REVERT','REV');

implementation

{$R *.dfm}

//****************************************************************************************
// 以下是自定义函数或过程
//****************************************************************************************

procedure TCalcForm.WritePosition;
var wRegistry: TRegistry;
    bReg: Boolean;
begin
    wRegistry:=TRegistry.Create;  //KeyExists
    wRegistry.RootKey:=HKEY_LOCAL_MACHINE;
    bReg:=wRegistry.KeyExists('Software\WgqAdvanCalc');
    If bReg then
    begin
        wRegistry.OpenKey('Software\WgqAdvanCalc',False);
        wRegistry.WriteInteger('iTop',Self.Top);
        wRegistry.WriteInteger('iLeft',Self.Left);
        wRegistry.WriteInteger('iHeight',Self.Height);
        wRegistry.WriteInteger('iWidth',Self.Width);
        wRegistry.CloseKey;
    end;
    wRegistry.Free;
end;

procedure TCalcForm.RevertSize;
var wRegistry: TRegistry;
    bReg: Boolean;
begin
    wRegistry:=TRegistry.Create;  //KeyExists
    wRegistry.RootKey:=HKEY_LOCAL_MACHINE;
    bReg:=wRegistry.KeyExists('Software\WgqAdvanCalc');
    If bReg then
    begin
        wRegistry.OpenKey('Software\WgqAdvanCalc',False);
        Self.Top:=wRegistry.ReadInteger('iTop');
        Self.Left:=wRegistry.ReadInteger('iLeft');
        Self.Height:=wRegistry.ReadInteger('iHeight');
        Self.Width:=wRegistry.ReadInteger('iWidth');
        wRegistry.CloseKey;
    end;
    wRegistry.Free;
end;

procedure hideTaskbar; //隐藏
var wndHandle : THandle;
    wndClass : array[0..50] of Char;
begin
    StrPCopy(@wndClass[0], 'Shell_TrayWnd');
    wndHandle := FindWindow(@wndClass[0], nil);
    ShowWindow(wndHandle, SW_HIDE);
End;

procedure showTaskbar;
var wndHandle : THandle;
    wndClass : array[0..50] of Char;
begin
    StrPCopy(@wndClass[0], 'Shell_TrayWnd');
    wndHandle := FindWindow(@wndClass[0], nil);
    ShowWindow(wndHandle, SW_RESTORE);
end;                                       

function TCalcForm.DowToWeekStr(Dow: Word): String;
begin
    case Dow of
        1: Result:='星期日';
        2: Result:='星期一';
        3: Result:='星期二';
        4: Result:='星期三';
        5: Result:='星期四';
        6: Result:='星期五';
        7: Result:='星期六';
    end;
end;

function TCalcForm.IsFloat(theStr: String): Boolean;
begin
    try
        StrToFloat(theStr);
        Result:=True;
    except
        Result:=False;
    end;
end;

Function FontStyleToString(FontStyle : TFontStyles) : String;
var strFontStyles : String;    //(fsBold, fsItalic, fsUnderline, fsStrikeOut);
begin
	strFontStyles:='-';
	if fsBold in FontStyle then strFontStyles:=strFontStyles+'fsBold'+'-'
	else strFontStyles:=strFontStyles+'aaaaaa'+'-';
	if fsItalic in FontStyle then strFontStyles:=strFontStyles+'fsItalic'+'-'
	else strFontStyles:=strFontStyles+'aaaaaaaa'+'-';
	if fsUnderline in FontStyle then strFontStyles:=strFontStyles+'fsUnderline'+'-'
	else strFontStyles:=strFontStyles+'aaaaaaaaaaa'+'-';
	if fsStrikeOut in FontStyle then strFontStyles:=strFontStyles+'fsStrikeOut'+'-'
	else strFontStyles:=strFontStyles+'aaaaaaaaaaa'+'-';
	Result:=strFontStyles;
end;

Function StringToFontStyle(strFontStyle : String) : TFontStyles;
var FontStyle : TFontStyles;
begin
	FontStyle:=[];
	If Copy(strFontStyle,2,6)='fsBold' then 
		FontStyle:=FontStyle+[fsBold];
	If Copy(strFontStyle,9,8)='fsItalic' then 
		FontStyle:=FontStyle+[fsItalic];	
	If Copy(strFontStyle,18,11)='fsUnderline' then 
		FontStyle:=FontStyle+[fsUnderline];
	If Copy(strFontStyle,30,11)='fsStrikeOut' then 
		FontStyle:=FontStyle+[fsStrikeOut];
	Result:=FontStyle;
end;

function TCalcForm.IsInOperatorsArray(theStr: String): Boolean;
var i: Integer;
begin
    Result:=False;
    For i:=Low(TheOperators) to High(TheOperators) do
    begin
        If theStr = TheOperators[i] then
        begin
            Result:=True;
            Break;
        end;
    end;
end;

function TCalcForm.CalcFormList(theList: TStringList): Extended;
var i,iBegin, iEnd: Integer;
    dTemp: Extended;
    theListIn: TStringList;
begin
        theListIn:=TStringList.Create;
        theListIn.Clear;
        iBegin:=-1;
        iEnd:=-1;
        while theList.Count>1 do
        begin
            For i:=0 to theList.Count-1 do If (theList.Strings[i]='(') then iBegin:=i;
            If iBegin<>-1 then
            begin
                For i:=iBegin to theList.Count-1 do
                begin
                    If (theList.Strings[i]=')') then
                    begin
                        iEnd:=i; break;
                    end;
                end;
            end;
            If (iBegin = -1)and(iEnd = -1) then
            begin
                theListIn.Clear;
                For i:=0 to theList.Count-1 do
                    theListIn.Add(theList.Strings[i]);
                If theListIn.Count<>0 then
                    dTemp:=CalcNonoKh(theListIn);
                theList.Clear;
                theList.Add(FloatToStr(dTemp));
            end
            else if (iBegin <> -1)and(iEnd <> -1) then
            begin
                theListIn.Clear;
                For i:=iBegin+1 to iEnd-1 do
                    theListIn.Add(theList.Strings[i]);
                If theListIn.Count<>0 then
                    dTemp:=CalcNonoKh(theListIn);
                For i:=1 to iEnd-iBegin do
                begin
                    theList.Delete(iBegin);
                end;
                theList.Strings[iBegin]:=FloatToStr(dTemp);
                iBegin:=-1; iEnd:=-1;
            end
            else begin
                Memo1.Lines.Add('表达式错误！∴');
                Exit;
            end;
        end;
        If UpperCase(theList.Strings[0])='PI' then
            Result:=3.1415926535897932384626433832795
        else
            Result:=StrToFloat(theList.Strings[0]);
        theListIn.Free;
end;

function TCalcForm.MemoLinesToStringList(var theList: TStringList; iCurPosition: Integer;
    bCalcOrCommond: Boolean = False): String;
var strTemp, str: String;
    i, j, iBegin, iEnd, iTemp: Integer;
    bbool, bBegin, bEnd: Boolean;
begin
    theList.Clear;
    Result:='';
    bbool:=False;  bBegin:=False; bEnd:=False;
    strTemp:=Memo1.Lines.Text;
    For i:=iCurPosition to Length(strTemp) do
    begin
        If strTemp[i]=#13 then
        begin
            iEnd:=i;
            bEnd:=True;
            break;
        end;
    end;
    For i:=iCurPosition downto 1 do
    begin
        If (strTemp[i-1]+strTemp[i])='∴' then
        begin
            iBegin:=i+1;
            bBegin:=True;
            break;
        end;
        If strTemp[i]=#13 then
        begin
            bbool:=True;
            iTemp:=i;
        end;
        If bbool and (strTemp[i]='=') then
        begin
            iBegin:=iTemp+1;
            bBegin:=True;
            break;
        end;
    end;
    If not bBegin then iBegin:=1;
    If not bEnd then iEnd:=Length(strTemp);
    j:=iBegin;
    For i:=iBegin to iEnd do
    begin
        If (IsInOperatorsArray(strTemp[i]))or(strTemp[i]=')')or(strTemp[i]='(')
            or(strTemp[i]=#13) then
        begin
            str:=Copy(strTemp,j,i-j);