| Новости | Поиск | FAQ | Статьи | Книги | Новости VCL | | Форумы ЧАТ | Орешник | KOL и MCK |
Форумы -» Основная («Начинающим»)/ Базы / WinAPI / Компоненты / Сети / Media / Игры / Corba и COM / KOL / FreePascal / .Net / Прочее / RSDN.ORG

	« предыдущая ветвь | форум | следующая ветвь »

Вопрос по потокам [XP]

Страницы:   < 1 2 >

petvv ©   (2009-03-17 07:52:00) 

Вот есть код:

constructor TMonDirThread.Create(aPath: String);
begin
 inherited Create(True);
 FreeOnTerminate := True;
 FPath := aPath;
 Self.Priority := tpHighest;
 Resume;
end;

procedure TMonDirThread.UpdateLog;
var
 s: string;
 f: TextFile;
 i: Integer;

begin
   Result:=1;
   KolStr:=0;
   Full:= WideCharToString(Path)+'\'+WideCharToString(FileName);
   CreateDBF();
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
       if Result=2 then
         begin
         // Сдесь получаем № и дату накладной
           GetNom(s,12,20);
           GetDat(s,21,31);
         end;
       Inc(Result,1);
     end;
   CloseFile(f);
//*************************************
// Получаем количество строк в файле
//*************************************
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
       Inc(KolStr,1);
     end;
     KolStr:=KolStr-4;
CloseFile(f);
//*******************
   Result:=1;
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
         if Result>=5 then
           begin
             Form1.Table1.Append;
             Form1.Table1.FieldByName('DATEN').AsDateTime:=StrToDateTime(ResultDat);
             Form1.Table1.FieldByName('NOMN').AsString:=ResultNom;
             //Отсюда начинается сама накладная
             //Получим количество полей
             GetFields(s, Length(s));

           end;
       Inc(Result,1);
     end;
   CloseFile(f);
   DeleteFile(Full);
   Form1.Table1.Active:=False;
end;

procedure TMonDirThread.Execute;
Type  PFileNotifyInformation=^TFileNotifyInformation;
     TFileNotifyInformation=packed record
     NextEntryOffset:dword;
     Action:dword;
     FileNameLength:dword;
     FileName:WideChar;
   end;
var hDir,cbReturn:dword;
   lpBuf:pointer;
   Ptr:PFileNotifyInformation;

begin

//Path:='D:\Накладные';
hDir:=CreateFile(Path,GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE
 or FILE_SHARE_DELETE,nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
if hDir=INVALID_HANDLE_VALUE then begin ShowMessage(SysErrorMessage(GetLastError));exit;end;
GetMem(lpBuf,BUF_SIZE);
//repeat
while not Terminated do
begin
 ZeroMemory(lpBuf,BUF_SIZE);
 if(not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,FILE_NOTIFY_CHANGE_FILE_NAME
 or FILE_NOTIFY_CHANGE_LAST_WRITE,@cbReturn,nil,nil))or(cbReturn=0)then Break;
 // пользователь не сможет прервать ожидание, если захочет. Это нужно либо вынести в отдельный
 // поток, либо использовать синхронный ввод/вывод
 Ptr:=lpBuf;OldName:='';
//  repeat
while not Terminated do
begin
 GetMem(FileName,Ptr^.FileNameLength+2);
 ZeroMemory(FileName,Ptr^.FileNameLength+2);
 lstrcpynW(FileName,addr(Ptr^.FileName),Ptr.FileNameLength div 2+1);
 case Ptr.Action of
   FILE_ACTION_ADDED:Synchronize(UpdateLog);

 end;
 FreeMem(FileName);
 if Ptr^.NextEntryOffset=0 then break;
 Inc(integer(Ptr),Ptr^.NextEntryOffset);
//  until false;
//until false;
end;
end;
FreeMem(lpBuf); // этот код ни разу не вызывается - программа останется в цикле до первой ошибки
CloseHandle(hDir);

end;



После выполнения FILE_ACTION_ADDED:Synchronize(UpdateLog);
не возвращается в цикл. Почему однако ???

---

Slym   (2009-03-18 11:52:00) [1]

