.doc ve .txt dosyalarından kelime oluşturma.

[Asri]

Aynı dizindeki .doc ve .txt dosyalarından kelimleri toplayarak kelimedosyasi.txt dosyasına kaydeder.

Kelimeler listeye eklendiklerinde aynı kelimeden var ise listeye eklenmez ve var olan kelimenin başına o kelimeden kaç defa okunduğu yazılır. .doc ve .txt dosyalarından sadece ingilizce alfabesinden olan kelimeler okunarak yazılır. Diğer bütün işaret ve karakterler elenir ve var olanlar küçük harfe çevirilir.


Bu kodun yazılış amacı için bkz.
viewtopic.php?p=33842#33842

Kod: Tümünü seç

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,ComObj, StdCtrls, FileCtrl, ComCtrls;

type
  TForm1 = class(TForm)
    Label5: TLabel;
    Memo1: TMemo;
    Button1: TButton;
    Memo2: TMemo;
    Label1: TLabel;
    Label2: TLabel;
    Label3: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
     function kelimele(sozcuk : String) : String;
     Procedure FindFiles(const Path, Mask: string; IncludeSubDir: boolean; Out List:TStringList);
     function prgdizini: string;
  end;

var
  Form1: TForm1;
  msword,Winword, Doc: Variant;
  hecesay,say,son1,i,z,z1,y,i1,i2,i3,i4:longint;
  fuz,f,dosyaadi,s1,s11,gec,gec1,gec2:string;
  liste:TStringList;

implementation

{$R *.dfm}

function tform1.prgdizini: string;
begin
  Result := ExtractFilePath(Application.ExeName);
  if Result[Length(Result)] <> '\' then
   Result := Result + '\';
end;

Procedure tform1.FindFiles(const Path, Mask: string; IncludeSubDir: boolean; Out List:TStringList);
var
  FindResult: integer;
  SearchRec : TSearchRec;
