Custom programming, Screenter, Opener, Searcher Applications: February 2017

Tuesday, February 21, 2017

- Bittorrent uses TCP to transfer files and UDP for searching. It will use port 80 if the default TCP ports 6881-6889,6969 and 8080 can not be reached. Some bittorrent clients also support HTTP downloading.To completely block BT, please block UDP port 1024-65534 in your router.

Imate zaposlene koji zloupotrebljavaju internet konekciju skidajući torrente, ovo je način da ih blokirate, ali imajte u vidu da interval portova koji koristi torrent može da se preklopi sa Cisco VPN Client aplikacijom, pa obratite pažnju kada blokirate na glavnom firewall-u vašeg cable router-a na primer.

Pitate se u čemu je štos, mislite da to nije neka zloupotreba, da nije neki veliki problem, kako se samo varate.

1) Ako pustite da zaposleni skidaju torrente bez kontrole, Vaša firma se može naći u velikom problemu ukoliko provajder internet usluga prosledi prijavu za kršenje autorskih prava na filmove, muziku ili piratske aplikacije koje Vaši zaposleni nemilice skidaju bez Vašeg odobrenja i znanja.

2) S druge strane Vaši zaposleni kada ne skidaju zabranjene sadržaje samom činjenicom da imaju instaliran torrent na kompjuteru konstantno seed-uju zabranjene sadržaje za druge korisnike torrent-a koji dele torrent resurse sa njima, pa i tako "ni luk jeli, ni luk mirisali", a opet i Vi i oni mogu biti u velikom problemu.

Monday, February 20, 2017

centos copy

momount /dev/cdrom ---> usually you use /mnt/cdrom (create it (use mkdir)if does not exist)

then cp /mnt/cdrom/