petvv   (18.03.09 11:38) [25]
hThread:=CreateThread(nil,0,@WorkThread, LV,0,ThID);
Думаешь проблема только с дельфевыми потоками? сирано графика у тебя съедет в один прекрасный момент...
если хочешь логов то Post/SendMessage пользуй но не напрямую VCL

---

Slym   (2009-03-18 11:48:00) [2]

petvv   (18.03.09 11:38) [25]
Path, Full, ResultNom, ResultDat, Path1,fName, nName, Pole: String;
Fields: Variant;
nFileName:PWideChar;
OldName:widestring;
Result, KolStr, KolFields:Integer;
procedure TxtToDbf1;
Это на самом деле проблема!
У тебя глаз висит? печень наруже или мозг вскрыт? Пациент умрет

---

petvv   (2009-03-18 11:38:00) [3]

Slym'у огромный респект, буду разбираться с твоим кодом. А решил всё так:

unit TxtToDbf;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, DB, DBTables, ComCtrls, StdCtrls;
const
 BUF_SIZE=1024;

type
 TForm1 = class(TForm)
   Table1: TTable;
   LV: TListBox;
   procedure FormCreate(Sender: TObject);
   procedure CreateDBF();
   procedure GetFields(InpString: string; fieldpos: Integer);
   function GetDat(InpString: string; nashpos: Integer; fieldpos: Integer): string;
   function GetNom(InpString: string; nashpos: Integer; fieldpos: Integer): string;

 private
   { Private declarations }
 public
   { Public declarations }
 end;

var
 Form1: TForm1;
 Path, Full, ResultNom, ResultDat, Path1,fName, nName, Pole: String;
 Fields: Variant;
 nFileName:PWideChar;
 OldName:widestring;
 Result, KolStr, KolFields:Integer;
 procedure TxtToDbf1;
implementation

{$R *.dfm}
procedure WorkThread(LV : TListView);stdcall;
Type  PFileNotifyInformation=^TFileNotifyInformation;
     TFileNotifyInformation=packed record
     NextEntryOffset:dword;
     Action:dword;
     FileNameLength:dword;
     FileName:PWideChar;
   end;

var
hDir : THandle;
lpBuf : Pointer;
cbReturn : Cardinal;
FileName : PWideChar;
Ptr:PFileNotifyInformation;
begin
hDir := CreateFile ('d:\Накладные',GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE
  or FILE_SHARE_DELETE,nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
if hDir = INVALID_HANDLE_VALUE
 then begin ShowMessage(SysErrorMessage(GetLastError)); exit; end;
GetMem(lpBuf,BUF_SIZE);
repeat
 // очищаем память перед записью в нее (на всякий случай)
 ZeroMemory(lpBuf,BUF_SIZE);
 if not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,
        FILE_NOTIFY_CHANGE_FILE_NAME or FILE_NOTIFY_CHANGE_LAST_WRITE,
        @cbReturn,nil,nil) then Break;
 Ptr:=lpBuf;
 repeat
   GetMem(FileName,Ptr^.FileNameLength+2);
   ZeroMemory(FileName,Ptr^.FileNameLength+2);
   lstrcpynW(FileName,addr(Ptr^.FileName),Ptr.FileNameLength div 2+1);
   Full:= Path+'\'+FileName;
  FreeMem(FileName);
  case PFileNotifyInformation(Ptr).Action of
   FILE_ACTION_ADDED    :   if ExtractFileExt(Full)<>'.dbf' Then TxtToDbf1();
  end;
  if PFileNotifyInformation(Ptr).NextEntryOffset=0
   then Break
    else begin
     Inc(Cardinal(Ptr),PFileNotifyInformation(Ptr).NextEntryOffset);
    end;
 until false;
until false;
FreeMem(lpBuf);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
ThID, hThread : Cardinal;

begin
Path:='d:\Накладные';
hThread:=CreateThread(nil,0,@WorkThread,LV,0,ThID);
// В случае неудачи выводим сообщение
if hThread=0 then ShowMessage(SysErrorMessage(GetLastError));
end;

.....

end.


---