begin
  FindResult := FindFirst(Path + Mask, faAnyFile - faDirectory, SearchRec);
  while FindResult = 0 do
  begin
    { do whatever you'd like to do with the files found }
    List.Add(Path + SearchRec.Name);
    FindResult := FindNext(SearchRec);
  end;
  { free memory }
  FindClose(SearchRec);
  if not IncludeSubDir then
    Exit;
  FindResult := FindFirst(Path + '*.*', faDirectory, SearchRec);
  while FindResult = 0 do
  begin
    if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then
        FindFiles (Path + SearchRec.Name + '\', Mask, TRUE,List);
    FindResult := FindNext(SearchRec);
  end;
  { free memory }
  FindClose(SearchRec);
end;

function tform1.kelimele(sozcuk : String) : String;
var
basla:boolean;
j:integer;
tmp,ek:string;

begin
  basla:=true;tmp:='';
  for j:=1 to length(sozcuk) do
  begin
    if (sozcuk[j] in ['!',',',' ','''','+','%','&','/','\','(',')','=','?','_','-',
   '#','$','{','[',']','}','*',';','"','é','~','`','.',':','<','>','|',
   '1','2','3','4','5','6','7','8','9','0']) then
    begin
       sozcuk[j]:=' ';
       basla:=false;
       ek:=' ';
       continue;
    end;
     tmp:=tmp+ek+sozcuk[j];
     ek:='';
  end;
  tmp:=tmp+' ';
  if length(tmp)>2 then result:=tmp else result:='';
end;

procedure docbelgesi;
begin
with form1 do begin
   Winword := CreateOleObject('word.Application');
   Doc := Winword.Documents.Open(f);
   Memo1.Lines.Text := Doc.Content;
   label2.Caption:='Top.Satır : '+inttostr(memo1.Lines.count);
   label2.refresh;

   //showmessage('ddd');
   memo1.Refresh;
   Winword.Quit;
end;
end;

procedure txtbelgesi;
begin
with form1 do begin
   memo1.Lines.LoadFromFile(f);
   label2.Caption:='Top.Satır : '+inttostr(memo1.Lines.count);
   label2.refresh;

end;
end;

procedure kelimeyaz;
var
 kel:string;
 say:longint;
begin
with form1 do begin
  z:=memo1.Lines.Count;
  for i:=0 to z-1 do begin
    application.ProcessMessages;
    label3.Caption:='Satır : '+inttostr(i);
    gec:=memo1.Lines.Strings[i];
    gec:=ansilowercase(gec);
    gec:=kelimele(gec);
    if gec='' then continue;


    s1:=gec;son1:=0;

    for y:=1 to length(gec) do
    begin
        application.ProcessMessages;
        son1:=pos(' ',s1);s11:=copy(s1,1,son1-1);s1:=copy(s1,son1+1,length(s1));
        gec:='';
        if length(s11)<>0 then
        begin
            for say:=1 to length(s11) do if  ord(s11[say])>64 then begin
                gec:=gec+s11[say];
            end;
            z1:=memo2.Lines.Count-1;

            for i2:=0 to z1 do
            begin
                gec2:=memo2.Lines.Strings[i2];
                say:=0;
                say:=strtoint(copy(gec2,1,pos(':',gec2)-1));
                gec2:=copy(gec2,pos(':',gec2)+1,length(gec2));

                if gec=gec2 then begin break;end;
            end;

            if gec<>gec2 then
            begin
               if length(gec)<=2 then continue;
               inc(hecesay);
               label1.Caption:='Kelime : '+inttostr(hecesay);
               label1.Refresh;

               memo2.Lines.Add('1:'+gec);
               memo2.Refresh;
            end else
            begin
               if length(gec)<=2 then continue;
               //inc(hecesay);
               inc(say);
               memo2.Lines.Strings[i2]:=inttostr(say)+':'+gec;
               memo2.Refresh;
            end;

        end;
    end;
  end;

end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  liste:=TStringList.Create;
  FindFiles(prgdizini,'*.doc',False,liste);
  FindFiles(prgdizini,'*.txt',False,liste);

  for i1:=0 to liste.Count-1 do begin
     f:=liste.Strings[i1];
     label5.Caption:='Dosya adı :'+f;
     fuz:=copy(f,pos('.',f)+1,length(f)-pos('.',f));
     fuz:=ansilowercase(fuz);
     memo1.Clear;

     if fuz='doc' then begin docbelgesi;kelimeyaz;end;
     if fuz='txt' then begin txtbelgesi;kelimeyaz;end;
  end;
  memo2.Lines.SaveToFile(prgdizini+'kelimedosya.txt');
  showmessage('Aktarım işlemi tamamladı');
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 if fileexists('kelimedosya.txt') then
 begin
   memo2.Lines.LoadFromFile('kelimedosya.txt');
   hecesay:=memo2.Lines.Count;
   label1.Caption:='Kelime : '+inttostr(hecesay);
 end;
end;

end.

// DFM dosyasının içeriği aşağıdadır.

Kod: Tümünü seç

object Form1: TForm1
  Left = 192
  Top = 114
  Width = 684
  Height = 236
  Caption = 'Form1'
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'MS Sans Serif'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  PixelsPerInch = 96
  TextHeight = 13
  object Label5: TLabel
    Left = 8
    Top = 8
    Width = 71
    Height = 14
    Caption = 'Dosya ad'#305' :'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Verdana'
    Font.Style = []
    ParentFont = False
  end
  object Label1: TLabel
    Left = 296
    Top = 152
    Width = 50
    Height = 14
    Caption = 'Kelime: '
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Verdana'
    Font.Style = []
    ParentFont = False
  end
  object Label2: TLabel
    Left = 8
    Top = 152
    Width = 64
    Height = 14
    Caption = 'Top sat'#305'r :'
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Verdana'
    Font.Style = []
    ParentFont = False
  end
  object Label3: TLabel
    Left = 144
    Top = 152
    Width = 42
    Height = 14
    Caption = 'Sat'#305'r : '
    Font.Charset = DEFAULT_CHARSET
    Font.Color = clWindowText
    Font.Height = -12
    Font.Name = 'Verdana'
    Font.Style = []
    ParentFont = False
  end
  object Memo1: TMemo
    Left = 8
    Top = 32
    Width = 553
    Height = 113
    ScrollBars = ssVertical
    TabOrder = 0
  end
  object Button1: TButton
    Left = 272
    Top = 176
    Width = 99
    Height = 25
    Caption = '&Kelime Ay'#305'kla'
    TabOrder = 1
    OnClick = Button1Click
  end
  object Memo2: TMemo
    Left = 568
    Top = 32
    Width = 97
    Height = 113
    ScrollBars = ssBoth
    TabOrder = 2
  end
end