Приложения. Приложение 1.
Программа “Эксперт” состоит из пятидесяти четырех модулей. Ниже я приведу листинг основных модулей.
//Модуль экранной заставки
unit pictU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls;
type
TfmPicture = class(TForm)
Image1: TImage;
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
fmPicture: TfmPicture;
implementation
uses Expert;
{$R *.DFM}
procedure TfmPicture.Timer1Timer(Sender: TObject);
begin
//Отключение таймера. Заставка исчезает и появляется основная форма
Timer1.Enabled:=false;
fmMain.Show;
end;
end.
//Модуль “Запрос пароля”
unit pass;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TfmPass = class(TForm)
Label1: TLabel;
ComboBox1: TComboBox;
Label2: TLabel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure Button2Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
//процедуры шифрования и расшифрования пароля
function Encrypt(const InString:string; StartKey,MultKey,AddKey:Integer): string;
function Decrypt(const InString:string; StartKey,MultKey,AddKey:Integer): string;
end;
var
fmPass: TfmPass;
implementation
uses Expert, DatesU, pworkU, directU;
{$R *.DFM}
{$R-}
{$Q-}
{*******************************************************
* Standard Encryption algorithm - Copied from Borland *
*******************************************************}
function TfmPass.Encrypt(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var
I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(Result[I]) + StartKey) * MultKey + AddKey;
end;
end;
{*******************************************************
* Standard Decryption algorithm - Copied from Borland *
*******************************************************}
function TfmPass.Decrypt(const InString:string; StartKey,MultKey,AddKey:Integer): string;
var
I : Byte;
begin
Result := '';
for I := 1 to Length(InString) do
begin
Result := Result + CHAR(Byte(InString[I]) xor (StartKey shr 8));
StartKey := (Byte(InString[I]) + StartKey) * MultKey + AddKey;
end;
end;
{$R+}
{$Q+}
procedure TfmPass.Button2Click(Sender: TObject);
begin
fmMain.NeedPass:=3;
Close;
end;
procedure TfmPass.Button1Click(Sender: TObject);
var i:integer;
begin
i:=0;
if ((ComboBox1.Text='Директор') and (Edit1.Text=Decrypt(fmMain.Param1, 14,13,12))) then
begin
i:=1;
fmMain.NeedPass:=1;
close;
end;
if ((ComboBox1.Text='Сотрудник') and (Edit1.Text=Decrypt(fmMain.Param2, 14,13,12))) then
begin
i:=1;
fmMain.NeedPass:=1;
fmDates.DBEdit2.Enabled:=false;
fmPWork.DBEdit6.Enabled:= false;
fmDirect.RichEdit1.Enabled:= false;
fmDirect.btnAddDate.Enabled:= false;
close;
end;
if i<>1 then ShowMessage('Проверьте правильность введенных данных');
end;
end.
//Модуль главной формы
unit Expert;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Grids, DBGrids, ComCtrls, Menus, Buttons,Registry,printers;
type
TfmMain = class(TForm)
PageControl1: TPageControl;
TabSheet1: TTabSheet;
TabSheet2: TTabSheet;
DBGrid1: TDBGrid;
Label1: TLabel;
edFind: TEdit;
MainMenu1: TMainMenu;
N1: TMenuItem;
N2: TMenuItem;
N3: TMenuItem;
mnTemi: TMenuItem;
N4: TMenuItem;
N7: TMenuItem;
N8: TMenuItem;
N9: TMenuItem;
N10: TMenuItem;
N11: TMenuItem;
N12: TMenuItem;
N5: TMenuItem;
N6: TMenuItem;
DBGrid2: TDBGrid;
Label2: TLabel;
edFind2: TEdit;
btnExit: TBitBtn;
tbnFirmaAbout: TBitBtn;
btnRabotiAbout: TBitBtn;
btnBeginWork: TBitBtn;
N13: TMenuItem;
N14: TMenuItem;
BitBtn1: TBitBtn;
BitBtn2: TBitBtn;
BitBtn3: TBitBtn;
N15: TMenuItem;
Excel1: TMenuItem;
N16: TMenuItem;
N17: TMenuItem;
N18: TMenuItem;
N19: TMenuItem;
N20: TMenuItem;
N21: TMenuItem;
N22: TMenuItem;
N23: TMenuItem;
N25: TMenuItem;
N26: TMenuItem;
N24: TMenuItem;
Label3: TLabel;
Label4: TLabel;
N27: TMenuItem;
N30: TMenuItem;
N31: TMenuItem;
N32: TMenuItem;
N33: TMenuItem;
N34: TMenuItem;
PrintDialog1: TPrintDialog;
N35: TMenuItem;
edtHeaderFont1: TEdit;
FontDialog1: TFontDialog;
N36: TMenuItem;
procedure mnTemiClick(Sender: TObject);
procedure edFindChange(Sender: TObject);
procedure N9Click(Sender: TObject);
procedure N12Click(Sender: TObject);
procedure N4Click(Sender: TObject);
procedure N8Click(Sender: TObject);
procedure N5Click(Sender: TObject);
procedure edFind2Change(Sender: TObject);
procedure tbnFirmaAboutClick(Sender: TObject);
procedure N2Click(Sender: TObject);
procedure btnRabotiAboutClick(Sender: TObject);
procedure btnBeginWorkClick(Sender: TObject);
procedure N13Click(Sender: TObject);
procedure BitBtn1Click(Sender: TObject);
procedure BitBtn2Click(Sender: TObject);
procedure BitBtn3Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure N6Click(Sender: TObject);
procedure N14Click(Sender: TObject);
procedure Excel1Click(Sender: TObject);
procedure N17Click(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure N21Click(Sender: TObject);
procedure N22Click(Sender: TObject);
procedure N25Click(Sender: TObject);
procedure N26Click(Sender: TObject);
procedure btnExitClick(Sender: TObject);
procedure N24Click(Sender: TObject);
procedure N19Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure N27Click(Sender: TObject);
procedure N31Click(Sender: TObject);
procedure N33Click(Sender: TObject);
procedure N34Click(Sender: TObject);
procedure N35Click(Sender: TObject);
procedure N36Click(Sender: TObject);
procedure N11Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
{ Keeps track of vertical space in pixels, printed on a page }
AmountPrinted: integer;
{ Private declarations }
PixelsInInchx: integer;
LineHeight: Integer;
{ Number of pixels in 1/10 of an inch. This is used for line spacing }
TenthsOfInchPixelsY: integer;
NeedPass:integer;
ShablonDirectory:string[250]; //Директория с шаблонами
ServerName:string[100]; //Почтовый сервер
RegistrationName:string[100]; //Имя регистрации на почтовом сервере
adresfrom:string; //Email адрес Эксперта
LastClientBase:string[50]; //Последняя открытая база клиентов
LastPClientBase:string[50]; //последняя открытая база постоянных клиентов
param1:string[15];
param2:string[15];
//Процедура печати строк таблицы
procedure PrintLine(Items: TStringList);
//Печать заголовка таблицы
procedure PrintHeader(head:string);
//Печать заголовков столбцов таблицы
procedure PrintColumnNames;
end;
var
fmMain: TfmMain;
implementation
uses Pclientu, pworkU, TemiU, Modal1, pcadddog, SotrudnU, AboutU, rememU,
OptionsU, MessShow, CModul, ClientU, RegZayav, dogovorU, manageU, directU,
pictU, WorkersM, alarm, lastwork, FromExcU, pcreateU, creatcl, Modul3,
searchD, compsach, pass, sechz, statist;
{$R *.DFM}
procedure TfmMain.mnTemiClick(Sender: TObject);
begin
fmTemi.ShowModal;
end;
procedure TfmMain.edFindChange(Sender: TObject);
begin
//Поиск по названию организации в базах потенциальных клиентов
Modal.taPClient.FindNearest([edFind.Text]);
EdFind2.Text:=edFind.Text;
end;
procedure TfmMain.N9Click(Sender: TObject);
begin
fmWorkersShow.ShowModal;
end;
procedure TfmMain.N12Click(Sender: TObject);
begin
fmAbout.ShowModal;
end;
procedure TfmMain.N4Click(Sender: TObject);
begin
fmRemember.ShowModal;
end;
procedure TfmMain.N8Click(Sender: TObject);
begin
fmOptions.ShowModal;
end;
procedure TfmMain.N5Click(Sender: TObject);
begin
fmMailShow.ShowModal;
end;
procedure TfmMain.edFind2Change(Sender: TObject);
begin
//Поиск по названию организации в базе постоянных клиентов
Modul.taClient.FindNearest([edFind2.Text]);
edFind.Text:=edFind2.Text;
end;
procedure TfmMain.tbnFirmaAboutClick(Sender: TObject);
begin
fmPClient.ShowModal;
end;
procedure TfmMain.N2Click(Sender: TObject);
begin
fmManage.ShowModal;
end;
procedure TfmMain.btnRabotiAboutClick(Sender: TObject);
begin
fmPwork.ShowModal;
end;
procedure TfmMain.btnBeginWorkClick(Sender: TObject);
begin
fmNewPClient.ShowModal;
end;
procedure TfmMain.N13Click(Sender: TObject);
begin
fmdirect.ShowModal;
end;
procedure TfmMain.BitBtn1Click(Sender: TObject);
begin
fmClient.ShowModal;
end;
procedure TfmMain.BitBtn2Click(Sender: TObject);
begin
fmDogovor.ShowModal;
end;
procedure TfmMain.BitBtn3Click(Sender: TObject);
begin
fmRegZayav.ShowModal;
end;
procedure TfmMain.FormClose(Sender: TObject; var Action: TCloseAction);
var Reg: TRegistry;
begin
//Сохранение параметров в реестре
Reg := TRegistry.Create;
Reg.RootKey:= HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Software\ExpertProject\EParam', false)
then begin
Reg.WriteString('SMTP сервер',ServerName);
Reg.WriteString('Имя регистрации на почтовом сервере',RegistrationName);
Reg.WriteString('Каталог шаблонов',ShablonDirectory);
Reg.WriteString('База потенциальных клиентов',LastPClientBase);
Reg.WriteString('База постоянных клиентов',LastClientBase);
Reg.WriteString('Адрес отправителя',adresfrom);
end;
Reg.Free;
//Сохранение параметров в реестре
Reg := TRegistry.Create;
Reg.RootKey:= HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Software\Microsoft\EPr\Params', false)
then begin
fmPass.Encrypt(param1,14,13,12);
fmPass.Encrypt(param2,14,13,12);
Reg.WriteString('Параметр 1',param1);
Reg.WriteString('Параметр 2',param2);
End;
Reg.Free;
fmMain.Hide;
fmPicture.Close;
end;
procedure TfmMain.N6Click(Sender: TObject);
begin
fmAlarm.ShowModal;
end;
procedure TfmMain.N14Click(Sender: TObject);
begin
fmLastWork.ShowModal;
end;
procedure TfmMain.Excel1Click(Sender: TObject);
begin
fmFromExcel.ShowModal;
end;
procedure TfmMain.N17Click(Sender: TObject);
begin
close;
end;
procedure TfmMain.FormShow(Sender: TObject);
var Reg: TRegistry;
begin
fmPicture.Visible:=false;
//Считывание параметров из реестра
Reg := TRegistry.Create;
try
Reg.RootKey:= HKEY_LOCAL_MACHINE;
if Reg.KeyExists('\Software\ExpertProject\EParam')
then begin
Reg.OpenKey('\Software\ExpertProject\EParam', True);
ServerName:=Reg.ReadString('SMTP сервер');
RegistrationName:=Reg.ReadString('Имя регистрации на почтовом сервере');
ShablonDirectory:=Reg.ReadString('Каталог шаблонов');
LastPClientBase:=Reg.ReadString('База потенциальных клиентов');
LastClientBase:=Reg.ReadString('База постоянных клиентов');
adresfrom:=Reg.ReadString('Адрес отправителя');
end;
finally
Reg.closeKey;
Reg.Free;
//Считывание параметров из реестра
Reg := TRegistry.Create;
try
Reg.RootKey:= HKEY_LOCAL_MACHINE;
if Reg.KeyExists('\Software\ExpertProject\EParam')
then begin
Reg.OpenKey('\Software\Microsoft\Epr\Params', True);
param1:=Reg.ReadString('Параметр 1');
param2:=Reg.ReadString('Параметр 2');
End;
Reg.Free;
inherited;
end;
//ПЕРЕКЛЮЧЕНИЕ НА ПОСЛЕДНЮЮ ОТКРЫТУЮ БАЗУ///////////////////////////////////
//Постоян. клиенты
Modul.taClient.Close;
Modul.taClient2.Close;
Modul.taCMailLink.Close;
Modul.taCMLink.Close;
Modul.taCMail.Close;
Modul.taCMail2.Close;
Modul.taDogovor.Close;
Modul.taAddDogovor.Close;
Modul.taCWLink.Close;
Modul.taCWLink2.Close;
Modul.taSotrudnRemem.Close;
Modul.taCRaboti.Close;
Modul.taAddCRaboti.Close;
Modul.taCRemem.Close;
Modul.taAddZayav.Close;
Modul.taZayav.Close;
Modul2.taBases.First;
while not Modul2.taBases.eof do begin
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=11)) then begin
Modul.taClient.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taClient2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=12)) then begin
Modul.taCMaillink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taCMLink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=13)) then begin
Modul.taCMail.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taCMail2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=14)) then begin
Modul.taDogovor.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taAddDogovor.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=15)) then begin
Modul.taCWLink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taCWLink2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taSotrudnRemem.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=16)) then begin
Modul.taCRaboti.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taCRemem.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taAddCRaboti.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=17)) then begin
Modul.taZayav.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul.taAddZayav.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
Modul2.taBases.Next;
end;
Modul.taClient.Open;
Modul.taClient2.Open;
Modul.taCMailLink.Open;
Modul.taCMLink.Open;
Modul.taCMail.Open;
Modul.taDogovor.Open;
Modul.taAddDogovor.Open;
Modul.taCWLink.Open;
Modul.taCWLink2.Open;
Modul.taCRaboti.Open;
Modul.taAddCRaboti.Open;
Modul.taAddZayav.Open;
Modul.taZayav.Open;
//Потенц. клиенты
Modal.taPClient.Close;
Modal.taPClient2.Close;
Modal.taPDogovor.Close;
Modal.taAddDogovor.Close;
Modal.taRabota.Close;
Modal.taAddRabota.Close;
Modal.taRemem.Close;
Modal.taRemSotrudn.Close;
Modal.taWLink.Close;
Modal.taWLink2.Close;
Modal.taMail.Close;
Modal.taMail2.Close;
Modal.taMailLink.Close;
Modal.taMailLinkAdd.Close;
Modal.taMLink.Close;
Modul2.taBases.First;
while not Modul2.taBases.eof do begin
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=1)) then begin
Modal.taPClient.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taPClient2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=2)) then begin
Modal.taMaillink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taMLink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taMaillinkAdd.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=3)) then begin
Modal.taMail.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taMail2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=4)) then begin
Modal.taPDogovor.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taAddDogovor.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=5)) then begin
Modal.taWLink.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taWLink2.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taRemSotrudn.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
if ((Modul2.taBases.FieldByName('BaseName').AsString=LastPClientBase)
and (Modul2.taBases.FieldByName('FileType').Value=6)) then begin
Modal.taRabota.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taRemem.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modal.taAddRabota.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
end;
Modul2.taBases.Next;
end;
Modal.taPClient.Open;
Modal.taPDogovor.Open;
Modal.taRabota.Open;
Modal.taAddRabota.Open;
Modal.taWLink.Open;
Modal.taWLink2.Open;
Modal.taMail.Open;
Modal.taMail2.Open;
Modal.taMailLink.Open;
Modal.taMailLinkAdd.Open;
Modal.taMLink.Open;
Label3.Caption:=LastPClientBase;
Label4.Caption:=LastClientBase;
end;
procedure TfmMain.N21Click(Sender: TObject);
begin
N21.Checked:=true;
Label1.Caption:='Поиск по названию организации';
Label2.Caption:='Поиск по названию организации';
//Переключение индексов для поиска
Modal.taPclient.IndexName:='company_ind';
Modul.taClient.IndexName:='company_ind';
edFind.clear;
edFind2.clear;
end;
procedure TfmMain.N22Click(Sender: TObject);
begin
N22.Checked:=true;
//Переключение индексов для поиска
Label1.Caption:='Поиск по имени контактного лица';
Label2.Caption:='Поиск по имени контактного лица';
Modal.taPClient.IndexName:='director_ind';
Modul.taClient.IndexName:='director_ind';
edFind.clear;
edFind2.clear;
end;
procedure TfmMain.N25Click(Sender: TObject);
begin
fmPCreateBase.ShowModal;
end;
procedure TfmMain.N26Click(Sender: TObject);
begin
fmCCreateBase.ShowModal;
end;
procedure TfmMain.btnExitClick(Sender: TObject);
begin
FormClose(Sender);
end;
procedure TfmMain.N24Click(Sender: TObject);
begin
fmSearchDog.ShowModal;
end;
procedure TfmMain.N19Click(Sender: TObject);
begin
fmCompSearch.ShowModal;
end;
procedure TfmMain.FormCreate(Sender: TObject);
begin
NeedPass:=0;
end;
procedure TfmMain.PrintLine(Items: TStringList);
var
OutRect: TRect;
Inches: double;
i: integer;
SaveFont: TFont;
begin
SaveFont := TFont.Create;
try
Savefont.Assign(Printer.Canvas.Font);
Printer.Canvas.Font.Assign(edtHeaderFont1.Font);
// First position the print rect on the print canvas
OutRect.Left := 0;
OutRect.Top := AmountPrinted;
OutRect.Bottom := OutRect.Top + LineHeight;
With Printer.Canvas do
for i := 0 to Items.Count - 1 do
begin
Inches := longint(Items.Objects[i]) * 0.1;
// Determine Right edge
OutRect.Right := OutRect.Left + round(PixelsInInchx*Inches);
if not Printer.Aborted then
// Print the line
TextRect(OutRect, OutRect.Left, OutRect.Top, Items[i]);
// Adjust right edge
OutRect.Left := OutRect.Right;
end;
{ As each line prints, AmountPrinted must increase to reflect how
much of a page has been printed on based on the line height. }
AmountPrinted := AmountPrinted + TenthsOfInchPixelsY*2;
finally
SaveFont.Free;
end;
end;
procedure TfmMain.PrintHeader(head:string);
var
SaveFont: TFont;
begin
{ Save the current printer's font, then set a new print font based
on the selection for Edit1 }
SaveFont := TFont.Create;
try
Savefont.Assign(Printer.Canvas.Font);
Printer.Canvas.Font.Assign(edtHeaderFont1.Font);
// First print out the Header
with Printer do
begin
if not Printer.Aborted then
Canvas.TextOut((PageWidth div 2)-(Canvas.TextWidth(edtHeaderFont1.Text)
div 2),0, 'База: '+head);
// Increment AmountPrinted by the LineHeight
AmountPrinted := AmountPrinted + LineHeight+TenthsOfInchPixelsY;
end;
// Restore the old font to the Printer's Canvas property
Printer.Canvas.Font.Assign(SaveFont);
finally
SaveFont.Free;
end;
end;
procedure TfmMain.PrintColumnNames;
var
ColNames: TStringList;
begin
{ Create a TStringList to hold the column names and the
positions where the width of each column is based on values
in the TEdit controls. }
ColNames := TStringList.Create;
try
// Print the column headers using a bold/underline style
Printer.Canvas.Font.Style := [fsBold, fsUnderline];
with ColNames do
begin
// Store the column headers and widths in the TStringList object
AddObject('N', pointer(5));
AddObject('Название организации', pointer(25));
AddObject('Телефон', pointer(15));
AddObject('Факс', pointer(15));
AddObject('Контактное лицо', pointer(25));
end;
PrintLine(ColNames);
Printer.Canvas.Font.Style := [];
finally
ColNames.Free; // Free the column name TStringList instance
end;
end;
procedure TfmMain.FormActivate(Sender: TObject);
begin
if NeedPass=0
then begin
fmPass.ShowModal;
if NeedPass=3 then fmPicture.Close; //отмена идентификации
end;
end;
procedure TfmMain.N27Click(Sender: TObject);
begin
fmSearchZayav.ShowModal;
end;
procedure TfmMain.N31Click(Sender: TObject);
begin
PrintDialog1.Execute;
end;
procedure TfmMain.N33Click(Sender: TObject);
var
Items: TStringList;
i:integer;
begin
{ Create a TStringList instance to hold the fields and the widths
of the columns in which they'll be drawn based on the entries in
the edit controls }
Items := TStringList.Create;
i:=1;
try
// Determine pixels per inch horizontally
PixelsInInchx := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
TenthsOfInchPixelsY := GetDeviceCaps(Printer.Handle,
LOGPIXELSY) div 7;
AmountPrinted := 0;
fmMain.Enabled := false; // Disable the parent form
try
Printer.BeginDoc;
Application.ProcessMessages;
{ Calculate the line height based on text height using the
currently rendered font }
LineHeight := Printer.Canvas.TextHeight('X')+TenthsOfInchPixelsY;
PrintHeader(LastClientBase);
PrintColumnNames;
////ПЕЧАТЬ ////////////////////////////////////
Modul.taClient.First;
{ Store each field value in the TStringList as well as its
column width }
while (not Modul.taClient.Eof) or Printer.Aborted do
begin
Application.ProcessMessages;
with Items do
begin
AddObject(IntToStr(i),pointer(5));
AddObject(Modul.taClient.FieldByName('NameSearch').AsString,
pointer(25));
AddObject(Modul.taClient.FieldByName('Thone').AsString,
pointer(15));
AddObject(Modul.taClient.FieldByName('Fax').AsString,
pointer(15));
AddObject(Modul.taClient.FieldByName('Director').AsString,
pointer(25));
i:=i+1;
end; //with Items do
PrintLine(Items);
{ Force print job to begin a new page if printed output has
exceeded page height }
if AmountPrinted + LineHeight > Printer.PageHeight then
begin
AmountPrinted := 0;
if not Printer.Aborted then
Printer.NewPage;
PrintHeader(LastClientBase);
PrintColumnNames;
end; //if AmountPrinted + LineHeight > Printer.PageHeight then
Items.Clear;
Modul.taClient.Next;
end; //while (not Modul.taClient.Eof) or Printer.Aborted
///////////////////////////////////////////////////////////
if not Printer.Aborted then
Printer.EndDoc;
finally // try Printer.BeginDoc;
fmMain.Enabled := true;
end;
finally
Items.Free;
end;
end;
procedure TfmMain.N34Click(Sender: TObject);
var
Items: TStringList;
i:integer;
begin
{ Create a TStringList instance to hold the fields and the widths
of the columns in which they'll be drawn based on the entries in
the edit controls }
Items := TStringList.Create;
try
// Determine pixels per inch horizontally
PixelsInInchx := GetDeviceCaps(Printer.Handle, LOGPIXELSX);
TenthsOfInchPixelsY := GetDeviceCaps(Printer.Handle,
LOGPIXELSY) div 7;
AmountPrinted := 0;
fmMain.Enabled := false; // Disable the parent form
try
Printer.BeginDoc;
i:=1;
Application.ProcessMessages;
{ Calculate the line height based on text height using the
currently rendered font }
LineHeight := Printer.Canvas.TextHeight('X')+TenthsOfInchPixelsY;
PrintHeader(LastPClientBase);
PrintColumnNames;
////ПЕЧАТЬ ////////////////////////////////////
Modal.taPClient.First;
{ Store each field value in the TStringList as well as its
column width }
while (not Modal.taPClient.Eof) or Printer.Aborted do
begin
Application.ProcessMessages;
with Items do
begin
AddObject(IntToStr(i),pointer(5));
AddObject(Modal.taPClient.FieldByName('NameSearch').AsString,
pointer(25));
AddObject(Modal.taPClient.FieldByName('Thone').AsString,
pointer(15));
AddObject(Modal.taPClient.FieldByName('Fax').AsString,
pointer(15));
AddObject(Modal.taPClient.FieldByName('Director').AsString,
pointer(25));
i:=i+1;
end; //with Items do
PrintLine(Items);
{ Force print job to begin a new page if printed output has
exceeded page height }
if AmountPrinted + LineHeight > Printer.PageHeight then
begin
AmountPrinted := 0;
if not Printer.Aborted then
Printer.NewPage;
PrintHeader(LastClientBase);
PrintColumnNames;
end; //if AmountPrinted + LineHeight > Printer.PageHeight then
Items.Clear;
Modal.taPClient.Next;
end; //while (not Modul.taClient.Eof) or Printer.Aborted
///////////////////////////////////////////////////////////
if not Printer.Aborted then
Printer.EndDoc;
finally // try Printer.BeginDoc;
fmMain.Enabled := true;
end;
finally
Items.Free;
end;
end;
procedure TfmMain.N35Click(Sender: TObject);
begin
{ Assign the font selected with FontDialog1 to Edit1. }
FontDialog1.Font.Assign(edtHeaderFont1.Font);
if FontDialog1.Execute then
edtHeaderFont1.Font.Assign(FontDialog1.Font);
end;
procedure TfmMain.N36Click(Sender: TObject);
begin
fmStat.ShowModal;
end;
procedure TfmMain.N11Click(Sender: TObject);
begin
Application.HelpFile := 'Справка.hlp';
Application.HelpCommand(HELP_FINDER, 0);
end;
end.
//Модуль “Работа с потенциальными клиентами”
unit pworkU;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Mask, DBCtrls, Grids, DBGrids, ExtCtrls, Menus, Buttons;
type
TfmPwork = class(TForm)
Label1: TLabel;
DBGrid1: TDBGrid;
Label2: TLabel;
DBGrid2: TDBGrid;
Label4: TLabel;
btnDotrudn: TButton;
Label6: TLabel;
DBEdit4: TDBEdit;
Label7: TLabel;
DBEdit5: TDBEdit;
DBEdit6: TDBEdit;
DBEdit7: TDBEdit;
DBNavigator1: TDBNavigator;
Edit1: TEdit;
MainMenu1: TMainMenu;
N1: TMenuItem;
mnPutDates: TMenuItem;
btnClose: TBitBtn;
btnToClient: TBitBtn;
N3: TMenuItem;
mnClose: TMenuItem;
N5: TMenuItem;
mnDel: TMenuItem;
procedure btnCloseClick(Sender: TObject);
procedure btnDotrudnClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure DBGrid1CellClick(Column: TColumn);
procedure DBGrid1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
procedure mnPutDatesClick(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure mnCloseClick(Sender: TObject);
procedure mnDelClick(Sender: TObject);
procedure btnToClientClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure WorkersDraw;
end;
var
fmPwork: TfmPwork;
implementation
uses Modal1, SotrudnU, CModul;
{$R *.DFM}
//Процедура вывода в поля вывода ответсвенных сотрудников
procedure TfmPwork.WorkersDraw;
var i:integer;
begin
Edit1.Text:=' ';
Modal.taWLink2.Open;
Modal.taWLink2.First;
for i:=1 to Modal.taWLink2.RecordCount do begin
if Edit1.Text[Pos(Modal.taWLink2.FieldByName('WorkerName').AsString, Edit1.Text)]='' then
Edit1.Text:=Edit1.Text+Modal.taWLink2.FieldByName('WorkerName').AsString+' ';
Modal.taWLink2.Next;
end;
end;
procedure TfmPwork.btnCloseClick(Sender: TObject);
begin
Close;
end;
procedure TfmPwork.btnDotrudnClick(Sender: TObject);
begin
fmWorkers.ShowModal;
end;
procedure TfmPwork.FormShow(Sender: TObject);
begin
WorkersDraw;
fmPWork.Caption:='О работах с '+Modal.taPclient.FieldByName('CompanyName').AsString;
end;
procedure TfmPwork.DBGrid1CellClick(Column: TColumn);
begin
WorkersDraw;
end;
procedure TfmPwork.DBGrid1KeyUp(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
FormShow(Sender);
end;
//Процедура автоматической простановки дат
procedure TfmPwork.mnPutDatesClick(Sender: TObject);
var LastDate:TDate;
i:integer;
begin
for i:=Modal.taRabota.RecNo to Modal.taRabota.RecordCount-1 do begin
LastDate:= Modal.taRabota.FieldByName('DatePlan').Value;
Modal.taRabota.Next;
//Смотрим указано ли к-во дней до этой работы
Modal.taRaboti2.Open;
Modal.taRaboti2.FindKey([Modal.taRabota.FieldByName('Rabota_ID').Value]);
if Modal.taRaboti2.FieldByName('DayNumber').Value<>0
then begin
Modal.taRabota.Edit;
Modal.taRabota.FieldByName('DatePlan').Value:=LastDate+Modal.taRaboti2.FieldByName('DayNumber').Value;
Modal.taRabota.Post;
end
else break;
end;
end;
procedure TfmPwork.FormClose(Sender: TObject; var Action: TCloseAction);
begin
Modal.taRaboti2.Close;
end;
procedure TfmPwork.mnCloseClick(Sender: TObject);
begin
Close;
end;
//Каскадное удаление данных о работах из таблиц
procedure TfmPwork.mnDelClick(Sender: TObject);
begin
if Application.MessageBox('Вы действительно хотите удалить информацию о предварительной заявке?',
'Подтвердите удаление базы',MB_YESNO + MB_ICONQUESTION) = IDYES
then begin
//Удаление всех работ, назначееных исполнителям
Modal.taWLink2.First;
while not Modal.taWLink2.Eof do Modal.taWLink2.Delete;
if Modal.taWLink.Active=true then Modal.taWLink.Refresh;
if Modal.taRemSotrudn.Active=true then Modal.taRemSotrudn.Refresh;
//Удаление всех работ по предварит. заявке
Modal.taRabota.First;
while not Modal.taRabota.Eof do Modal.taRabota.Delete;
if Modal.taRemem.Active=true then Modal.taRemem.Refresh;
if Modal.taAddRabota.Active=true then Modal.taAddRabota.Refresh;
//Удаляем предв. заявку
Modal.taPDogovor.Delete;
if Modal.taPDogovor.RecordCount=0 then Edit1.Clear
else WorkersDraw;
end;
end;
//Процедура перевода потенциального клиента в разряд постоянных
procedure TfmPwork.btnToClientClick(Sender: TObject);
begin
Modul.taClient.Insert;
Modul.taClient.FieldByName('CompanyName').Value:=Modal.taPClient.FieldByName('CompanyName').Value;
Modul.taClient.FieldByName('NameSearch').Value:=Modal.taPClient.FieldByName('NameSearch').Value;
Modul.taClient.FieldByName('Adres').Value:=Modal.taPClient.FieldByName('Adres').Value;
Modul.taClient.FieldByName('Director').Value:=Modal.taPClient.FieldByName('Director').Value;
Modul.taClient.FieldByName('EMail').Value:=Modal.taPClient.FieldByName('EMail').Value;
Modul.taClient.FieldByName('Thone').Value:=Modal.taPClient.FieldByName('Thone').Value;
Modul.taClient.FieldByName('Fax').Value:=Modal.taPClient.FieldByName('Fax').Value;
Modul.taClient.FieldByName('Type').Value:=Modal.taPClient.FieldByName('Type').Value;
Modul.taClient.FieldByName('Comments').Value:=Modal.taPClient.FieldByName('Comments').Value;
Modul.taClient.FieldByName('CManage').Value:=Modal.taPClient.FieldByName('CManage').Value;
Modul.taClient.FieldByName('Manage').Value:=Modal.taPClient.FieldByName('Manage').Value;
Modul.taClient.FieldByName('CDoljnost').Value:=Modal.taPClient.FieldByName('CDoljnost').Value;
Modul.taClient.FieldByName('Doljnost').Value:=Modal.taPClient.FieldByName('Doljnost').Value;
Modul.taClient.FieldByName('COtrasl').Value:=Modal.taPClient.FieldByName('COtrasl').Value;
Modul.taClient.FieldByName('Otrasl').Value:=Modal.taPClient.FieldByName('Otrasl').Value;
Modul.taClient.Post;
end;
end.
//Модуль “Поиск заявки”
unit sechz;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
Buttons, StdCtrls;
type
TfmSearchZayav = class(TForm)
Label1: TLabel;
Edit1: TEdit;
Button3: TButton;
Label2: TLabel;
Edit2: TEdit;
BitBtn1: TBitBtn;
Button1: TButton;
procedure BitBtn1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
ss3:string;
ss4:string;
procedure DogovorSearch(n:string;str:string);
procedure CompanySearch(m:integer; str:string;n:string);
end;
var
fmSearchZayav: TfmSearchZayav;
implementation
uses Modul3, compsach, Modal1, CModul;
{$R *.DFM}
procedure TfmSearchZayav.BitBtn1Click(Sender: TObject);
begin
close;
end;
procedure TfmSearchZayav.CompanySearch(m:integer; str:string; n:string);
begin
Modul2.taBases.First;
//Ищем нужную базу
while not Modul2.taBases.eof do begin
if str=Modul2.taBases.FieldByName('BaseName').AsString then break;
Modul2.taBases.Next;
end;
while not Modul2.taBases.eof do begin
if ((Modul2.taBases.FieldByName('FileType').AsString='1')
or (Modul2.taBases.FieldByName('FileType').AsString='11'))
then begin
Modul2.taSearch.close;
Modul2.taSearch.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul2.taSearch.IndexName:='';
Modul2.taSearch.Open;
if ((Modul2.taSearch.FindKey([m])=true) and (str=Modul2.taBases.FieldByName('BaseName').AsString)) //организация найдена
then begin
ss4:=Modul2.taSearch.FieldByName('NameSearch').AsString;
Edit2.Text:=Edit2.Text+'\'+Modul2.taSearch.FieldByName('NameSearch').AsString+'\'+n;
Modul2.taSearch.IndexName:='';
break;
end
else Edit2.Text:='нет такой заявки';
Modul2.taSearch.Close;
end;
Modul2.taBases.Next;
end;
end;
procedure TfmSearchZayav.DogovorSearch(n:string;str:string);
begin
Modul2.taBases.First;
//Ищем нужную базу
while not Modul2.taBases.eof do begin
if str=Modul2.taBases.FieldByName('BaseName').AsString then break;
Modul2.taBases.Next;
end;
//ищем нужный файл с договорами
while not Modul2.taBases.eof do begin
if Modul2.taBases.FieldByName('FileType').AsString='14'
then begin
Modul2.taSearch.close;
Modul2.taSearch.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul2.taSearch.IndexName:='';
Modul2.taSearch.Open;
//ищем в нем нужный номер договора
if ((Modul2.taSearch.FindKey([n])=true) and (str=Modul2.taBases.FieldByName('BaseName').AsString)) //договор найден
then begin
ss3:=Modul2.taBases.FieldByName('BaseName').AsString;
//ищем теперь компанию
CompanySearch(Modul2.taSearch['Company_ID'],Modul2.taBases.FieldByName('BaseName').AsString,n);
break;
end;
Modul2.taSearch.Close;
end;
Modul2.taBases.Next;
end;
end;
procedure TfmSearchZayav.Button3Click(Sender: TObject);
begin
Modul2.taSearch.close;
Modul2.taBases.First;
while not Modul2.taBases.eof do begin
if Modul2.taBases.FieldByName('FileType').AsString='17'
then begin
Modul2.taSearch.TableName:=Modul2.taBases.FieldByName('FileName').AsString;
Modul2.taSearch.IndexName:='zayav_ind';
Modul2.taSearch.Open;
if Modul2.taSearch.FindKey([Edit1.Text])=true //договор найден
then begin
//Ищем название организации
Modul2.taSearch.IndexName:=' ';
Edit2.Text:=Modul2.taBases.FieldByName('BaseName').AsString;
DogovorSearch(Modul2.taSearch['Dogovor'],Modul2.taBases.FieldByName('BaseName').AsString);
break;
end;
Modul2.taSearch.Close;
end;
Modul2.taBases.Next;
end;
ShowMessage('Поиск завершен');
end;
procedure TfmSearchZayav.Button1Click(Sender: TObject);
begin
if Edit2.Text<>'' then begin
fmCompSearch.CClientOpen(ss3);
fmCompSearch.PClientOpen(ss3);
//Поиск по названию организации в базах потенциальных клиентов
Modal.taPClient.FindNearest([ss4]);
Modul.taClient.FindNearest([ss4]);
end;
end;
end.