Slym   (2009-03-18 08:35:00) [4]

       while not Terminated do
       begin
         ZeroMemory(lpBuf,BUF_SIZE);
         if(not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,FILE_NOTIFY_CHANGE_FILE_NAME
             or FILE_NOTIFY_CHANGE_LAST_WRITE,@cbReturn,nil,nil))or(cbReturn=0) then Break;

         Ptr:=lpBuf;

         repeat
           FileName:=WideCharLenToString(@(Ptr^.FileName),Ptr.FileNameLength div 2);
           case Ptr.Action of
             FILE_ACTION_ADDED: DataProcessor.ProcessFile(FPath+FileName);
           end;
           if Ptr^.NextEntryOffset=0 then break;
           Inc(integer(Ptr),Ptr^.NextEntryOffset);
         until false;
       end;
     finally
       FreeMem(lpBuf);
     end;
   finally
     CloseHandle(hDir);
   end;
 except
   if Assigned(ApplicationHandleException) then
     ApplicationHandleException(Self);
 end;
end;

end.

TMonDirThread.Create('c:\');



---

Slym   (2009-03-18 08:35:00) [5]

это ты тупиЩъ...
вот так должно выглядеть и никаких Undiclared identificator не будет

unit uDataProcessor;

interface
uses
Windows, SysUtils, Classes, DB, DBTables;
type
 TDataProcessor=class
 private
   Table:TTable;
 protected
   procedure InitTable(const FileName:string);
   procedure ProcessLine(const Line:string);
 public
   constructor Create;
   destructor Destroy;override;
   procedure ProcessFile(const FileName:string);
 end;

implementation

function GetDat(InpString: string; nashpos: Integer; fieldpos: Integer): string;
var
curpos, i: Integer;
c: Char;
begin
curpos:= nashpos;
result:= '';
for i := nashpos to fieldpos do
begin
  if curpos > fieldpos then  Break;
  repeat
    c := InpString[curpos];
    Inc(curpos, 1);
    if (c='о') or (c='т')then
      c := ' ';
    if c <> ',' then
      result:= result + c;
  until (c = ',') or (curpos > fieldpos)
end;
result := Trim(result);
end;

function GetNom(InpString: string; nashpos: Integer; fieldpos: Integer): string;
var
c: Char;
curpos, i: Integer;
begin
curpos := nashpos;
result := '';
for i := nashpos to fieldpos do
begin
  if curpos > fieldpos then
    Break;
  repeat
    c := InpString[curpos];
    Inc(curpos, 1);
    if (c='о') or (c='т') or (c = #13) or (c = #10) then
      c := ' ';
    if c <> ',' then
      result := result + c;
  until (c = ',') or (curpos > fieldpos)
end;
if (curpos > Length(InpString)) and (i < fieldpos) then
  result := '';
result := Trim(result);
end;

{ TDataProcessor }

constructor TDataProcessor.Create;
begin
 inherited Create;
 Table:=TTable.Create(nil);
end;

destructor TDataProcessor.Destroy;
begin
 Table.Free;
 inherited;
end;

procedure TDataProcessor.InitTable(const FileName: string);
begin
 with Table do
 begin
   Active:=False;
   TableType:=ttDBase;
   DataBaseName:=ExtractFileDir(FileName);
   TableName:=ExtractFileName(FileName);
   with FieldDefs do
   begin
     Clear;
     Add('DATEN',ftDate);
     Add('NOMN',ftString,12,False);
     Add('KOD',ftFloat,0,False);
     Add('NAME',ftString,200,False);
     Add('KOL',ftFloat,0,False);
     Add('PROIZV',ftString,50,False);
     Add('COUNTRY',ftString,15,False);
     Add('GTD',ftString,30,False);
     Add('CENA_OTP',ftFloat,0,False);
     Add('CENA',ftFloat,0,False);
     Add('NDS',ftFloat,0,False);
     Add('SUM_NDS',ftFloat,0,False);
     Add('CENA_SNDS',ftFloat,0,False);
     Add('SUM_BNDS',ftFloat,0,False);
     Add('CENA_REES',ftFloat,0,False);
     Add('CENA_PR',ftFloat,0,False);
     Add('TORG_NADB',ftFloat,0,False);
     Add('SERIA',ftString,20,False);
     Add('GODN',ftDate);
     Add('NOM_SERT',ftString,30,False);
     Add('SROK_DEIST',ftString,10,False);
     Add('ORGAN',ftString,50,False);
     Add('NOM_GLK',ftString,30,False);
     Add('DATA_VID',ftString,10,False);
   end;
   CreateTable;
   Exclusive:=true;    
   Active:=True;
 end;
end;

procedure TDataProcessor.ProcessLine(const Line: string);
const FieldNames:array[1..22] of string=('KOD','NAME','KOL','PROIZV','COUNTRY','GTD',
 'CENA_OTP','CENA','NDS','SUM_NDS','CENA_SNDS','SUM_BNDS','CENA_REES','CENA_PR',
 'TORG_NADB','SERIA','GODN','NOM_SERT','SROK_DEIST','ORGAN','NOM_GLK','DATA_VID') ;
var
 LineData:TStringList;
 i:Integer;
 Field:TField;
 FieldValue:string;
begin
 LineData:=TStringList.Create;
 try
   LineData.Delimiter:=';';
   LineData.DelimitedText:=Line;
   for i:= Low(FieldNames) to High(FieldNames) do
   begin
     Field:=Table.FindField(FieldNames[i]);
     if not assigned(Field) then continue;
     FieldValue:=LineData[i];
     FieldValue:=StringReplace(FieldValue,'%',' ',[rfReplaceAll]);
     if Field.DataType<>ftDate then
       FieldValue:=StringReplace(FieldValue,'.',',',[rfReplaceAll]);
     Field.Value:=FieldValue;
   end;
 finally
   LineData.Free;
 end;
end;

procedure TDataProcessor.ProcessFile(const FileName: string);
var
 FileData:TStringList;
 Dat:TDateTime;
 Nom:string;
 i:integer;
begin
 InitTable(ChangeFileExt(FileName,'.dbf'));
 try
   FileData:=TStringList.Create;
   try
     FileData.LoadFromFile(FileName);
     Dat:=StrToDateTime(GetNom(FileData[1],12,20));
     Nom:=GetDat(FileData[1],21,31);

     for i:=4 to FileData.Count-1 do
     begin
       Table.Append;
       ProcessLine(FileData[i]);
       Table.FieldByName('DATEN').AsDateTime:=Dat;
       Table.FieldByName('NOMN').AsString:=Nom;
       Table.Post;
     end;
   finally
     FileData.Free;
   end;
 finally
   Table.Close;
 end;
end;

end.

unit uMonThread;

interface

uses
Windows, Messages, SysUtils, Classes,uDataProcessor;

type
 TMonDirThread = class(TThread)
 private
   FPath: String;
   DataProcessor:TDataProcessor;
 protected
   procedure Execute; override;
 public
   constructor Create(const Path: String);
   destructor Destroy;override;
 end;

implementation

type
 PFileNotifyInformation=^TFileNotifyInformation;
 TFileNotifyInformation=packed record
    NextEntryOffset:dword;
    Action:dword;
    FileNameLength:dword;
    FileName:WideChar;
 end;

const
BUF_SIZE=4096;

constructor TMonDirThread.Create(const Path: String);
begin
inherited Create(True);
DataProcessor:=TDataProcessor.Create;
FreeOnTerminate:=True;
FPath:=IncludeTrailingPathDelimiter(Path);
Priority:=tpHighest;
Resume;
end;

destructor TMonDirThread.Destroy;
begin
 DataProcessor.Free;
 inherited;
end;

procedure TMonDirThread.Execute;
var
 hDir,cbReturn:dword;
 lpBuf:pointer;
 Ptr:PFileNotifyInformation;
 FileName:string;
begin
 try
   hDir:=CreateFile(PChar(FPath),GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE or FILE_SHARE_DELETE,
                     nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
   if hDir=INVALID_HANDLE_VALUE then RaiseLastOSError;
   try
     GetMem(lpBuf,BUF_SIZE);
     try

---

petvv   (2009-03-18 07:53:00) [6]

ё мля люди походу енто у меня дельфя чегойто глючит.
Пишу:


Type  PFileNotifyInformation=^TFileNotifyInformation;
     TFileNotifyInformation=packed record
     NextEntryOffset:dword;
     Action:dword;
     FileNameLength:dword;
     FileName:WideChar;
   end;
var hDir,cbReturn:dword;
   lpBuf:pointer;
   Ptr:PFileNotifyInformation;

begin

//Path:='D:\Накладные';
hDir:=CreateFile(Path,GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE
 or FILE_SHARE_DELETE,nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
if hDir=INVALID_HANDLE_VALUE then begin ShowMessage(SysErrorMessage(GetLastError));exit;end;
GetMem(lpBuf,BUF_SIZE);
repeat
//while not Terminated do
//begin
 ZeroMemory(lpBuf,BUF_SIZE);
 if(not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,FILE_NOTIFY_CHANGE_FILE_NAME
 or FILE_NOTIFY_CHANGE_LAST_WRITE,@cbReturn,nil,nil))or(cbReturn=0)then Terminate;
 // пользователь не сможет прервать ожидание, если захочет. Это нужно либо вынести в отдельный
 // поток, либо использовать синхронный ввод/вывод
 Ptr:=lpBuf;OldName:='';
 repeat
//while not Terminated do
//begin
 GetMem( FileName,Ptr^.FileNameLength+2);
 ZeroMemory( FileName,Ptr^.FileNameLength+2);
 lstrcpynW( FileName,addr(Ptr^.FileName),Ptr.FileNameLength div 2+1);
 case Ptr.Action of
   FILE_ACTION_ADDED:Form1.TxtToDbf(Form1);
на выделенное жирным говорит Undiclared identificator ...

Опупеть. И ещё заметил, что при добавлении на форму любого компонента в секции Uses не появляются нужные ссылки. А появляются они только после того как начнёш чегой то в ентой секции менять. Во пипец.


---

Slym   (2009-03-18 06:34:00) [7]

Какой формат файла? Намудрено сильно...

---

Slym   (2009-03-18 05:57:00) [8]

я не вижу привязки Table1 к гриду или другой визуализации...
1. Тогда зачем его держать на форме?
2. Нет обращения к форме, нет нужды в синхронизе...
3. Код на троечку с - (куча глобальных переменных)... на рефакторинг...

---

Сергей М.   (2009-03-17 13:35:00) [9]

А что, напрямую никак нелься вызвать TxtToDbf() ? Обязательно в обработчике ее вызывать ?

TxtToDbf;
Form1.Memo1.SetSelText('Изменено')

Чем этот вариант плох ?

---

petvv   (2009-03-17 13:29:00) [10]

Form1.Memo1.SetSelText('Изменено'); <-- вот здесть ты встал по брейкпойнту, сделал шаг по F7

Memo1 в OnChange стоит TxtToDbf();

---

Сергей М.   (2009-03-17 13:22:00) [11]

> Нажимаеш F7 попадаем в TxtToDbf


Что ты несешь, какой еще TxtToDbf ?
Процедура Updatelog у тебя состоит из одной-единственной исполняемой строчки :

procedure TMonDirThread.UpdateLog;
begin
//Synchronize(TxtToDbf); // <-- эта закомментарена
Form1.Memo1.SetSelText('Изменено');<-- вот здесть ты встал по брейкпойнту, сделал шаг по F7
end;<-- сюда попал ? толкнул F9 дальше ?

---

petvv   (2009-03-17 13:01:00) [12]

Да. Нажимаеш F7 попадаем в TxtToDbf она выполняется, попадаем в

procedure TMonDirThread.UpdateLog;
begin
//Synchronize(TxtToDbf);
Form1.Memo1.SetSelText('Изменено');
end; // вот сюда
Дальше хоть обнажимайся F7, F8, F9 никуда не возвращается

---

Сергей М.   (2009-03-17 12:47:00) [13]

> выполнение останавливается


Шаг (F7) после останова выполняется успешно?

---

petvv   (2009-03-17 12:01:00) [14]

Ставил. Когда кидаеш 1-й файл в директорию отрабатыват нормально (создаёт dbf) и после Form1.Memo1.SetSelText('Изменено');
выполнение останавливается (не возвращается в основной цикл опроса). Т.е. кидаеш следующий файл в директорию, а реакции 0.

---

Сергей М.   (2009-03-17 11:57:00) [15]

> выполнение останавливается (не возвращается в основной цикл
> опроса)


Как ты это узнал ?
Ставил брейкпойнт на вызове SetSelText и делал шаг (F7) ?

---

petvv   (2009-03-17 11:45:00) [16]

Если не понятно то ещё раз:


while not Terminated do
begin
 GetMem(FileName,Ptr^.FileNameLength+2);
 ZeroMemory(FileName,Ptr^.FileNameLength+2);
 lstrcpynW(FileName,addr(Ptr^.FileName),Ptr.FileNameLength div 2+1);
 case Ptr.Action of
  FILE_ACTION_ADDED:Synchronize(UpdateLog); //Уходит на синхронизацию

 end;
 FreeMem(FileName);
 if Ptr^.NextEntryOffset=0 then break;
 Inc(integer(Ptr),Ptr^.NextEntryOffset);
//  until false;
//until false;
end;


procedure TMonDirThread.UpdateLog;
begin
 //Synchronize(TxtToDbf);
 Form1.Memo1.SetSelText('Изменено');
end;

В Мемо1 OnChange = Form1.TxtToDbf - выполняется обработка файла

и после Form1.Memo1.SetSelText('Изменено');
выполнение останавливается (не возвращается в основной цикл опроса)

---

petvv   (2009-03-17 11:39:00) [17]

непосредственно по проблеме был выше, и вопрос конкретный

---

Юрий Зотов   (2009-03-17 11:36:00) [18]

> petvv   (17.03.09 11:17) [9]

Как Вы считаете, если бы Вы выделили и привели только тоткод, который относится к проблеме непосредственно, то Ваши шансы получить конкретный толковый ответ увеличились бы, или уменьшились?

---

petvv   (2009-03-17 11:17:00) [19]

Вот код потока:

unit uMonThread;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ExtCtrls, StdCtrls, DB, DBTables, Menus;

const
 BUF_SIZE=256;

type

 TMonDirThread = class(TThread)
 private
   FPath: String;
 protected
   procedure Execute; override;
   procedure UpdateLog;

 public
   constructor Create(aPath: String);

 end;

implementation
uses
 Unit1;

constructor TMonDirThread.Create(aPath: String);
begin
 inherited Create(True);
 FreeOnTerminate := True;
 FPath := aPath;
 Self.Priority := tpHighest;
 Resume;
end;
procedure TMonDirThread.UpdateLog;
begin
 //Synchronize(TxtToDbf);
 Form1.Memo1.SetSelText('Изменено');
end;

procedure TMonDirThread.Execute;
Type  PFileNotifyInformation=^TFileNotifyInformation;
     TFileNotifyInformation=packed record
     NextEntryOffset:dword;
     Action:dword;
     FileNameLength:dword;
     FileName:WideChar;
   end;
var hDir,cbReturn:dword;
   lpBuf:pointer;
   Ptr:PFileNotifyInformation;

begin

//Path:='D:\Накладные';
hDir:=CreateFile(Path,GENERIC_READ,FILE_SHARE_READ or FILE_SHARE_WRITE
 or FILE_SHARE_DELETE,nil,OPEN_EXISTING,FILE_FLAG_BACKUP_SEMANTICS,0);
if hDir=INVALID_HANDLE_VALUE then begin ShowMessage(SysErrorMessage(GetLastError));exit;end;
GetMem(lpBuf,BUF_SIZE);
//repeat
while not Terminated do
begin
 ZeroMemory(lpBuf,BUF_SIZE);
 if(not ReadDirectoryChangesW(hDir,lpBuf,BUF_SIZE,true,FILE_NOTIFY_CHANGE_FILE_NAME
 or FILE_NOTIFY_CHANGE_LAST_WRITE,@cbReturn,nil,nil))or(cbReturn=0)then Break;
 // пользователь не сможет прервать ожидание, если захочет. Это нужно либо вынести в отдельный
 // поток, либо использовать синхронный ввод/вывод
 Ptr:=lpBuf;OldName:='';
//  repeat
while not Terminated do
begin
 GetMem(FileName,Ptr^.FileNameLength+2);
 ZeroMemory(FileName,Ptr^.FileNameLength+2);
 lstrcpynW(FileName,addr(Ptr^.FileName),Ptr.FileNameLength div 2+1);
 case Ptr.Action of
   FILE_ACTION_ADDED:Synchronize(UpdateLog);

 end;
 FreeMem(FileName);
 if Ptr^.NextEntryOffset=0 then break;
 Inc(integer(Ptr),Ptr^.NextEntryOffset);
//  until false;
//until false;
end;
end;
FreeMem(lpBuf); // этот код ни разу не вызывается - программа останется в цикле до первой ошибки
CloseHandle(hDir);

end;

end.


---

petvv   (2009-03-17 10:25:00) [20]

Вот код основной формы:


unit Unit1;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
 Dialogs, ExtCtrls, StdCtrls, DB, DBTables, Menus, uMonThread;
const
 BUF_SIZE=256;
type
 TForm1 = class(TForm)
   TrayIcon1: TTrayIcon;
   Table1: TTable;

   procedure FormCreate(Sender: TObject);

 private
   { Private declarations }
 public
   { Public declarations }

 end;

var
 Form1: TForm1;
 Table1: TTable;
 Path:PWideChar;
 Full, ResultNom, ResultDat, Path1,fName, nName, Pole: String;
 Fields: Variant;
 FileName:PWideChar;
 OldName:widestring;
 Result, KolStr, KolFields:Integer;
 procedure TxtToDbf;
 procedure GetFields(InpString: string; fieldpos: Integer);
 procedure CreateDBF();
 function GetDat(InpString: string; nashpos: Integer; fieldpos: Integer): string;
 function GetNom(InpString: string; nashpos: Integer; fieldpos: Integer): string;
implementation

uses ShellApi, shlobj, registry;

//**************************************
procedure CreateDBF();
begin
//**************************************
path1:=ExtractFileDir(Full);
fName:=ExtractFileName(Full);
nName:=ChangeFileExt(fName, '.dbf');
//*****
Form1.Table1.Active:=False;
Form1.Table1.TableType:=ttDBase;
Form1.Table1.DataBaseName:=Path1;
Form1.Table1.TableName:=nName;
Form1.Table1.FieldDefs.Clear;
Form1.Table1.FieldDefs.Add('DATEN',ftDate);
Form1.Table1.FieldDefs.Add('NOMN',ftString,12,False);
Form1.Table1.FieldDefs.Add('KOD',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('NAME',ftString,200,False);
Form1.Table1.FieldDefs.Add('KOL',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('PROIZV',ftString,50,False);
Form1.Table1.FieldDefs.Add('COUNTRY',ftString,15,False);
Form1.Table1.FieldDefs.Add('GTD',ftString,30,False);
Form1.Table1.FieldDefs.Add('CENA_OTP',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('CENA',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('NDS',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('SUM_NDS',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('CENA_SNDS',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('SUM_BNDS',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('CENA_REES',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('CENA_PR',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('TORG_NADB',ftFloat,0,False);
Form1.Table1.FieldDefs.Add('SERIA',ftString,20,False);
Form1.Table1.FieldDefs.Add('GODN',ftDate);
Form1.Table1.FieldDefs.Add('NOM_SERT',ftString,30,False);
Form1.Table1.FieldDefs.Add('SROK_DEIST',ftString,10,False);
Form1.Table1.FieldDefs.Add('ORGAN',ftString,50,False);
Form1.Table1.FieldDefs.Add('NOM_GLK',ftString,30,False);
Form1.Table1.FieldDefs.Add('DATA_VID',ftString,10,False);
Form1.Table1.CreateTable;
Form1.Table1.Active:=True;
Form1.Table1.Edit;
Form1.Table1.First;

end;
//********************************
procedure GetFields(InpString: string; fieldpos: Integer);
var
 c: Char;
 curpos, i: Integer;
begin
//**************************************
 curpos := 1;
 KolFields:=0;
 Fields:='';
 for i := 1 to fieldpos do
 begin

  case KolFields of
    1:   Pole:='KOD';
    2:   Pole:='NAME';
    3:   Pole:='KOL';
    4:   Pole:='PROIZV';
    5:   Pole:='COUNTRY';
    6:   Pole:='GTD';
    7:   Pole:='CENA_OTP';
    8:   Pole:='CENA';
    9:   Pole:='NDS';
    10:  Pole:='SUM_NDS';
    11:  Pole:='CENA_SNDS';
    12:  Pole:='SUM_BNDS';
    13:  Pole:='CENA_REES';
    14:  Pole:='CENA_PR';
    15:  Pole:='TORG_NADB';
    16:  Pole:='SERIA';
    17:  Pole:='GODN';
    18:  Pole:='NOM_SERT';
    19:  Pole:='SROK_DEIST';
    20:  Pole:='ORGAN';
    21:  Pole:='NOM_GLK';
    22:  Pole:='DATA_VID';
  end;

  case KolFields of
   1,3,7,8,9,10,11,12,13,14,15:  Form1.Table1.FieldByName(Pole).AsFloat:=StrToFloat(Fields);
   2,4,5,6,16,18,19,20,21,22:  Form1.Table1.FieldByName(Pole).AsString:=Fields;
  end;
  Fields:='';
  KolFields := KolFields+1;
   if curpos > Length(InpString) then
     Break;
   repeat
     c := InpString[curpos];
     Inc(curpos, 1);
     if (c = #13) or (c = #10) then
       c := ' ';
     if (KolFields<>19) and (c='.') then
       c:=',';
     if c='%' then
       c:=' ';
     if c <> ';' then
       Fields := Fields + c;
   until (c = ';') or (curpos > Length(InpString))
 end;
 if (curpos > Length(InpString)) and (i < fieldpos) then
end;

//********************************
function GetDat(InpString: string; nashpos: Integer; fieldpos: Integer): string;
var
 c: Char;
 curpos, i: Integer;
begin

 curpos := nashpos;
 resultDat := '';
 for i := nashpos to fieldpos do
 begin
   if curpos > fieldpos then
     Break;
   repeat
     c := InpString[curpos];
     Inc(curpos, 1);
     if (c='о') or (c='т') or (c = #13) or (c = #10) then
       c := ' ';
     if c <> ',' then
       resultDat := resultDat + c;
   until (c = ',') or (curpos > fieldpos)
 end;
 resultDat := Trim(resultDat);
 end;
//********************************
function GetNom(InpString: string; nashpos: Integer; fieldpos: Integer): string;
var
 c: Char;
 curpos, i: Integer;
begin

 curpos := nashpos;
 resultNom := '';
 for i := nashpos to fieldpos do
 begin
   if curpos > fieldpos then
     Break;
   repeat
     c := InpString[curpos];
     Inc(curpos, 1);
     if (c='о') or (c='т') or (c = #13) or (c = #10) then
       c := ' ';
     if c <> ',' then
       resultNom := resultNom + c;
   until (c = ',') or (curpos > fieldpos)
 end;
 if (curpos > Length(InpString)) and (i < fieldpos) then
   result := '';
 resultNom := Trim(resultNom);
end;
//************************************

{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
 Path:='D:\Накладные';
 Form1.Tag := Integer(TMonDirThread.Create(Path));

end;
procedure TxtToDbf;
var
 s: string;
 f: TextFile;
//  i: Integer;

begin
   Result:=1;
   KolStr:=0;
   Full:= WideCharToString(Path)+'\'+WideCharToString(FileName);
   CreateDBF();
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
       if Result=2 then
         begin
         // Сдесь получаем № и дату накладной
           GetNom(s,12,20);
           GetDat(s,21,31);
         end;
       Inc(Result,1);
     end;
   CloseFile(f);
//*************************************
// Получаем количество строк в файле
//*************************************
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
       Inc(KolStr,1);
     end;
     KolStr:=KolStr-4;
CloseFile(f);
//*******************
   Result:=1;
   AssignFile(f, Full);
   Reset(f);
   while not EOF(f) do
     begin
       ReadLn(f, s);
         if Result>=5 then
           begin
             Form1.Table1.Append;
             Form1.Table1.FieldByName('DATEN').AsDateTime:=StrToDateTime(ResultDat);
             Form1.Table1.FieldByName('NOMN').AsString:=ResultNom;
             //Отсюда начинается сама накладная
             //Получим количество полей
             GetFields(s, Length(s));

           end;
       Inc(Result,1);
     end;
   CloseFile(f);
   DeleteFile(Full);
   Form1.Table1.Active:=False;
end;
end.


---

Страницы:   < 1 2 >

Наверх