cp -r /home/server/folder/test/* /home/server/

$ cp -avr /tmp/conf/ /tmp/backup

$ cp -avr /mnt/cd/ /var/www/html

-a : Preserve the specified attributes such as directory an file mode, ownership, timestamps, if possible additional attributes: context, links, xattr, all.
-v : Explain what is being done.
-r : Copy directories recursively.

=============================================

mkdir -p /mnt/cdrom
mount /dev/cdrom /mnt/cdrom

=========================================

phpinfo.php in /var/www/html/

=========================================

rm -rf httpd-2.0.48

rm -rf "dir name"

=========================================

+++++++++++++++++++++++++++++

USB...

mount /dev/sdb1 /mnt

umount /mnt

sync

And then remove the USB drive.

++++++++++++++++++++

mkdir -p /media/USB

ls /dev/sd (then hit tab)

You should see something like this:

sda sda1 sda2

Next, insert your USB flash drive into the CentOS 7 machine. Type ls /dev/sd (then hit tab). You should see a new sdb and sdb1.

mount -t vfat /dev/sdb1 /media/USB

cp nfs-utils-1.3.0-0.21.el7_2.x86_64.rpm /media/USB/

umount /media/USB

You can now safely eject the USB flash drive from the CentOS 7 machine.

++++++++++++++++++++++++++

NTFS:

yum install epel-release

yum install ntfs-3g

mkdir /mnt/win

mount -t ntfs-3g /dev/sdb1 /mnt/win

umount /mnt/win

**************************

To mount the NTFS partition permanently, add the following line to the /etc/fstab file.
nano /etc/fstab

And add the line:
/dev/sdb1 /mnt/win ntfs-3g defaults 0 0

Again, replace /dev/sdb1 with the device name that matches your setup. Now your Linux system will mount the NTFS drive automatically at boot time.
***************************

CD...

Mount DVD on CentOS
Mount DVD on CentOS

need to mount CD/DVD on CentOS Temporarily or Permanently? Here’s the Process Us Linux Pro’s Follow:

Login to a terminal window as root

from here to ls /dev

as you can see, there’s alot of stuff here (usually it’s /dvd or /sr0) but how can we be sure?

issue the following two commands to find out what Linux Thinks is the CD/DVD ROM:

ls /dev -l | grep dvd

ls /dev -l | grep cd

Linux seems pretty confident that it’s /dev/sr0 (does windows know how to do that?) Your situation may provide different output, use that.

alright, so at this point, we are talking about the following device: /dev/sr0 (always use the full path)

let’s make a directory to mount it to:

mkdir /mnt/DVD

from here, all we have to do is mount the device

to do a temporary mount (one time only until reboot) issue the following Command:

to do a permanent boot, edit /etc/fstab

Like a good Linux Admin, use the # sign, and put a comment in

from here /dev/sr0 will be mounted to /mnt/DVD the filesystem type and filesystem defaults

Save and quit

issue the almighty Linux Command that Re-Mounts ALL FILESYSTEMS

you should get a notice that it will mount as read-only, that means it mounted, and we can read from it, perfect!

ls /mnt/DVD

as you can see this is an integration services DVD mounted on this CentOS Linux Box.

That’s it!

To Get a Hosted CentOS Linux Server visit www.zwiegnet.comcd/go to get started today!

Tsearch

procedure TForm1.Button1Click(Sender: TObject);
var
Rec: TSearchRec;
FileList: array of string;
DateList: array of TDateTime;
i: Integer;
Done: Boolean;
TempName: string;
TempDate: TDateTime;
begin
// Get files list
if FindFirst('c:\*.*', faAnyFile, Rec) = 0 then
repeat
Setlength(FileList, Length(FileList) + 1);
Setlength(DateList, Length(DateList) + 1);
FileList[High(FileList)]:= Rec.Name;
DateList[High(DateList)]:= FileDateToDateTime(Rec.Time);
until FindNext(Rec) <> 0;
FindClose(Rec);

// Sort
// Bubble sort
repeat
Done:= True;
for i:= 0 to High(FileList) - 1 do
if DateList[i] > DateList[i + 1] then
begin
Done:= False;
TempName:= FileList[i];
FileList[i]:= FileList[i + 1];
FileList[i + 1]:= TempName;

TempDate:= DateList[i];
DateList[i]:= DateList[i + 1];
DateList[i + 1]:= TempDate;

end;

until Done;

// Show in list
ListBox1.Clear;
for i:= 0 to High(FileList) do
ListBox1.Items.Add(FileList[i] + ' ' + DateTimeToStr(DateList[i]));
end;

If you want descending sort then invert the comparison operator to <

if DateList[i] < DateList[i + 1] then

//-------

const
DirectoryPath = 'C:\data\';

procedure TForm1.Button1Click(Sender: TObject);
var
tsr: TSearchRec;
list: TStringList;
x: integer;
begin
list := TStringList.Create;
list.Sorted := true;
try
// Build list of files in time creation order
if FindFirst( DirectoryPath + '*.*', 0, tsr ) = 0 then begin
repeat
list.Append( Format( '%.8x %s', [ tsr.Time, tsr.Name ] ) );
until FindNext( tsr ) <> 0;
FindClose( tsr );
end;
// Process these files one at a time
for x := 0 to list.count - 1 do
Process( DirectoryPath + Copy( list[x], 9, Length(list[x]) ) );
finally
list.free;
end;
end;

procedure TForm1.Process(filename: string);
begin
memo1.Lines.Append( filename );
end;

//----------

http://www.tek-tips.com/viewthread.cfm?qid=1479527

https://www.experts-exchange.com/questions/20533938/Date-sorted-FileList.html

Rotate img

procedure Rotate90(Source: TGraphic; Target: TJpegImage);
var
SourceBmp, TargetBmp: TBitmap;
r, c: Integer;
x, y: Integer;
begin
SourceBmp := TBitmap.Create;
SourceBmp.Assign(Source);
TargetBmp := TBitmap.Create;
TargetBmp.Width := SourceBmp.Height;
TargetBmp.Height := SourceBmp.Width;
for r := 0 to SourceBmp.Height - 1 do
begin
for c := 0 to SourceBmp.Width - 1 do
begin
//x := (SourceBmp.Height-1) - r; // -90
//y := c; //-90
x := r; //90
y := (SourceBmp.Width-1) - c; //90
// look into Bitmap.ScanLine for faster pixel access
TargetBmp.Canvas.Pixels[x, y] := SourceBmp.Canvas.Pixels[c, r];
end;
end;
Target.Assign(TargetBmp);
SourceBmp.Free;
TargetBmp.Free;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Jpeg: TJPEGImage;
begin
Jpeg := TJPEGImage.Create;
Rotate90(Image1.Picture.Graphic, Jpeg);
Image1.Picture.Assign(Jpeg);
Jpeg.Free;
end;

//http://www.efg2.com/Lab/ImageProcessing/FlipReverseRotate.htm
//http://stackoverflow.com/questions/11864236/what-is-the-fastest-way-to-rotate-a-jpg-image-file
//http://www.delphigroups.info/2/12/317243.html
//http://www.efg2.com/Lab/Library/Delphi/Graphics/ImageProcessing.htm

indy ftp server

...unit1.pas...
unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StrUtils, IdThreadMgr, IdThreadMgrDefault, IdUserAccounts,
IdBaseComponent, IdComponent, IdTCPServer, IdFTPServer, IdFTPList, StdCtrls,
OleCtrls, SHDocVw, FileCtrl;

type
TForm1 = class(TForm)
IdFTPServer1: TIdFTPServer;
IdUserManager1: TIdUserManager;
FileListBox1: TFileListBox;
IdThreadMgrDefault1: TIdThreadMgrDefault;
WebBrowser1: TWebBrowser;
FileListBox2: TFileListBox;
Memo1: TMemo;
Edit1: TEdit;
Memo2: TMemo;
procedure IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
procedure FormCreate(Sender: TObject);
procedure IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
procedure FileListBox1Change(Sender: TObject);
procedure IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
const AFilename: String; var VFileSize: Int64);
procedure IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
{ Déclarations privées }
public
{ Déclarations publiques }
end;

var
Form1: TForm1;
implementation

{$R *.dfm}

procedure TForm1.IdFTPServer1ListDirectory(ASender: TIdFTPServerThread;
const APath: String; ADirectoryListing: TIdFTPListItems);
var
buf, FSize : Integer;
FName, FDate : String;
F : file of byte;
begin
Memo1.Clear;
FileListBox1.Directory := APath;
ASender.CurrentDir := '';
ADirectoryListing.ListFormat := flfDos;
for buf := 0 to FileListBox1.Items.Count -1 do
begin
FName := APath + FileListBox1.Items.Strings[Buf];
AssignFile(F, FName);
Reset(F);
FSize := FileSize(F);
CloseFile(F);
FDate := FormatDateTime('mm/dd/yy hh:nn',FileDateToDateTime(FileAge(FName)));
Memo1.Lines.Add(FDate + ' ' + IntToStr(FSize) + ' ' + FileListBox1.Items.Strings[buf]);
end;
Memo2.Clear;
for buf := 0 to FileListBox2.Items.Count -1 do
begin
Edit1.Clear;
Edit1.Text := FileListBox2.Items.Strings[Buf];
Edit1.SelStart := 0;
Edit1.SelLength := 1;
Edit1.ClearSelection;
Edit1.SelStart := Length(Edit1.Text) - 1;
Edit1.SelLength := 1;
Edit1.ClearSelection;
if (Edit1.Text <> '.') and (Edit1.Text <> '..') then
Memo2.Lines.Add(Edit1.Text);
end;
for buf := 0 to Memo2.Lines.Count - 1 do
begin
FDate := '01-01-01 00:00';
Memo1.Lines.Add(FDate + ' <DIR> ' + Memo2.Lines.Strings[buf]);
end;
ADirectoryListing.LoadList(Memo1.Lines);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
WebBrowser1.Navigate('ftp://127.0.0.1');
end;

procedure TForm1.IdFTPServer1ChangeDirectory(ASender: TIdFTPServerThread;
var VDirectory: String);
begin
ASender.CurrentDir := VDirectory;
end;

procedure TForm1.FileListBox1Change(Sender: TObject);
begin
FileListBox2.Directory := FileListBox1.Directory;
end;

procedure TForm1.IdFTPServer1GetFileSize(ASender: TIdFTPServerThread;
const AFilename: String; var VFileSize: Int64);
var
F : File of Byte;
begin
AssignFile(F, AFileName);
Reset(F);
VFileSize := FileSize(F);
CloseFile(F);
end;

procedure TForm1.IdFTPServer1RetrieveFile(ASender: TIdFTPServerThread;
const AFileName: String; var VStream: TStream);
begin
VStream := TFileStream.Create(AFileName,fmOpenRead);
end;

procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
idFTPServer1.Threads.Clear;
end;

end.

...Unit1.dfm...
object Form1: TForm1
Left = 211
Top = 107
Width = 640
Height = 433
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCloseQuery = FormCloseQuery
OnCreate = FormCreate
PixelsPerInch = 96
TextHeight = 13
object FileListBox1: TFileListBox
Left = 0
Top = 8
Width = 169
Height = 153
ItemHeight = 13
TabOrder = 0
OnChange = FileListBox1Change
end
object WebBrowser1: TWebBrowser
Left = 184
Top = 8
Width = 441
Height = 393
TabOrder = 1
ControlData = {
4C000000942D00009E2800000000000000000000000000000000000000000000
000000004C000000000000000000000001000000E0D057007335CF11AE690800
2B2E126208000000000000004C0000000114020000000000C000000000000046
8000000000000000000000000000000000000000000000000000000000000000
00000000000000000100000000000000000000000000000000000000}
end
object FileListBox2: TFileListBox
Left = 0
Top = 176
Width = 169
Height = 65
FileType = [ftDirectory]
ItemHeight = 13
TabOrder = 2
end
object Memo1: TMemo
Left = 0
Top = 248
Width = 169
Height = 129
Lines.Strings = (
'07/02/01 10:01 <DIR> Test'
'05/06/03 1:23 612 test.txt')
ScrollBars = ssBoth
TabOrder = 3
end
object Edit1: TEdit
Left = 0
Top = 384
Width = 121
Height = 21
TabOrder = 4
Text = 'Edit1'
end
object Memo2: TMemo
Left = 0
Top = 292
Width = 185
Height = 69
Lines.Strings = (
'Memo2')
ScrollBars = ssBoth
TabOrder = 5
end
object IdFTPServer1: TIdFTPServer
Active = True
Bindings = <>
CommandHandlers = <>
DefaultPort = 21
Greeting.NumericCode = 220
Greeting.Text.Strings = (
'Serveur FTP Indy prêt.')
Greeting.TextCode = '220'
MaxConnectionReply.NumericCode = 0
ReplyExceptionCode = 0
ReplyTexts = <>
ReplyUnknownCommand.NumericCode = 500
ReplyUnknownCommand.Text.Strings = (
'Erreur de syntaxe, commande non reconnue.')
ReplyUnknownCommand.TextCode = '500'
ThreadMgr = IdThreadMgrDefault1
AnonymousAccounts.Strings = (
'anonymous'
'ftp'
'guest')
HelpReply.Strings = (
'FTP Server by LunaticSkunk')
UserAccounts = IdUserManager1
SystemType = 'WIN32'
OnChangeDirectory = IdFTPServer1ChangeDirectory
OnGetFileSize = IdFTPServer1GetFileSize
OnListDirectory = IdFTPServer1ListDirectory
OnRetrieveFile = IdFTPServer1RetrieveFile
Left = 258
Top = 242
end
object IdUserManager1: TIdUserManager
Accounts = <
item
UserName = 'User'
Password = '1234'
end>
CaseSensitiveUsernames = False
CaseSensitivePasswords = False
Left = 194
Top = 238
end
object IdThreadMgrDefault1: TIdThreadMgrDefault
Left = 222
Top = 240
end
end

Volume set

var
MixerControl: TMixerControl;
MixerControlDetails: TMixerControlDetails;
MixerControlDetailsSigned: TMixerControlDetailsSigned;
Mixer: THandle;
MixerLine: TMixerLine;
MixerLineControls: TMixerLineControls;
PeakMeter: DWord;
Rslt: DWord;
SourceCount: Cardinal;
WaveOut: DWord;
I: Integer;
X: Integer;
Y: Integer;
begin
Rslt := mixerOpen(@Mixer, 0, 0, 0, 0);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t open mixer (%d)', [Rslt]);
FillChar(MixerLine, SizeOf(MixerLine), 0);
MixerLine.cbStruct := SizeOf(MixerLine);
MixerLine.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
Rslt := mixerGetLineInfo(Mixer, @MixerLine,
MIXER_GETLINEINFOF_COMPONENTTYPE);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t find speaker line (%d)', [Rslt]);
SourceCount := MixerLine.cConnections;
WaveOut := $FFFFFFFF;
for I := 0 to SourceCount - 1 do
begin
MixerLine.dwSource := I;
Rslt := mixerGetLineInfo(Mixer, @MixerLine,
MIXER_GETLINEINFOF_SOURCE);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t get source line (%d)', [Rslt]);
if MixerLine.dwComponentType = MIXERLINE_COMPONENTTYPE_SRC_WAVEOUT
then
begin
WaveOut := MixerLine.dwLineId;
Break;
end;
end;
if WaveOut = $FFFFFFFF then
raise Exception.Create('Can''t find wave out device');
FillChar(MixerLineControls, SizeOf(MixerLineControls), 0);
with MixerLineControls do
begin
cbStruct := SizeOf(MixerLineControls);
dwLineId := WaveOut;
dwControlType := MIXERCONTROL_CONTROLTYPE_PEAKMETER;
cControls := 1;
cbmxctrl := SizeOf(TMixerControl);
pamxctrl := @MixerControl;
end;
Rslt := mixerGetLineControls(Mixer, @MixerLineControls,
MIXER_GETLINECONTROLSF_ONEBYTYPE);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t find peak meter control (%d)',
[Rslt]);
PeakMeter := MixerControl.dwControlID;

// at this point, I have the meter control ID, so I can
// repeatedly query its value and plot the resulting data
// on a canvas

X := 0;
FillChar(MixerControlDetails, SizeOf(MixerControlDetails), 0);
with MixerControlDetails do
begin
cbStruct := SizeOf(MixerControlDetails);
dwControlId := PeakMeter;
cChannels := 1;
cbDetails := SizeOf(MixerControlDetailsSigned);
paDetails := @MixerControlDetailsSigned;
end;
repeat
Sleep(10);
Rslt := mixerGetControlDetails(Mixer, @MixerControlDetails,
MIXER_GETCONTROLDETAILSF_VALUE);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t get control details (%d)',
[Rslt]);
Application.ProcessMessages;
Inc(X);
Y := 300 - Round(300 * Abs(MixerControlDetailsSigned.lValue) /
32768);
with Canvas do
begin
MoveTo(X, 0);
Pen.Color := clBtnFace;
LineTo(X, 300);
Pen.Color := clWindowText;
LineTo(X, Y);
end;
until X > 500;

// don't forget to close the mixer handle when you're done

Rslt := mixerClose(Mixer);
if Rslt <> 0 then
raise Exception.CreateFmt('Can''t close mixer (%d)', [Rslt]);
end;

http://torry.net/pages.php?id=186

http://www.swissdelphicenter.ch/en/showcode.php?id=225

{1.}

uses
MMSystem;

procedure SetVolume(const volL, volR: Word);
var
hWO: HWAVEOUT;
waveF: TWAVEFORMATEX;
vol: DWORD;
begin
// init TWAVEFORMATEX
FillChar(waveF, SizeOf(waveF), 0);
// open WaveMapper = std output of playsound
waveOutOpen(@hWO, WAVE_MAPPER, @waveF, 0, 0, 0);
vol := volL + volR shl 16;
// set volume
waveOutSetVolume(hWO, vol);
waveOutClose(hWO);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
SetVolume(14000, 14000);
end;

{************************************************}

{2.}

{by Serhiy Perevoznyk}

uses
MMSystem;

function GetVolumeControl(aMixer: HMixer; componentType, ctrlType: Longint;
var mxc: TMixerControl): Boolean;
var
mxl: TMixerLine;
mxlc: TMixerLineControls;
rc: Longint;
begin
Result := False;
FillChar(mxl, SizeOf(TMixerLine), 0);
mxl.cbStruct := SizeOf(TMixerLine);
mxl.dwComponentType := componentType;
{Obtain a line corresponding to the component type}
rc := mixerGetLineInfo(aMixer, @mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);
if rc = MMSYSERR_NOERROR then
begin
with mxlc do
begin
cbStruct := SizeOf(TMixerLineControls);
dwLineID := mxl.dwLineID;
dwControlType := ctrlType;
cControls := 1;
cbmxctrl := SizeOf(TMixerLine);
pamxctrl := @mxc;
pamxctrl^.cbStruct := SizeOf(TMixerControl);
end;
mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
rc := mixerGetLineControls(aMixer, @mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
Result := rc = MMSYSERR_NOERROR;
end;
end;

function SetVolumeControl(aMixer: HMixer; mxc: TMixerControl; volume: Longint): Boolean;
var
mxcd: TMixerControlDetails;
vol: TMixerControlDetails_Unsigned;
rc: MMRESULT;
begin
FillChar(mxcd, SizeOf(mxcd), 0);
with mxcd do
begin
cbStruct := SizeOf(TMixerControlDetails);
dwControlID := mxc.dwControlID;
cbDetails := SizeOf(TMixerControlDetails_Unsigned);
paDetails := @vol;
cMultipleItems := 0;
cChannels := 1;
end;
vol.dwValue := volume;
rc := mixerSetControlDetails(aMixer, @mxcd, MIXER_SETCONTROLDETAILSF_VALUE);
Result := rc = MMSYSERR_NOERROR;
end;

function InitMixer: HMixer;
var
Err: MMRESULT;
begin
Err := mixerOpen(@Result, 0, 0, 0, 0);
if Err <> MMSYSERR_NOERROR then
Result := 0;
end;

// Example:

procedure SetMasterVolumeToZero;
var
MyMixerHandle: HMixer;
MyVolCtrl: TMixerControl;
begin
MyMixerHandle := InitMixer;
if MyMixerHandle <> 0 then
try
FillChar(MyVolCtrl, SizeOf(MyVolCtrl), 0);
if GetVolumeControl(MyMixerHandle, MIXERLINE_COMPONENTTYPE_DST_SPEAKERS,
MIXERCONTROL_CONTROLTYPE_VOLUME, MyVolCtrl) then
begin
{The last parameter (0) here is the volume level}
if SetVolumeControl(MyMixerHandle, MyVolCtrl, 0) then
ShowMessage('Volume should now be set to zero');
end;
finally
mixerClose(MyMixerHandle);
end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
SetMasterVolumeToZero
end;

hta links

http://analystcave.com/vbs-hta-example-for-vba-developers/

http://www.robvanderwoude.com/htaexamples.php

https://www.techwalla.com/articles/how-to-run-an-hta-file-from-vbscript

http://www.htasoft.com/progressbar_hta.htm

pretraga fajlova

List.Items.Add(s+SearchRec.Name+IntToStr(PosInFile(ja,s+SearchRec.Name))); { Adding to list }
http://atviewer.sourceforge.net/atstreamsearch.htm
http://www.yunqa.de/delphi/products/tntunicodecontrols/index
https://community.embarcadero.com/images/38980/Delphi_and_Unicode.pdf
https://www.embarcadero.com/images/old/dm/technical-papers/delphi-in-a-unicode-world-updated.pdf
-------------------------

procedure TForm1.AddAllFilesInDir(const Dir: string);
var
SR: TSearchRec;
begin
if FindFirst(IncludeTrailingBackslash(Dir) + '*.*', faAnyFile or faDirectory, SR) = 0 then
try
repeat
if (SR.Attr and faDirectory) = 0 then
ListBox1.Items.Add(SR.Name)
else if (SR.Name <> '.') and (SR.Name <> '..') then
AddAllFilesInDir(IncludeTrailingBackslash(Dir) + SR.Name); // recursive call!
until FindNext(Sr) <> 0;
finally
FindClose(SR);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
ListBox1.Items.BeginUpdate;
AddAllFilesInDir('C:\Users\Andreas Rejbrand\Documents\Aweb');
ListBox1.Items.EndUpdate;
end;

------------------------

procedure FindDocs(const Root: string);
var
SearchRec: TSearchRec;
Folders: array of string;
Folder: string;
I: Integer;
Last: Integer;
begin
SetLength(Folders, 1);
Folders[0] := Root;
I := 0;
while (I < Length(Folders)) do
begin
Folder := IncludeTrailingBackslash(Folders[I]);
Inc(I);
{ Collect child folders first. }
if (FindFirst(Folder + '*.*', faDirectory, SearchRec) = 0) then
begin
repeat
if not ((SearchRec.Name = '.') or (SearchRec.Name = '..')) then
begin
Last := Length(Folders);
SetLength(Folders, Succ(Last));
Folders[Last] := Folder + SearchRec.Name;
end;
until (FindNext(SearchRec) <> 0);
FindClose(SearchRec);
end;
{ Collect files next.}
if (FindFirst(Folder + '*.doc', faAnyFile - faDirectory, SearchRec) = 0) then
begin
repeat
if not ((SearchRec.Attr and faDirectory) = faDirectory) then
begin
WriteLn(Folder, SearchRec.Name);
end;
until (FindNext(SearchRec) <> 0);
FindClose(SearchRec);
end;
end;
end;

----------------------------

procedure TForm1.Button1Click(Sender: TObject);
begin
GetAllSubFolders(Edit1.Text);
end;

procedure TForm1.GetAllSubFolders(sPath: String);
var
Path : String;
Rec : TSearchRec;
begin
try
Path := IncludeTrailingBackslash(sPath);
if FindFirst(Path + '*.*', faDirectory, Rec) = 0 then
try
repeat
if (Rec.Name<>'.') and (Rec.Name<>'..') then
begin
ListBox1.Items.Add(Path+Rec.Name);
GetAllSubFolders(Path + Rec.Name);
end;
until FindNext(Rec) <> 0;
finally
FindClose(Rec);
end;
except
on e: Exception do
Showmessage('Err : TForm1.GetAllSubFolders - '+e.Message);
end;
end;

-----------------------

procedure GetSubDirs(const sRootDir: string; slt: TStrings);
var
srSearch: TSearchRec;
sSearchPath: string;
sltSub: TStrings;
i: Integer;
begin
sltSub := TStringList.Create;
slt.BeginUpdate;
try
sSearchPath := AddDirSeparator(sRootDir);
if FindFirst(sSearchPath + '*', faDirectory, srSearch) = 0 then
repeat
if ((srSearch.Attr and faDirectory) = faDirectory) and
(srSearch.Name <> '.') and
(srSearch.Name <> '..') then
begin
slt.Add(sSearchPath + srSearch.Name);
sltSub.Add(sSearchPath + srSearch.Name);
end;
until (FindNext(srSearch) <> 0);

FindClose(srSearch);

for i := 0 to sltSub.Count - 1 do
GetSubDirs(sltSub.Strings[i], slt);
finally
slt.EndUpdate;
FreeAndNil(sltSub);
end;
end;

------------------------------

procedure TForm1.ListDir(Path:String; List:TListBox);
{Path : string that contains start path for listing filenames and directories
List : List box in which found filenames are going to be stored }
var
SearchRec:TsearchRec;
Result:integer;
S:string; { Used to hold current directory, GetDir(0,s) }
begin
try {Exception handler }
ChDir(Path);
except on EInOutError do
begin
MessageDlg('Error occurred by trying to change directory',mtWarning,[mbOK],0);
Exit;
end;
end;
if length(path)<> 3 then path:=path+'\'; { Checking if path is root, if not add }
FindFirst(path+'*.*',faAnyFile,SearchRec); { '\' at the end of the string }
{ and then add '*.*' for all file }
Repeat
if SearchRec.Attr=faDirectory then { if directory then }
begin
if (SearchRec.Name<>'.') and (SearchRec.Name<>'..') then { Ignore '.' and '..' }
begin
GetDir(0,s); { Get current dir of default drive }
if length(s)<>3 then s:=s+'\'; { Checking if root }
List.Items.Add(s+SearchRec.Name); { Adding to list }
ListDir(s+SearchRec.Name,List); { ListDir found directory }
end;
end
else { if not directory }
begin
GetDir(0,s); { Get current dir of default drive }
if length(s)<>3 then List.items.add(s+'\'+SearchRec.Name) { Checking if root }
else List.items.add(s+SearchRec.Name); { Adding to list }
end;
Result:=FindNext(SearchRec);
Application.ProcessMessages;
until result<>0; { Found all files, go out }
GetDir(0,s);
if length(s)<>3 then ChDir('..'); { if not root then go back one level }
end;

---------------------------

procedure GetFiles(APath: string; AExt: string; AList: TStrings; ARecurse:
boolean);
var
theExt: string;
searchRec: SysUtils.TSearchRec;
begin
if APath[Length(APath)] <> '\' then
APath := APath + '\';
AList.AddObject(APath, Pointer(-1));
if FindFirst(APath + '*.*', faAnyFile, searchRec) = 0 then try
repeat
with searchRec do begin
if (Name <> '.') and (Name <> '..') then
if (Attr and faDirectory <= 0) then begin
theExt := '*' + UpperCase(ExtractFileExt(searchRec.Name));
if (AExt = '*.*') or (theExt = UpperCase(AExt)) then
AList.AddObject(searchRec.Name, Pointer(0))
end
else begin
if ARecurse then begin
GetFiles(APath + Name + '\', AExt, AList, ARecurse);
end;
end;
end; {with searchRec...}
Application.ProcessMessages;
until FindNext(searchRec) <> 0;
finally
SysUtils.FindClose(searchRec);
end;
end;

----------------------------------

function PosInFile(Str,FileName:string):integer;
var
Buffer : array [0..1023] of char;
BufPtr,BufEnd:integer;
F:File;
Index : integer;
Increment : integer;
c : char;

function NextChar : char;
begin
if BufPtr>=BufEnd then
begin
BlockRead(F,Buffer,1024,BufEnd);
BufPtr := 0;
Form1.ProgressBar1.Position := FilePos(F);
Application.ProcessMessages;
end;
Result := Buffer[BufPtr];
Inc(BufPtr);
end;

begin
Result := -1;
AssignFile(F,FileName);
Reset(F,1);
Form1.ProgressBar1.Max := FileSize(F);
BufPtr:=0;
BufEnd:=0;
Index := 0;
Increment := 1;
repeat
c:=NextChar;
if c=Str[Increment] then
Inc(Increment)
else
begin
Inc(Index,Increment);
Increment := 1;
end;
if Increment=(Length(Str)+1) then
begin
Result := Index;
break;
end;
until BufEnd = 0;
CloseFile(F);
Form1.ProgressBar1.Position := 0;
end;

-------------------------

function ScanFile( const filename: String; const forString: String;
caseSensitive: Boolean ): LongInt;
{ returns position of string in file or -1, if not found }
const
BufferSize= $8001; { 32K + 1 bytes }
var
pBuf, pEnd, pScan, pPos: Pchar;
filesize: LongInt;
bytesRemaining: LongInt;
bytesToRead: Word;
F: File;
SearchFor: Pchar;
oldMode: Word;
begin
Result := - 1; { assume failure }
if (Length( forString ) = 0) or (Length( filename ) = 0) then
Exit;
SearchFor := Nil;
pBuf := Nil;
{ open file as binary, 1 byte recordsize }
AssignFile( F, filename );
oldMode := FileMode;
FileMode := 0; { read-only access }
Reset( F, 1 );
FileMode := oldMode;
try { allocate memory for buffer and pchar search string }
SearchFor := StrAlloc( Length( forString ) +1 );
StrPCopy( SearchFor, forString );
if not caseSensitive then { convert to upper case }
AnsiUpper( SearchFor );
GetMem( pBuf, BufferSize );
filesize := System.Filesize( F );
bytesRemaining := filesize;
pPos := Nil;
while bytesRemaining > 0 do
begin
{ calc how many bytes to read this round }
if bytesRemaining >= BufferSize then
bytesToRead := Pred( BufferSize )
else
bytesToRead := bytesRemaining;
{ read a buffer full and zero-terminate the buffer }
BlockRead( F, pBuf^, bytesToRead, bytesToRead );
pEnd := @pBuf[ bytesToRead ];
pEnd^ := #0;
{ scan the buffer. Problem: buffer may contain #0 chars! So we
treat it as a concatenation of zero-terminated strings. }
pScan := pBuf;
while pScan < pEnd do
begin
if not caseSensitive then { convert to upper case }
AnsiUpper( pScan );
pPos := StrPos( pScan, SearchFor ); { search for substring }
if pPos <> Nil then
begin { Found it! }
Result := FileSize - bytesRemaining + LongInt( pPos )
- LongInt( pBuf );
Break;
end;
pScan := StrEnd( pScan );
Inc( pScan );
end;
if pPos <> Nil then
Break;
bytesRemaining := bytesRemaining - bytesToRead;
if bytesRemaining > 0 then
begin
{ no luck in this buffers load. We need to handle the case of
the search string spanning two chunks of file now. We simply
go back a bit in the file and read from there, thus inspecting
some characters twice }
Seek( F, FilePos(F) - Length( forString ));
bytesRemaining := bytesRemaining + Length( forString );
end;
end;
finally
CloseFile( F );
if SearchFor <> Nil then
StrDispose( SearchFor );
if pBuf <> Nil then
FreeMem( pBuf, BufferSize );
end;
end;

-------------------------

procedure TForm1.Button1Click(Sender: TObject);
var
FromF, ToF: file;
NumRead, NumWritten: Integer;
Buf: array[1..2048] of Char;
begin
if OpenDialog1.Execute then { Display Open dialog box. }
begin
AssignFile(FromF, OpenDialog1.FileName);
Reset(FromF, 1); { Record size = 1 }
if SaveDialog1.Execute then { Display Save dialog box. }
begin
AssignFile(ToF, SaveDialog1.FileName); { Open output file. }
Rewrite(ToF, 1); { Record size = 1 }
Canvas.TextOut(10, 10, 'Copying ' + IntToStr(FileSize(FromF))
+ ' bytes...');
repeat
System.BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
BlockWrite(ToF, Buf, NumRead, NumWritten);
until (NumRead = 0) or (NumWritten <> NumRead);
// Use CloseFile rather than Close; Close is provided for backward compatibility.
CloseFile(FromF);
CloseFile(ToF);
Canvas.TextOut(120, 10, ' done.');
end;
end;
end;

-------------------------

//search and replace

Var
TheFile : String;
SearchStringPos : Integer;
YourSearchString : ShortString;
YourReplaceString : ShortString;
begin
RichEdit1.PlainText:=true;
RichEdit1.Lines.LoadFromFile('YourFile.html');
YourSearchString := '<BR>';
YourReplaceString := '<HR>';
TheFile:=RichEdit1.Text;
SearchStringPos:=Pos(YourSearchString,TheFile);
While SearchStringPos > 0 do
begin
RichEdit1.SelStart:=SearchStringPos-1;
RichEdit1.SelLength:=length(YourSearchString);
RichEdit1.SelText:=YourReplaceString;
TheFile:=RichEdit1.Text;
SearchStringPos:=Pos(YourSearchString,TheFile)
end;
RichEdit1.Lines.SaveToFile('YourFile.html');
end;

-------------------------
//SysUtils unit

TS := TStringList.Create;
try
TS.LoadFromFile(filename);
TS.Text := StringReplace(TS.Text, 'foo', 'bar', [rfreplaceAll]);
TS.SaveToFile(filename);
finally
TS.Free;
end;

//TS.Text := StringReplace(TS.Text, '<hr>', '<br>', [rfreplaceAll,rfIgnoreCase]);
-----------------------------

Custom programming, Screenter, Opener, Searcher Applications

beogradsko programiranje