unit SVAProcLib;
interface
uses Windows, SysUtils, Forms, DB, DBTables, DBGrids,
Variants, StdCtrls, Classes, Controls, ComCtrls, ShellAPI, DBITypes;
{ DeleteFile есть и в Windows и в SysUtils.
В программе исп-ся SysUtils.DeleteFile(f:string):boolean,
для этого (!?) порядок должен быть: Windows, SysUtils }
const
{ Цвета }
ColorBlue = $FFCC99; // для заголовков в StringGrid1
ColorBBlue = $FF9966; // я-голубой
ColorLBlue = $FFFFC0; // св-гол.
ColorGrBlue = $A56E3A; // серо-голубой
ColorBluGreen= $FFCC00; // св.син-зел
ColorDarkGr = $603000; // для линий в заголовках =RGB(124,92,60)
ColorBYellow = $80FFFF; // я-желтый
ColorLYellow = $99FFFF; // св-жел.
ColorYellow = $C0FFFF; // слабый желтый
ColorPYellow = $CCFFFF; // бледно-желтый (pale yellow)
ColorLBrown = $99CCFF; // св-коричневый
ColorPBrown = $C0D8FF; // бл-кор. (pale brown)
ColorLGreen = $CCFFCC; // св-зел
ColorPGreen = $E4FFE4; // бл-зел (pale green)
type
// Для простого справочника (список наименований)
TSprv = packed record
Cod: integer;
Name: array[0..79] of char;
end;
TLSprv = array of TSprv;
TSprPNom = array of SmallInt; { Код => Порядковый № в List (c 0) }
{ простой справочник }
TSprav = class(TObject)
Spr : TLSprv;
Count: integer;
PNom : TSprPNom;
MaxCod: integer;
constructor Create(FName:string);
procedure Clear;
destructor Destroy; override;
function CodToName(Cod:integer):string;
end;
procedure CreateSprv(FName:string);
procedure CmBoxSprvTextShow(CmBox:TComboBox; Cod:integer; Sprav:TSprav);
procedure CmBoxSpravCloseUp(CmBox:TComboBox; Tab:TTable; Pole: string;
Sprav: TSprav);
procedure RusKeyboard(Rus:boolean);
function Space(l:integer):string;
procedure DOStoWin(var s:string);
procedure WinToDOS(var s:string);
procedure Del2Char(var s:string; c:char);
procedure Del2Space(var s:string);
procedure Del2Minus(var s:string);
procedure StringToChar(s:string; var c; n:integer);
function Find(const Substr, S: string; StartPos:integer): integer;
function FindBack(const Substr, S: string; StartPos:integer): integer;
procedure StrDoubleChar(var s:string; c:Char);
procedure CopyFile1(const SourceFileName, TargetFileName: string);
function CopyFiles(PBuf:pchar; DestDir:string; Wnd:HWND):boolean;
function AgeP(Date1,Date2: tDateTime): integer;
function InputString(const ACaption, APrompt, ADefault: string;
const MLength, PswB: byte): string;
procedure CalcWidth(i:integer; DBGrid: TDBGrid);
procedure CalcWidthLV(i:integer; ListView: TListView);
procedure GetDiskList(var d, Dr: string);
function xlColumnName(col:integer):string;
function BoolToInt(Field:TField):integer;
function ControlNumber(s:string; Count:integer):boolean;
procedure CmBoxTextShow(CmBox:TComboBox; Cod:integer);
function IndexByCode(Code:integer; Sprav:TSprav):integer;
function NameByCode(Code:integer; Sprav:TSprav):string;
procedure CmBoxSpravShow(CmBox:TComboBox; Cod:integer; Sprav:TSprav);
procedure CmBoxCloseUp(CmBox:TComboBox; Tab:TTable; Pole:string);
function FilesFound(FNames:string):boolean;
function MakeFile(FName:string):boolean;
function FileDate(FName: string): tDateTime;
function StrFileSize(FSize:integer):string;
function StrFDateTime(DT:integer):string;
procedure DelFiles(FNames:string);
function IndxControlDB(FName:string; INames:string):boolean;
procedure DelIndexes(FName:string);
function SaveToArchive(RarFileName, Keys, FNames:string; var Msg:string;
BackFrm:TForm):boolean;
procedure FRarUnpack(RarFile, Keys, FNames, DirTarget: string; BackFrm:TForm);
function PackDBF(FName:string):boolean;
procedure PackTable(Tbl: TTable);
function FieldString(Field:TField):string;
function CheckIndF(FName,IFName: string): boolean;
procedure TableDBaseIII(FName:string; LangCode:byte);
procedure IndxCreate(FN,IndF,KeyF: string);
function Max2(X,Y:integer):integer;
function Max3(X,Y,Z:integer):integer;
function Min2(n1,n2:integer):integer;
function Itogo(v:currency):string;
implementation
{ ======== Для объекта TSprav ======== }
constructor TSprav.Create(FName:string);
var
Tab: TTable;
i: integer; s: string;
begin
Clear;
MaxCod:= 0;
if not FileExists(FName) then
CreateSprv(FName);
Tab:= TTable.Create(nil);
with Tab do begin
close;
TableName:= FName;
open;
Count:= RecordCount;
if Count > 0 then begin
SetLength(Spr, Count);
for i:= 0 to pred(Count) do begin
Spr[i].Cod:= Fields[0].Value;
s:= Fields[1].AsString;
StringToChar(s, Spr[i].Name, 80);
if Spr[i].Cod > MaxCod then MaxCod:= Spr[i].Cod;
if i < pred(Count) then Next
end
end;
close; Free;
end { with Tab };
{ Заполнение массива порядковых номеров }
SetLength(PNom, 0);
SetLength(PNom, succ(MaxCod)); // т.к.0-й не исп-ся
for i:= 0 to MaxCod do PNom[i]:= -1; // -1 = кода нет
if Count > 0 then
for i:= 0 to pred(Count) do PNom[Spr[i].Cod]:=i;
end; { Create }
procedure TSprav.Clear;
begin
SetLength(Spr,0); SetLength(PNom,0);
MaxCod:=0; Count:=0;
end;
destructor TSprav.Destroy;
begin
Clear
end;
function TSprav.CodToName(Cod:integer):string;
begin
Result:= '';
if (Cod > 0) and (Cod <= MaxCod) then
if PNom[Cod] >= 0 then
Result:= Spr[PNom[Cod]].Name
end;
{ ========== Использование TSprav ============ }
{ --- Разные мелкие справочники - создание ---- }
procedure CreateSprv(FName:string);
begin
with TTable.Create(nil) do begin
TableName:= FName;
with FieldDefs do begin
Clear;
Add('Cod',ftAutoInc,0,false);
Add('Name',ftString,80,false);
end;
CreateTable;
Free
end;
end;
{ ======== По Cod задать ComboBox.ItemIndex и ComboBox.Text ======== }
{ ---- для справочников типа TSprav ---- }
procedure CmBoxSprvTextShow(CmBox:TComboBox; Cod:integer; Sprav:TSprav);
var k: integer; // Cod = 1..Sprav.MaxCod
begin
k:= -1;
if (Cod > 0) and (Cod <= Sprav.MaxCod) then
k:= Sprav.PNom[Cod];
with CmBox do begin
if (k >= 0) and (k < Items.Count) then begin
ItemIndex:= k;
Text:= Items[k];
end
else begin
ItemIndex:= -1;
Text:=''
end;
end;
end;
{ --- Выбор в ComboBox - для TSprav --- }
procedure CmBoxSpravCloseUp(CmBox:TComboBox; Tab:TTable; Pole: string;
Sprav: TSprav);
var
k: integer; Field: TField;
begin
k:= CmBox.ItemIndex;
Field:= Tab.FieldByName(Pole);
if k < 0 then begin
CmBox.Text:= '';
if not Field.IsNull then Field.Value:= Null;
exit
end;
CmBox.Text:= CmBox.Items[k];
k:= Sprav.Spr[k].Cod;
if Field.AsInteger <> k then Field.AsInteger:= k
end;
{ ==== Самостоятельные процедуры и функции общего назначения ===== }
{ --- Включение/выкл. русской раскладки клавиатуры ---- }
procedure RusKeyboard(Rus:boolean);
const
Cod: array[false..true] of string = ('00000409','00000419');
var
Layout: array[0..KL_NAMELENGTH] of char;
begin
LoadKeyboardLayout(StrCopy(Layout,PChar(Cod[Rus])),KLF_ACTIVATE);
end;
{ ----- Строка пробелов ----- }
function Space(l:integer):string;
var i:integer;
begin
Result:= '';
for i:=1 to l do Result:= Result + ' ';
end;
{ -------- Перевод кодировки из MS-DOS в Windows -------- }
procedure DOStoWin(var s:string);
var p: PAnsiChar;
begin
if s = '' then exit;
p:= PAnsiChar(s); // указатель на s
OEMToChar(p, p);
s:= p
end;
{ -------- Перевод кодировки из Windows в MS-DOS -------- }
procedure WinToDOS(var s:string);
var p: PAnsiChar;
begin
if s = '' then exit;
p:= PAnsiChar(s);
CharToOem(p,p);
s:= p;
end;
{ -- Удаление лишних двойных символов внутри строки -- }
procedure Del2Char(var s:string; c:char);
var k:integer;
begin
if length(s) = 0 then exit;
k:= pos(c+c, s);
while k > 0 do begin
delete(s, k, 1);
k:= pos(c+c, s);
end
end;
{ -- Удаление лишних пробелов внутри строки -- }
procedure Del2Space(var s:string);
begin
Del2Char(s, ' ')
end;
{ -- Удаление лишних черточек внутри строки -- }
procedure Del2Minus(var s:string);
begin
Del2Char(s, '-')
end;
{ --- string -> array of char --- }
procedure StringToChar(s:string; var c; n:integer);
var a:string;
begin
a:= TrimRight(s);
FillChar(c,n,0);
if length(a) > n then move(a[1],c,n)
else move(a[1],c,length(s));
end;
{ ------ Поиск фрагмента Substr в строке S с позиции StartPos ------ }
// любой регистр
function Find(const Substr, S: string; StartPos:integer): integer;
var
i, j, d: integer;
begin
Result:= 0;
d:= length(S) - length(Substr);
if d < 0 then exit;
for i:= StartPos to d + 1 do
for j:= 1 to length(Substr) do
if AnsiUpperCase(Substr[j]) <> AnsiUpperCase(S[i + j - 1]) then
break
else if j = length(Substr) then
begin
Result:= i;
exit;
end;
end;
{ ------ Поиск назад (к началу строки) ------- }
function FindBack(const Substr, S: string; StartPos:integer): integer;
var
i, j, d: integer;
begin
Result:= 0;
d:= length(S) - length(Substr);
if d < 0 then exit;
if StartPos > d + 1 then exit;
for i:= StartPos downto 1 do
for j:= 1 to length(Substr) do
if AnsiUpperCase(Substr[j]) <> AnsiUpperCase(S[i + j - 1]) then
break
else if j = length(Substr) then
begin
Result:= i;
exit;
end;
end;
{ ------ Дублирование символа (кавычек) ------- }
procedure StrDoubleChar(var s:string; c:Char);
var i: integer;
begin
i:=0;
while i < length(s) do begin
inc(i);
if s[i] = c then begin
insert(c, s, i); inc(i)
end;
end;
end;
{ --- Копирование НЕ на дискету --- }
procedure CopyFile1(const SourceFileName, TargetFileName: string);
var
S, T : TFileStream; // uses Classes
begin
if not FileExists(SourceFileName) then exit;
S:= nil; T:= nil;
try
SysUtils.DeleteFile(TargetFileName);
S:= TFileStream.Create(SourceFileName, fmOpenRead);
T:= TFileStream.Create(TargetFileName, fmOpenWrite or fmCreate);
T.CopyFrom(S, S.Size);
FileSetDate(T.Handle, FileGetDate(S.Handle));
finally
if T <> nil then T.Free;
if S <> nil then S.Free;
end;
end;
{ ------ если копировать пачку файлов чисто как Windows ------ }
function CopyFiles(PBuf:pchar; DestDir:string; Wnd:HWND):boolean;
{ PBuf - указатель на строку Buf:array[0..4096] of char,
где файлы перечислены через 1 символ #0 (#0#0 - конец) }
var FO : TSHFileOpStruct; // uses ShellAPI
begin
FillChar(FO, sizeof(FO), #0);
FO.Wnd:= Wnd; // окно, где показывать
FO.wFunc:= FO_COPY; // еще бывает FO_DELETE, FO_MOVE, FO_RENAME (?)
FO.pFrom:= PBuf;
FO.pTo:= PChar(DestDir);
FO.fFlags:= 0;
Result:= (SHFileOperation(Fo) = 0) and not Fo.fAnyOperationsAborted;
Application.ProcessMessages;
{ после этого может быть активным чужое окошко - проблемка, однако
Self.Activate; Application.ProcessMessages; - не помогает }
// если просто 1 файл, то достаточно:
// if CopyFile('C:\MKB.rar', 'D:\MKB.rar', true) then ShowMessage('OK!');
{ - - - - - - - - - - - - пример
procedure TForm1.Button1Click(Sender: TObject);
var s: string;
begin
s:= 'C:\MKB.rar'#0'C:\MKB1.rar'#0'C:\Ex06.rar'#0#0;
if CopyFiles(PChar(s), 'D:\TEMP\', Handle) then ShowMessage('OK')
end;
}
{ или
var
Buffer : array[0..4096] of char;
p : pchar;
begin
FillChar(Buffer, sizeof(Buffer), #0);
p:= @Buffer;
p:= StrECopy(p, 'C:\MKB.rar') + 1; // заполняется Buffer и указатель p
// сдвигается на 1 дальше, чтобы все слова перечислялись через #0
p:= StrECopy(p, 'C:\MKB1.rar') + 1;
p:= StrECopy(p, 'C:\Ex06.rar') + 1;
StrECopy(p, 'C:\MKB.rar');
if CopyFiles(p, 'D:\TEMP\', Handle) then ShowMessage('OK')
}
end; { CopyFiles }
{ ---- Кол-во полных лет между датами Date1 и Date2 ---- }
function AgeP(Date1,Date2: tDateTime): integer;
var Y1,M1,D1,Y2,M2,D2: word; Age: integer;
begin
DecodeDate(Date2,Y2,M2,D2);
DecodeDate(Date1,Y1,M1,D1);
Age:= Y2 - Y1;
if M2*31 + D2 < M1*31 + D1 then dec(Age);
Result:= Age
end;
{ ---- Из Dialogs.pas со своим упрощением ---- }
function InputString(const ACaption, APrompt, ADefault: string;
const MLength, PswB: byte): string;
var
Form: TForm;
Prompt: TLabel;
Edit: TEdit;
Button1Left, ButtonTop, ButtonWidth, ButtonHeight,
FrmClWidth, n: Integer;
begin
Result := ADefault;
Form := TForm.Create(Application);
with Form do
try
// параметры (свойства) формы
Canvas.Font := Font;
BorderStyle := bsDialog;
Caption := ACaption;
FrmClWidth := MLength * 8 + 32;
if FrmClWidth < 240 then FrmClWidth := 240
else if FrmClWidth > 640 then FrmClWidth := 640;
ClientWidth := FrmClWidth;
Position := poScreenCenter;
// Label.Caption := APrompt;
Prompt := TLabel.Create(Form);
with Prompt do begin
Parent := Form;
AutoSize := false;
Caption := APrompt;
Left := 16;
Top := 16;
Width := FrmClWidth - 32;
n := Canvas.TextWidth(APrompt);
if n > Width then
Height := Height * (n div Width + 1);
WordWrap := True;
end;
// Строка редактирования
Edit := TEdit.Create(Form);
with Edit do begin
if PswB = 0 then PasswordChar := #0
else PasswordChar := '#';
Parent := Form;
Left := Prompt.Left;
Top := Prompt.Top + Prompt.Height + 5;
Width := FrmClWidth - 32;
MaxLength := MLength;
Text := ADefault;
SelectAll;
end;
// параметры кнопок
ButtonTop := Edit.Top + Edit.Height + 15;
ButtonWidth := 97;
ButtonHeight := 25;
Button1Left := (FrmClWidth div 2) - 20 - ButtonWidth;
if Button1Left < 16 then Button1Left := 16;
// кнопка 'OK'
with TButton.Create(Form) do begin
Parent := Form;
Caption := 'OK';
ModalResult := mrOk;
Default := True;
SetBounds(Button1Left, ButtonTop, ButtonWidth, ButtonHeight);
end;
// кнопка 'Отказаться'
with TButton.Create(Form) do begin
Parent := Form;
Caption := 'Отказаться';
ModalResult := mrCancel;
Cancel := True;
SetBounds(Form.ClientWidth - Button1Left - ButtonWidth,
ButtonTop, ButtonWidth, ButtonHeight);
Form.ClientHeight := Top + Height + 13;
end;
// Показ формы и получение результата
if ShowModal = mrOk then Result := Edit.Text;
finally
Form.Free;
end;
end; { InputString }
{ ----- Подсчет ширины i-го столбца в DBGrid ----- }
{ для того чтобы подогнать все столбцы на всю ширину DBGrid.
Предполагается, что ширина всех остальных столбцов уже задана.
Если значение DBGrid.Width слишком мало, то никаких действий не будет}
procedure CalcWidth(i:integer; DBGrid: TDBGrid);
var j,n:integer; // не ранее FormShow
begin
with DBGrid do begin
n:= ClientWidth;
if dgIndicator in DBGrid.Options then dec(n,12);
for j:= 0 to Columns.Count - 1 do
if j<>i then begin
dec(n, Columns[j].Width);
if dgColLines in DBGrid.Options then dec(n)
end;
if n < 4 then exit; // critical error
Columns[i].Width:= n;
end;
Application.ProcessMessages;
end; { CalcWidth }
{ ----- Подсчет ширины i-го столбца в ListView ----- }
{ для того чтобы подогнать все столбцы на всю ширину ListView
предполагается, что ширина всех остальных столбцов уже задана }
// TListView : uses ComCtrls
procedure CalcWidthLV(i:integer; ListView: TListView);
// in FormActivate
var
j,n,n0:integer;
begin
with ListView do begin
n:= ClientWidth;
n0:= n;
for j:= 0 to Columns.Count - 1 do
if j<>i then dec(n, Columns[j].Width);
if n < 4 then exit; // critical error
Columns[i].Width:= n;
Application.ProcessMessages;
{ В основном здесь и всё, но можно и проверить ScrollBar -
например, до пересчета Columns[i].Width был HorScroll,
а после - он исчез, появилась в конце строка, и затем исчез VertScroll.
Тогда можно и увеличить Columns[i].Width }
if ClientWidth <> n0 then
Columns[i].Width:= n + ClientWidth - n0;
end;
end; { CalcWidthLV }
{ ----- Список разделов дисков ----- }
procedure GetDiskList(var d, Dr: string);
var // d - список разделов, Dr - соотв. ему список кодов устройств
s: string; n: Integer; c: char;
begin
d:= ''; Dr:= '';
for c:= 'A' to 'Z' do begin
s:= c + ':\';
n:= GetDriveType(Pchar(s));
case n of
0: { Тип диска невозможно определить };
1: { не существует };
2..5: { DRIVE_REMOVABLE (2), DRIVE_FIXED (3),
DRIVE_REMOTE (4), DRIVE_CDROM (5) }
begin
d:= d + c;
Dr:= Dr + IntToStr(n)
end;
DRIVE_RAMDISK: ; { 6 - Диск явяляется RAM диском }
end; { case }
end;
end;
{ ----- Для Excel: № столбца -> буквы столбца ----- }
function xlColumnName(col:integer):string;
var k: integer;
begin
if Col < 27 then Result:= chr(64 + Col) // 'A'..'Z'
else begin // 'AA'..'ZZ'
k:= (Col - 1) div 26;
Result:= chr(64 + k);
k:= (Col - 1) mod 26;
Result:= Result + chr(65 + k)
end
end;
{ --- BooleanField --> 1, 0, -1 --- }
function BoolToInt(Field:TField):integer;
begin
if Field.IsNull then Result:= -1 // Null
else if Field.AsBoolean then Result:= 1 // true
else Result:= 0; // false
end;
{ ------- Контроль цифрового номера -------- }
function ControlNumber(s:string; Count:integer):boolean;
var i:integer; // Count=0 - любое кол-во
begin
Result:=false;
if Count<>0 then
if length(s) <> Count then exit;
for i:=1 to length(s) do
if not(s[i] in ['0'..'9']) then exit;
Result:=true;
end;
{ ------- По Cod задать ComboBox.Text -------- }
procedure CmBoxTextShow(CmBox:TComboBox; Cod:integer);
var k: integer; // Cod = 1..CmBox.Items.Count
begin
k:= pred(Cod);
with CmBox do begin
if (k >= 0) and (k < Items.Count) then begin
ItemIndex:= k;
Text:= Items[k];
end
else begin
ItemIndex:= -1;
Text:= ''
end;
end;
end;
{ ------ По коду определить индекс в TSprav ------ }
function IndexByCode(Code:integer; Sprav:TSprav):integer;
begin
if (Code < 1) or (Code > Sprav.MaxCod) then Result:= -1
else Result:= Sprav.PNom[Code]
end;
{ ------ По коду определить Name в TSprav ------ }
function NameByCode(Code:integer; Sprav:TSprav):string;
var k:integer;
begin
k:= IndexByCode(Code, Sprav);
if k >= 0 then Result:= Sprav.Spr[k].Name
else Result:= ''
end;
{ ----- По Коду задать CmBox.ItemIndex в TSprav ----- }
procedure CmBoxSpravShow(CmBox:TComboBox; Cod:integer; Sprav:TSprav);
begin
CmBox.ItemIndex:= IndexByCode(Cod, Sprav);
end;
{ ------------ ComboBox_CloseUp ------------- }
// Выбор в ComboBox
procedure CmBoxCloseUp(CmBox:TComboBox; Tab:TTable; Pole:string);
var k: integer; Field: TField;
begin
k:= CmBox.ItemIndex;
Field:= Tab.FieldByName(Pole);
if k < 0 then begin
CmBox.Text:= '';
if not Field.IsNull then Field.Value:= Null;
exit
end;
if k < CmBox.Items.Count then begin
CmBox.Text:= CmBox.Items[k];
inc(k);
if Field.AsInteger <> k then Field.AsInteger:= k
end
end;
{ ---- Найдены ли файлы (можно с маской) ---- }
function FilesFound(FNames:string):boolean;
var SR: TSearchRec;
begin
Result:= true;
if FindFirst(FNames, faAnyFile, SR) <> 0 then
Result:= false;
FindClose(SR);
end;
{ ---- Создание пустого файла ---- }
function MakeFile(FName:string):boolean;
var f:file;
begin
Result:= true;
AssignFile(f,FName);
try
rewrite(f);
CloseFile(f);
except
Result:= false
end;
end;
{ ---- Дата файла ---- }
function FileDate(FName: string): tDateTime;
var Date0, Hnd: integer;
begin
Result:= 0;
if not FileExists(FName) then exit;
Hnd:= FileOpen(FName, 2);
Date0:= FileGetDate(Hnd);
Result:= FileDateToDateTime(Date0);
FileClose(Hnd);
end;
{ -- Размер файла (с разделителями) -- }
function StrFileSize(FSize:integer):string;
begin
Result:= FloatToStrF(FSize, ffNumber, 9, 0); // SysUtils
end;
{ --- Дата и время файла в виде <dd.mm.yyyy hh:mm> --- }
function StrFDateTime(DT:integer):string;
// Dates: 01.01.1980 - 31.12.2107 (128 years)
// сутки 65536 и более - не знаю закономерности
var D: tDateTime; FormatSettings: TFormatSettings;
begin
D:= FileDateToDateTime(DT);
with FormatSettings do begin
ShortDateFormat:= 'dd/mm/yyyy';
DateSeparator:= '.';
TimeSeparator:= ':';
LongTimeFormat:= 'hh:mm';
end;
Result:= DateToStr(D, FormatSettings) + ' ' + TimeToStr(D, FormatSettings);
{ если с одним пробелом, то можно и короче:
Result:= DateTimeToStr(D, FormatSettings); }
end;
{ ---- Удаление файлов с маской ---- }
procedure DelFiles(FNames:string);
var
SR: TSearchRec; sDir: string;
begin
sDir:= ExtractFilePath(FNames);
if FindFirst(FNames, faAnyFile, SR) <> 0 then begin
SysUtils.FindClose(SR);
exit;
end;
repeat
SysUtils.DeleteFile(sDir + SR.Name);
until FindNext(SR) <> 0;
SysUtils.FindClose(SR);
end;
{ --------- Проверка индексных файлов в DB --------- }
function IndxControlDB(FName:string; INames:string):boolean;
// INames - перечисление имен через запятую (не более 32)
// Сначала на наличие файлов PX, XG?, YG?
// отсутствие PX не замечается - только при проверке др. индексов
var
Tab:TTable; s,f: string; GoodIndex: boolean;
i,j,k: integer; c: char; eX, eY: string[3];
// Проверка простого наличия инд. файла
function FileControl(ExtName:string): boolean;
begin
Result:= FileExists(ChangeFileExt(FName,ExtName))
end;
// Проверка при загрузке БД с индексом
function Indx1Control(IndxName:string):boolean; // true - OK
begin
Result:= true;
Tab.Close;
Tab.IndexName:= IndxName;
try
Tab.Open;
except
Result:= false;
end;
end;
begin
Result:= false;
// проверка простого наличия инд. файлов
if not FileControl('.PX') then exit;
// остальные файлы
eX:= '.XG'; eY:= '.YG';
i:= 0; c:= '0';
f:= Trim(INames);
k:= Pos(',', f);
while k > 0 do begin
s:= Trim(Copy(f,1,k-1));
if s <> '' then begin
if not FileControl(eX + c) then exit;
if not FileControl(eY + c) then exit;
inc(i);
if i = 16 then begin
eX:= '.XH'; eY:= '.YH';
end;
j:= i mod 16;
if j < 10 then c:= chr(48 + j)
else c:= chr(55 + j);
end;
delete(f,1,k);
k:= Pos(',', f);
end;
f:= Trim(f);
if f <> '' then begin
if not FileControl(eX + c) then exit;
if not FileControl(eY + c) then exit;
end;
// Проверка при загрузке БД с индексом
Tab:= TTable.Create(nil);
Tab.TableName:= FName;
f:= Trim(INames);
GoodIndex:= Indx1Control('');
// остальные индексы
k:= Pos(',', f);
while (k > 0) and GoodIndex do begin
s:= Trim(Copy(f,1,k-1));
if s <> '' then
GoodIndex:= Indx1Control(s);
delete(f,1,k);
k:= Pos(',', f);
end;
f:= Trim(f);
if (f <> '') and GoodIndex then
GoodIndex:= Indx1Control(f);
Result:= GoodIndex;
Tab.Close;
Tab.Free;
end; { IndxControlDB }
{ -------- Удаление индексов в DB ---------- }
procedure DelIndexes(FName:string);
var c,d: char; eX, eY: string[3];
begin // до 32 индексов
DeleteFile(ChangeFileExt(FName,'.PX'));
for d:= 'G' to 'H' do begin
eX:= '.X' + d;
eY:= '.Y' + d;
for c:= '0' to 'F' do begin
DeleteFile(ChangeFileExt(FName, eX + c));
DeleteFile(ChangeFileExt(FName, eY + c));
end;
end
end;
{ ------ Создание Rar-архива с ожиданием окончания работы ------ }
function SaveToArchive(RarFileName, Keys, FNames:string; var Msg:string;
BackFrm:TForm):boolean;
// RarFileName - полное имя (если расширения нет, то добавится .rar)
var
s, RarFile: string; k: integer;
APChar: array[0..255] of char;
si: TStartupInfo; // для запуска и ожидания WinRar
pi: TProcessInformation;
begin
Result:= false;
RarFile:= RarFileName;
if AnsiUpperCase(ExtractFileExt(RarFile)) <> '.RAR' then
RarFile:= RarFile + '.rar';
if not MakeFile(RarFile) then begin
Msg:= 'Не удалось создать файл ' + RarFile;
exit
end;
FindExecutable(PChar(RarFile), nil, APChar);
DeleteFile(RarFile);
if APChar[0] = #0 then begin
Msg:= 'Не удалось найти программу WinRAR';
exit
end;
s:= APChar + ' a ' + Keys + ' "' + RarFile + '" ' + FNames; // Keys: -ep без папок-путей
// запуск WinRar и ожидание окончания его работы
ZeroMemory(@si,sizeof(si));
si.cb:= SizeOf(si);
k:=0;
if CreateProcess(nil, { No module name (use command line). }
PChar(s), { Command line. }
nil, { Process handle not inheritable. }
nil, { Thread handle not inheritable. }
False, { Set handle inheritance to FALSE. }
0, { No creation flags. }
nil, { Use parent's environment block. }
nil, { Use parent's starting directory. }
si, { Pointer to STARTUPINFO structure. }
pi) { Pointer to PROCESS_INFORMATION structure. }
then begin
k:=1; // процесс пошел
if BackFrm = nil then
WaitForSingleObject(pi.hProcess, INFINITE) // - так тоже можно, но хуже;
else
while WaitforSingleObject(pi.hProcess,50) = WAIT_TIMEOUT do
BackFrm.Repaint; // для длительного процесса так лучше
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
end;
if FileExists(RarFile) then begin
Msg:= 'Создан архивный файл:'#10 + RarFile;
Result:= true
end
else
if k = 1 then
Msg:= 'Процесс прерван при создании файла'#10 + RarFile
else
Msg:= 'Не удалось создать архивный файл'#10 + RarFile +
#10'(Возможно, есть проблемы с WinRar)'
end; { SaveToArchive }
{ -------- Восстановление файлов из архива ---------- }
procedure FRarUnpack(RarFile, Keys, FNames, DirTarget: string; BackFrm:TForm);
{ RarFile - полное имя rar-файла
Keys - ключи (можно '')
FNames - файлы для извлечения; если несколько, то в кавычках и через пробел
DirTarget - папка-приемник (можно '')
BackFrm - окно-форма, откуда вызвана процедура }
const
titl = ' Восстановление данных из архива';
var
s, FRarName: string;
APChar: array[0..255] of char;
si: TStartupInfo; // для запуска и ожидания WinRar
pi: TProcessInformation;
begin
if DirTarget <> '' then
if not DirectoryExists(DirTarget) then
if not CreateDir(DirTarget) then begin
Application.MessageBox(PChar('Не удаётся создать папку "' + DirTarget + '"'),
titl, MB_ICONSTOP);
exit
end;
ZeroMemory(@APChar, 256);
FindExecutable(PChar(RarFile), nil, APChar);
if APChar[0] = #0 then begin
Application.MessageBox('Не удалось найти программу WinRAR',
titl, MB_ICONSTOP);
exit
end;
s:= APChar + ' x ' + Keys + ' "' + RarFile + '" ' + FNames;
if DirTarget <> '' then s:= s + ' "' + DirTarget + '"';
// запуск WinRar и ожидание окончания его работы
ZeroMemory(@si, sizeof(si));
si.cb:= SizeOf(si);
if CreateProcess(nil, PChar(s), nil, nil, False, 0, nil, nil, si, pi)
then begin
if BackFrm = nil then
WaitForSingleObject(pi.hProcess, INFINITE) // - так тоже можно, но хуже;
else
while WaitforSingleObject(pi.hProcess,50) = WAIT_TIMEOUT do
BackFrm.Repaint; // для длительного процесса так лучше
CloseHandle(pi.hProcess);
CloseHandle(pi.hThread);
Application.ProcessMessages;
Application.MessageBox(PChar('Файл "' + ExtractFileName(RarFile) +
'" обработан'), titl);
end
else
Application.MessageBox(PChar('Не удалось обработать файл "' + FRarName + '"'),
titl, MB_ICONWARNING);
end;
{ --------- Упаковка DBF-таблицы --------- }
function PackDBF(FName:string):boolean;
// uses DBITypes
begin
Result:= false;
try
with TTable.Create(nil) do begin
TableName:= FName;
Exclusive:= true ;
Open ;
Result:= DbiPackTable(DBHandle, Handle, nil, szDBASE, true) = DBIERR_NONE;
Close;
Exclusive:= false;
Free
end;
except
end
end;
{ --------- Упаковка таблицы DBF и DB --------- }
procedure PackTable(Tbl: TTable);
// uses DBITypes
var
hDb: hDBIDb;
Props: CURProps;
CrDesc: CRTblDesc;
Save: Boolean;
begin
Save:= Tbl.Active;
Tbl.Active:= True;
try
Check(DbiGetCursorProps(Tbl.Handle, Props));
if (Props.szTableType = szPARADOX) then begin
{ для PARADOX - не 100%, но даже если и появляются странные сообщения
после процедуры, последствий - никаких }
FillChar(CrDesc, SizeOf(CRTblDesc), 0);
StrCopy(CrDesc.szTblName, Props.szName);
StrCopy(CrDesc.szTblType, Props.szTableType);
CrDesc.bPack:= True;
Check(DbiGetObjFromObj(hDBIObj(Tbl.Handle), objDATABASE, hDBIObj(hDb)));
Tbl.DisableControls;
Tbl.Active:= False;
Check(DbiDoRestructure(hDb, 1, @CrDesc, nil, nil, nil, False));
end
else if (Props.szTableType = szDBASE) then begin
Tbl.Active:= True;
Check(DbiPackTable(Tbl.DBHandle, Tbl.Handle, nil, szDBASE, True));
end;
finally
Tbl.Active:= Save;
Tbl.EnableControls;
end;
end; { PackTable }
{ ------ Field.AsString реально как есть в БД ------ }
function FieldString(Field:TField):string;
{ бывают проблемы с Query при устаревших настройках BDE в dBase,
и здесь они могут быть разрешены.
Но не на 100% - возможно, только тогда, когда не создается временный файл _q,
в который попали уже испорченные значения - т.е. при маленьких размерах.
А Table и без этого обычно нормально работает }
var PCh:array[0..254] of char;
begin
Field.GetData(@PCh);
Result:= PCh;
end;
{ -- Проверка наличия индексного файла в dbf
и удаление признака, если нет и.ф.-- }
function CheckIndF(FName,IFName: string): boolean;
var
FHandle,DT: integer; b:byte;
begin
Result:= true;
if FileExists(IFName) then exit;
try
FHandle:= FileOpen(FName, fmOpenReadWrite);
DT:= FileGetDate(FHandle);
FileSeek(FHandle,28,0);
FileRead(FHandle,b,1);
if b > 0 then begin
b:= 0;
FileSeek(FHandle,28,0);
FileWrite(FHandle,b,1);
FileSetDate(FHandle, DT);
end;
FileClose(FHandle);
except
Application.MessageBox('Проблемы при проверке признака индексирования!',
PChar('Файл: ' + FName),0);
Result:= false
end
end; { CheckIndF }
{ -------- Проверка и установка код.страницы dbf-файла -------- }
procedure TableDBaseIII(FName:string; LangCode:byte);
var
FHandle,DT: integer;
D: tDateTime; Y,M,day: word;
b: array[0..5] of byte;
begin
if not FileExists(FName) then exit;
FHandle:= FileOpen(FName, fmOpenReadWrite);
DT:= FileGetDate(FHandle);
D:= FileDateToDateTime(DT);
DecodeDate(D,Y,M,day); Y:= Y - 1900;
FileRead(FHandle,b[0],4);
FileSeek(FHandle,28,0);
FileRead(FHandle,b[4],2);
if (b[0] <> 3) or (b[1] <> Y) or (b[2] <> M) or (b[3] <> day) or (b[4] <> 0)
or (b[5] <> LangCode) then
begin
b[0]:= 3; b[1]:= Y; b[2]:= M; b[3]:= day; b[4]:= 0;
b[5]:= LangCode;
FileSeek(FHandle,0,0);
FileWrite(FHandle,b[0],4);
FileSeek(FHandle,28,0);
FileWrite(FHandle,b[4],2);
FileSetDate(FHandle, DT);
DeleteFile(ChangeFileExt(FName,'.MDX'));
end;
FileClose(FHandle);
end; { TableDBaseIII }
{ --- Создание инд. файла в DBF, если нет MDX --- }
procedure IndxCreate(FN,IndF,KeyF: string);
var Tab: TTable; IFN: string;
begin
if not FileExists(FN) then exit;
IFN:= ChangeFileExt(FN,'.mdx');
if not FileExists(IFN) and CheckIndF(FN, IFN) then begin
Tab:= TTable.Create(nil);
Tab.TableName:= FN;
Tab.AddIndex(IndF, KeyF, [ixExpression]);
Tab.Free;
end;
end; { IndxCreate }
{ ----- Максимальное из 2 чисел ------ }
function Max2(X,Y:integer):integer;
begin
if X > Y then Result:= X else Result:= Y
end;
{ ----- Максимальное из 3 чисел ------ }
function Max3(X,Y,Z:integer):integer;
begin
Result:= Max2(Max2(X,Y),Z)
end;
{ ----- Минимальное из 2 чисел ------ }
function Min2(n1,n2:integer):integer;
begin
if n1 < n2 then Result:= n1 else Result:= n2
end;
{ ------- Итоговая сумма прописью ------- }
function Itogo(v:currency):string;
Const
sot : array[1..9] of string[9] = ('сто','двести','триста',
'четыреста','пятьсот','шестьсот','семьсот','восемьсот','девятьсот');
des : array[2..9] of string[11] = ('двадцать','тридцать','сорок',
'пятьдесят','шестьдесят','семьдесят','восемьдесят','девяносто');
tsat: array[1..9] of string[5] = ('один','две','три','четыр','пят',
'шест','сем','восем','девят');
edin: array[1..9] of string[6] = ('один','два','три','четыре','пять',
'шесть','семь','восемь','девять');
tedin: array[1..2] of string[4] = ('одна','две');
var
LDig: int64;
mlrd,mln,tys,r : word; s:string; Kop,b:byte;
kk : string[2];
function Right(s:string):string;
begin
if length(s) < 3 then Result:=s
else begin
Result:= Copy(s, length(s)-1, 2)
end;
end;
Procedure Mile(m:word; n:byte);
var
a : string;
begin
case n of
9 : a:='миллиард';
6 : a:='миллион';
3 : a:='тысяч';
0 : a:='руб';
end;
b:= m div 100; { сотни }
if b>0 then s:= s + sot[b] + ' ';
m:= m mod 100;
b:= m div 10; { десятки }
if b<>1 then begin
if b>1 then s:= s + des[b] + ' ';
b:= m mod 10; { единицы }
if b>0 then
if (n=3) and (b in [1,2]) then s:= s + tedin[b] + ' '
else s:= s + edin[b] + ' ';
s:= s + a;
case b of
1 : if n=3 then s:= s + 'а'
else if n=0 then s:= s + 'ль';
2..4 : case n of
0 : s:= s + 'ля';
3 : s:= s + 'и';
6,9 : s:= s + 'а'
end
else if n>3 then s:= s + 'ов'
else if n=0 then s:= s + 'лей'
end;
s:= s + ' '
end
else begin
b:= m mod 10;
if b=0 then s:= s + 'десять'
else s:= s + tsat[b] + 'надцать';
s:= s + ' ' + a;
case n of
0 : s:= s + 'лей ';
3 : s:= s + ' ';
6,9 : s:= s + 'ов '
end
end
end;
begin
if v<0 then v:= -v;
if v > 999999999999.0 then begin
Result:=Format('%.2f руб.',[v]);
exit
end;
LDig:= round(v * 100);
Kop:= LDig mod 100; // копейки
LDig:= LDig div 100; // целые рубли - все
r:= LDig mod 1000; // рубли 1..999
LDig:= LDig div 1000; // т.р.
Tys:= LDig mod 1000; // тысячи
LDig:= LDig div 1000; // млн.р.
Mln:= LDig mod 1000; // миллионы
Mlrd:= LDig div 1000; // миллиарды
s:='';
if v<1 then s:='Ноль рублей '
else begin
if Mlrd>0 then Mile(Mlrd,9);
if Mln>0 then Mile(Mln,6);
if tys>0 then Mile(tys,3);
Mile(r,0)
end;
kk:= Format('%.2d',[Kop]);
s:= s + kk + ' копе';
if kk[1]='1' then s:= s + 'ек'
else case kk[2] of
'1': s:= s + 'йка';
'2'..'4': s:= s + 'йки';
else s:= s + 'ек';
end;
if s[1] in ['а'..'я'] then s[1]:= chr(ord(s[1])-32);
Result:=s
end { -- Itogo -- };
end.
