Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель»




Скачать 482.12 Kb.
Название Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель»
страница 4/4
Тип Курсовой проект
rykovodstvo.ru > Руководство эксплуатация > Курсовой проект
1   2   3   4

saveBML(ExtractFilePath(Application.ExeName)+'data\plData.bml',true)

else

saveBML(ExtractFilePath(Application.ExeName)+'data\plData.bml',false);

DXAudioOut.Stop(false);

end;

saveOptions;

end;
procedure Tface.FormDockOver(Sender: TObject; Source: TDragDockObject; X, Y:

Integer; State: TDragState; var Accept: Boolean);

begin

Accept:=false;

end;
function Tface.getPlayingID: Integer;

begin

Result := PlayingID;

end;
function Tface.getPlayingIndex: Integer;

begin

result := PlayingIndex;

end;
function Tface.GetSelectedItem: Integer;

begin

Result := play_list.ItemIndex;

end;
procedure Tface.opFileClick(Sender: TObject);

var

i: Integer;

begin

with dm do

if fOP_med.Execute then

for i:=0 to fOP_med.Files.Count - 1 do

scanfile(fOP_med.Files.Strings[i]);

end;
procedure Tface.playClick(Sender: TObject);

var

SelInd: Integer;

begin

with dm do

if plPlay.Down then

begin

case DXAudioOut.Status of

tosPlaying: //если проигрывается файл то ставим паузу

begin

DXAudioOut.Pause;

t3.Enabled:=false;

if fiTeest(getPlayingIndex) then

play_list.Items.Item[getPlayingIndex].StateIndex:=img_state_pause;

plPlay.ImageIndex:=img_state_play;

SetTrayInfo('BolidAmp | Пауза');

end;

tosPaused: //если пауза то старт проигрывания

begin

DXAudioOut.Resume;

T3.Enabled:=true;

if fiTeest(getPlayingIndex) then

play_list.Items.Item[getPlayingIndex].StateIndex:=img_state_play;

plPlay.ImageIndex:=img_state_pause;

SetTrayInfo('BolidAmp | '+StatusPane1.Caption);

end;

tosIdle: //если стоп то стартуем проигрывание первого в списке файла

begin

SelInd := GetSelectedItem;

if (SelInd < 0) and (play_list.Items.Count > 0) then

SelInd := 0;

if SelInd >= 0 then

if (SelInd<>getPlayingIndex)or(getPlayingIndex<>0)or(0=SelInd) then

begin

StopPlaying := False;

PlayItem(SelInd);

end;

end;

end;

plPlay.Down:=false;

end

else

if (DXAudioOut.Status=tosIdle)

or(DXAudioOut.Status=tosPaused) then playClick(nil);

end;
procedure Tface.PlayItem(index: integer);

var

fi: TAuFileIn;

FileName: string;

SR: TSearchRec;

begin

try

with dm do

if StopPlaying=false then

begin

Playingprevios:=PlayingIndex;

PlayingIndex:= index;

resetPlStatus(Playingprevios);
plPlay.ImageIndex:=0;

dm.t3.Enabled:=false;

DXAudioOut.Stop(False);

FileName := play_list.Items.Item[PlayingIndex].SubItems[vlPlFilePach];
FI := nil;

case mediaType(FileName) of

mNull : FI := nil;

mp3 : FI := MP3in;

wav : FI := Wavein;

wma : FI := WMin;

ogg : FI := Vorbisin;

flac : FI := FLACin;

ape : FI := MacIn;

end;
if FI = nil then

begin

StatusPane1.Caption := 'файл не поддерживается';

play_list.Items.Item[PlayingIndex].StateIndex:=img_state_error;

Exit;

end;

FI.FileName := FileName;

if not FI.Valid then

begin

StatusPane1.Caption := 'невозможно проиграть фал. файл повреждён или кодировка различается.';

play_list.Items.Item[PlayingIndex].StateIndex:=img_state_error;

Exit;

end;

try

sBalance.input:=FI;

tb.max:=FI.TotalTime;

play_list.Items.Item[PlayingIndex].SubItems.Strings[vlPlTime]:=FormatedTime(FI.TotalTime);
dm.tagID3(FI,PlayingIndex);
StatusPane1.Caption := 'Проигрывается: '

+ play_list.Items.Item[PlayingIndex].SubItems.Strings[vlPlArtist]

+ ' - '

+ play_list.Items.Item[PlayingIndex].Caption

+ '. Альбом: '

+ play_list.Items.Item[PlayingIndex].SubItems.Strings[vlPlAlbum]

+ '. Время: '

+ play_list.Items.Item[PlayingIndex].SubItems.Strings[vlPlTime];

SetTrayInfo('BolidAmp | '+StatusPane1.Caption);
resetPlStatus(Playingprevios);

play_list.Items.Item[PlayingIndex].checked:=true;

play_list.Items.Item[PlayingIndex].StateIndex:=img_state_play;

plPlay.ImageIndex:=img_state_pause;

//Playingprevios:=PlayingIndex;

{

if play_list.Items.Item[PlayingIndex].SubItems.Strings[4]='' then

begin

inc(Playingcount);

play_list.Items.Item[PlayingIndex].SubItems.Strings[4]:=inttostr(Playingcount);

PlayingID:=Playingcount;

end

else

PlayingID:=strtoint(play_list.Items.Item[PlayingIndex].SubItems.Strings[4]);}

DXAudioOut.Run;

T3.Enabled:=true;

tb.Enabled:=true;

except

play_list.Items.Item[PlayingIndex].StateIndex:=img_state_error;

DXAudioOut.Stop(false);

end;

try

imgAlbum.Picture.LoadFromFile(ExtractFileDir(play_list.Items.Item[PlayingIndex].SubItems[vlPlFilePach])+'\Folder.jpg');

except

if FindFirst(ExtractFileDir(play_list.Items.Item[PlayingIndex].SubItems[vlPlFilePach]) + '\*.jpg', faAnyFile, SR) = 0 then

begin

if SR.Attr <> faDirectory then

imgAlbum.Picture.LoadFromFile(ExtractFileDir(play_list.Items.Item[PlayingIndex].SubItems[vlPlFilePach])

+ '\' + sr.Name);

FindClose(SR);

end

else

imgAlbum.Picture.LoadFromFile(ExtractFilePath(Application.ExeName)+'image\def_audio.png');

end;
end

else

begin

dxaudioout.Stop(false);

DXAudioOut.OnDone(nil);

end;

plPlay.Down:=false;

finally

end;

end;
procedure Tface.play_listDblClick(Sender: TObject);

var

SelInd: Integer;

begin

SelInd := GetSelectedItem;

if SelInd >= 0 then

begin

PlayItem(SelInd);

end;

end;
procedure Tface.play_listDragOver(Sender, Source: TObject; X, Y: Integer;

State: TDragState; var Accept: Boolean);

begin

if (Source <> Sender) then Accept:=true

else Accept:=false;

end;
procedure Tface.play_listEditing(Sender: TObject; Item: TListItem; var

AllowEdit: Boolean);

begin

AllowEdit:=false;

end;
procedure Tface.play_listKeyPress(Sender: TObject; var Key: Char);

var

i: Integer;

begin

i:=0;

if key=#8 then

with play_list.Items do

while i<=Count - 1 do

if Item[i].Selected=true then

begin

Item[i].Delete;

if i=PlayingIndex then

PlayingIndex:=-1;

end

else inc(i);

if Odd(GetKeyState(vk_CONTROL))and(key=#1) then play_list.SelectAll;

if key=#13 then play_list.OnDblClick(nil);
end;
procedure Tface.plClearClick(Sender: TObject);

begin

play_list.Clear;

end;
procedure Tface.plNextClick(Sender: TObject);

var

temp: Integer;

begin

randomize;

StopPlaying:=false;

temp:=PlayingIndex;

if play_list.Items.Count-1<0 then

begin

Playingprevios:=0;

exit;

end;

if plRandom.Down then temp:=random(play_list.Items.Count)

else

if PlayingIndex+1<=play_list.Items.Count-1 then inc(temp)

else

if (plRepeat.Down)AND(play_list.Items.Count-1>0) then PlayingIndex:=0

else

StopPlaying:=true;

PlayItem(temp);

end;
procedure Tface.plOpenClick(Sender: TObject);

var

pl: string;

begin

with dm do

if dm.OpenPl.Execute then

begin

pl:=ExtractFileExt(OpenPl.FileName);

pl:=AnsiLowerCase(pl);

if pl = '.bml' then readBML(OpenPl.FileName);

end;
end;
procedure Tface.plOpSaveClick(Sender: TObject);

begin

dm.t2.Interval:=face.plScanIdle.Value;

dm.plAddSpeed:=face.plAddSpeed.Value;

dm.plAddCol:=face.plAddCol.Value;

end;
procedure Tface.plPrevClick(Sender: TObject);

begin

if (Playingprevios<=play_list.Items.Count-1)AND(Playingprevios>-1) then

begin

PlayItem(Playingprevios);

end;

end;
procedure Tface.plSaveClick(Sender: TObject);

var

pl: string;

begin

with dm do

if SavePl.Execute then

begin

pl:=ExtractFileExt(OpenPl.FileName);

pl:=AnsiLowerCase(pl);

if SavePL.FilterIndex = 1 then

saveBML(savePl.FileName,false);

end
end;
procedure Tface.plStopClick(Sender: TObject);

begin

with dm do

begin

if DXAudioOut.Status<>tosIdle then

begin

plPlay.ImageIndex:=img_state_play;

resetPlStatus(getPlayingIndex);

T3.Enabled:=false;

LCD.Lines[0]:='BolidAMP';

LCD.Refresh;

DXAudioOut.Stop(false);

tb.Enabled:=false;

end;

end;
end;
procedure Tface.readBML(pach:string);

var

b: array [1..2] of boolean;

dir: string;

i: Integer;

PL: IXMLPlaylistType;

t: Byte;

x: Integer;

y: Integer;

begin

try

dir:=ExtractFileDir(pach);

pl:= LoadPlaylist(pach);

b[2]:= false;

b[1]:= pl.Play;

x:=play_list.Items.Count; i:= 0; y:= 0;

while pl.Count>y do

begin

while pl.Artist[y].Album.Count>i do

begin

Play_list.Items.Add.Caption:=pl.Artist[y].Album.Item[i].Caption;

for t := 0 to vlPlstringsCount do

Play_list.Items.Item[x].SubItems.Add('');

Play_list.Items.Item[x].SubItems.Strings[vlPlArtist] :=pl.Artist[y].Tag;

Play_list.Items.Item[x].SubItems.Strings[vlPlAlbum] :=pl.Artist[y].Album.Tag;

Play_list.Items.Item[x].SubItems.Strings[vlPlTime] :=pl.Artist[y].Album.Item[i].Time;

Play_list.Items.Item[x].SubItems.Strings[vlPlFilePach]:=RelativePathToAbsolute(dir,pl.Artist[y].Album.Item[i].Pach);

Play_list.Items.Item[x].Checked :=pl.Artist[y].Album.Item[i].Checked;

if pl.Artist[y].Album.Item[i].Selected then

if b[1] then

begin

{p:=tb2.Position;

tb2.Position:=0; }

PlayItem(x);{

while p<>tb2.Position do

begin

sleep(30);

tb2.Position:=tb2.Position+1;

end; }

end;

if pl.Artist[y].Album.Item[i].Checked=false then b[2]:=true;

inc(i); inc(x);

end;

i:=0;

inc(y);

end;

if b[2] then dm.t2.Enabled:=true;

finally

pl.Clear;

pl:=nil;

end;

end;
procedure Tface.readOptions;

var

ini: TiniFile;

begin

ini:=TiniFile.Create(ExtractFileDir(application.ExeName)+'\options.ini');

AlbumArt.Collapsed := ini.ReadBool ('Interface','AlbumArtCollapsed',false);

Manipulation.Collapsed := ini.ReadBool ('Interface','ManipulationCollapsed',false);

face.ClientHeight := ini.ReadInteger('Interface','MainForm.Heigth',550);

face.ClientWidth := ini.ReadInteger('Interface','MainForm.Width',800);

face.Left := ini.ReadInteger('Interface','MainForm.Left',100);

face.Top := ini.ReadInteger('Interface','MainForm.Top',100);

application.ShowMainForm:= ini.ReadBool ('Interface','MainForm.Show',true);

tb2.Position := ini.ReadInteger('Sound','Volume',100);

tbBalance.Position := ini.ReadInteger('Sound','Balance',50);

plRepeat.Down := ini.ReadBool ('Control','Repeat',false);

plRandom.Down := ini.ReadBool ('Control','Random',false);

plAddCol.Value := ini.ReadInteger('plScan','plAddCol',10);

plAddSpeed.Value := ini.ReadInteger('plScan','plAddSpeed',50);

plScanIdle.Value := ini.ReadInteger('plScan','plScanIdle ',5);

AssCheck.ItemChecked[0] := ini.ReadBool ('regType','ogg',false);

AssCheck.ItemChecked[1] := ini.ReadBool ('regType','mp3',false);

AssCheck.ItemChecked[2] := ini.ReadBool ('regType','wav',false);

AssCheck.ItemChecked[3] := ini.ReadBool ('regType','wma',false);

AssCheck.ItemChecked[4] := ini.ReadBool ('regType','ape',false);

AssCheck.ItemChecked[5] := ini.ReadBool ('regType','flac',false);

ini.Free;

dm.plAddSpeed :=plAddSpeed.Value;

dm.plAddCol :=plAddCol.Value;

end;
function Tface.ReadStringFromMailslot: string;

var

MessageSize: DWORD;

begin

// Получаем размер следующего сообщения в почтовом ящике

GetMailslotInfo(ServerMailslotHandle, nil, MessageSize, nil, nil);

// Если сообщения нет, возвращаем пустую строку

if MessageSize = MAILSLOT_NO_MESSAGE then

begin

Result := '';

Exit;

end;

// Выделяем для сообщения буфер и читаем его в этот буфер

SetLength(Result, trunc(MessageSize/SizeOf(string)));

ReadFile(ServerMailslotHandle, Result[1], MessageSize, MessageSize, nil);

end;
procedure Tface.resetPlStatus(index: integer);

begin

if index >-1 then

if play_list.Items.Count>index then

if (play_list.Items.Item[index].StateIndex<>img_state_error)

and (play_list.Items.Item[index].StateIndex<>img_state_none) then

play_list.Items.Item[index].StateIndex := img_state_none;

end;
procedure Tface.RzPageControl1Close(Sender: TObject; var AllowClose: Boolean);

begin

appClose

end;
procedure Tface.saveBML(pach: string;play:boolean);

var

dir: string;

i: Integer;

PL: IXMLPlaylistType;

s: UTF8string;

x: Integer;

y: Integer;

begin

dir:=ExtractFileDir(pach);

x:=0;y:=-1;i:=-1;

pl:= NewPlaylist;

pl.Play:= play;

while x


begin

if x>0 then

begin

if (play_list.Items.Item[x].SubItems.Strings[vlPlArtist]<>play_list.Items.Item[x-1].SubItems.Strings[vlPlArtist])

or (play_list.Items.Item[x].SubItems.Strings[vlPlAlbum]<>play_list.Items.Item[x-1].SubItems.Strings[vlPlAlbum]) then

begin

pl.Add.Tag:=play_list.Items.Item[x].SubItems.Strings[vlPlArtist]; inc(y);

pl.Artist[y].Album.Tag:=play_list.Items.Item[x].SubItems.Strings[vlPlAlbum];

i:=-1;

end{

else

if play_list.Items.Item[x].SubItems.Strings[vlPlAlbum]<>play_list.Items.Item[x-1].SubItems.Strings[vlPlAlbum] then

begin

pl.Artist[y].Album.Tag:=play_list.Items.Item[x].SubItems.Strings[vlPlAlbum];

i:=-1;

end};

inc(i);

pl.Artist[y].Album.Add.Caption:=play_list.Items.Item[x].Caption;

pl.Artist[y].Album.Item[i].Time:=play_list.Items.Item[x].SubItems.Strings[vlPlTime];

pl.Artist[y].Album.Item[i].Pach:=AbsolutePathToRelative(dir,play_list.Items.Item[x].SubItems.Strings[vlPlFilePach]);

pl.Artist[y].Album.Item[i].Checked:=play_list.Items.Item[x].Checked;

if x=PlayingIndex then

pl.Artist[y].Album.Item[i].Selected:=true

else

pl.Artist[y].Album.Item[i].Selected:=false;

end

else

begin

inc(y); inc(i);

pl.Add.Tag:=play_list.Items.Item[x].SubItems.Strings[vlPlArtist];

pl.Artist[y].Album.Tag:=play_list.Items.Item[x].SubItems.Strings[vlPlAlbum];

pl.Artist[y].Album.Add.Caption:=play_list.Items.Item[x].Caption;

pl.Artist[y].Album.Item[i].Time:=play_list.Items.Item[x].SubItems.Strings[vlPlTime];

pl.Artist[y].Album.Item[i].Pach:=AbsolutePathToRelative(dir,play_list.Items.Item[x].SubItems.Strings[vlPlFilePach]);

pl.Artist[y].Album.Item[i].Checked:=play_list.Items.Item[x].Checked;

if x=PlayingIndex then

pl.Artist[y].Album.Item[i].Selected:=true

else

pl.Artist[y].Album.Item[i].Selected:=false;

end;

inc(x);

end;

s:=UTF8String(pl.XML);

with TFileStream.create(pach, fmCreate or fmOpenWrite) do

try

write(pointer(s)^,length(s));

finally

free;

end;

pl.Clear;

pl:=nil;

end;
procedure Tface.saveOptions;

var

ini: TiniFile;

begin

ini:=TiniFile.Create(ExtractFileDir(application.ExeName)+'\options.ini');

ini.WriteBool ('Interface','AlbumArtCollapsed',AlbumArt.Collapsed);

ini.WriteBool ('Interface','ManipulationCollapsed',Manipulation.Collapsed);

ini.WriteInteger('Interface','MainForm.Heigth',face.ClientHeight);

ini.WriteInteger('Interface','MainForm.Width',face.ClientWidth);

ini.WriteInteger('Interface','MainForm.Left',face.Left);

ini.WriteInteger('Interface','MainForm.Top',face.Top);

ini.WriteBool ('Interface','MainForm.Show',face.Visible);

ini.WriteInteger('Sound','Volume',tb2.Position);

ini.WriteInteger('Sound','Balance',tbBalance.Position);

ini.WriteBool ('Control','Repeat',plRepeat.Down);

ini.WriteBool ('Control','Random',plRandom.Down);

ini.WriteInteger('plScan','plAddCol',plAddCol.Value);

ini.WriteInteger('plScan','plAddSpeed',plAddSpeed.Value);

ini.WriteInteger('plScan','plScanIdle',plScanIdle.Value );

ini.WriteBool ('regType','ogg',AssCheck.ItemChecked[0]);

ini.WriteBool ('regType','mp3',AssCheck.ItemChecked[1]);

ini.WriteBool ('regType','wav',AssCheck.ItemChecked[2]);

ini.WriteBool ('regType','wma',AssCheck.ItemChecked[3]);

ini.WriteBool ('regType','ape',AssCheck.ItemChecked[4]);

ini.WriteBool ('regType','flac',AssCheck.ItemChecked[5]);

ini.Free;

AssTrueClick(nil);

end;
procedure Tface.SearchListDblClick(Sender: TObject);

begin

playitem(strtoint(SearchList.Items.Item[SearchList.ItemIndex].SubItems.Strings[vlPlFilePach]));

//searchlist.Items.Item[SearchList.ItemIndex].ImageIndex:=play_list.Items.Item[PlayingIndex].ImageIndex;

end;
procedure Tface.SearchListKeyPress(Sender: TObject; var Key: Char);

var

i: Integer;

begin

i:=0;

if key=#8 then

with Searchlist.Items do

while i<=Count - 1 do

if Item[i].Selected=true then

begin

play_list.Items.Item[strtoint(item[i].SubItems.Strings[vlPlFilePach])];

if strtoint(item[i].SubItems.Strings[vlPlFilePach])=PlayingIndex then

PlayingIndex:=-1;

Item[i].Delete;

end

else inc(i);

//if key=#13 then play_list.OnDblClick(nil);

end;
procedure Tface.tb2Change(Sender: TObject);

begin

dm.setVolume;

end;
procedure Tface.tb2MouseDown(Sender: TObject; Button: TMouseButton; Shift:

TShiftState; X, Y: Integer);

begin

tb2.Position:=round(tb2.Max/100*(abs(tb2.Height-y)/(tb2.Height/100)));

end;
procedure Tface.TbBalanceChange(Sender: TObject);

begin

dm.sBalance.Balance:=tbBalance.Position/100;

end;
procedure Tface.TbBalanceContextPopup(Sender: TObject; MousePos: TPoint; var

Handled: Boolean);

begin

tbBalance.Position:=50;

end;
procedure Tface.TBChange(Sender: TObject);

begin

if dm.scroll_b then

begin

if tb.Max<>0 then

begin

dm.T1.Enabled:=true;

end;

end

else

dm.scroll_b:=true

end;
procedure Tface.TBMouseDown(Sender: TObject; Button: TMouseButton; Shift:

TShiftState; X, Y: Integer);

begin

tb.Position:=round(tb.Max/100*(x/(tb.Width/100)));

end;
procedure Tface.WMCommandArrived(var Message: TMessage);

begin

dm.scanfile(ReadStringFromMailslot);

end;
procedure Tface.WMDropFiles(var Msg: TWMDropFiles);
const

//maxlen = 32767; //максимально домустимая длинна пути на NTFS дисках

//maxlen = 16384; //половинное значение - итак много

//maxlen = 8192; //много - вредно =/

maxlen = 4096; //=(
var

h: THandle;

i: integer;

num: integer;

pchr: array[0..maxlen] of char;

//pchr: pwidechar;
begin

h := Msg.Drop;

num:=DragQueryFile(h,Dword(-1),nil,0);

for i:=0 to num-1 do

begin

DragQueryFile(h,i,pchr,maxlen);

dm.scanfile(string(pchr));

end;

DragFinish(h);

end;

end.

unit controlls_comp;
interface
uses

SysUtils, Classes, ACS_Classes, ACS_DXAudio, ACS_MPC, ACS_TAK, ACS_OptimFROG,

ACS_TTA, ACS_WavPack, ACS_FLAC, ACS_MAC, ACS_WinMedia, ACS_smpeg, ACS_Wave,

ACS_Vorbis, ExtCtrls, ImgList, Controls, NewAC_DSP, ACS_Converters,

PNGImage, AMixer, ACS_Misc, Dialogs, Menus, RzShellDialogs, tech_unit

;

type
TMediaType = (mNull, mp3, ogg, flac, wav, wma, aac, ape, cda, bml);
TDM = class(TDataModule)



DXAudioOut: TDXAudioOut;

FLACIn: TFLACIn;

FLACt: TFLACIn;

fOP_med: TOpenDialog;

imgOther: TImageList;

imgPlay: TImageList;

MACIn: TMACIn;

MACt: TMACIn;

MP3In: TMP3In;

MP3t: TMP3In;

MPCIn: TMPCIn;

N1: TMenuItem;

N2: TMenuItem;

N3: TMenuItem;

OFRIn: TOFRIn;

OpenPl: TOpenDialog;

savePl: TSaveDialog;

sBalance: TStereoBalance;

SelectFolder: TRzSelectFolderDialog;

ShowHide: TMenuItem;

T1: TTimer;

t2: TTimer;

T3: TTimer;

t4: TTimer;

TAKIn: TTAKIn;

tmClose: TMenuItem;

tmNext: TMenuItem;

tmPlay: TMenuItem;

tmPrev: TMenuItem;

tmRandom: TMenuItem;

tmRepeat: TMenuItem;

tmStop: TMenuItem;

TrayIcon: TTrayIcon;

TrayMenu: TPopupMenu;

TTAIn: TTTAIn;

VorbisIn: TVorbisIn;

Vorbist: TVorbisIn;

WaveIn: TWaveIn;

Wavet: TWaveIn;

WMIn: TWMIn;

WMt: TWMIn;

WVIn: TWVIn;

procedure DataModuleCreate(Sender: TObject);

procedure DataModuleDestroy(Sender: TObject);

procedure DXAudioOutDone(Sender: TComponent);

procedure DXAudioOutProgress(Sender: TComponent);

procedure ShowHideClick(Sender: TObject);

procedure T1Timer(Sender: TObject);

procedure t2Timer(Sender: TObject);

procedure T3Timer(Sender: TObject);

procedure t4Timer(Sender: TObject);

procedure tmCloseClick(Sender: TObject);

procedure tmNextClick(Sender: TObject);

procedure tmPlayClick(Sender: TObject);

procedure tmPrevClick(Sender: TObject);

procedure tmRandomClick(Sender: TObject);

procedure tmRepeatClick(Sender: TObject);

procedure TrayIconDblClick(Sender: TObject);

procedure TrayMenuPopup(Sender: TObject);


private

fmStrings: array of string;

Mixer: aMixer.TAudioMixer;

plcoladd: Integer;

plspeedadd: Integer;

t_check_index: Integer;

function GetplAddCol: Integer;

function GetplAddSpeed: Integer;

procedure SetplAddCol(Value: Integer);

procedure SetplAddSpeed(Value: Integer);

public

new_search: Boolean;

scroll_b: Boolean;

search_index: Integer;

function fiTeest(index:integer): Boolean;

function FormatedTime(time:integer): string;

function mediaType(Send: string): TMediaType;

procedure scanfile(FileName:string);

procedure SetTrayInfo(Hint:string);

procedure setVolume;

procedure tagID3(Send: TAuFileIn;index:integer);

property plAddCol: Integer read GetplAddCol write SetplAddCol;

property plAddSpeed: Integer read GetplAddSpeed write SetplAddSpeed;

end;
const

// index статусов

img_state_none = -1;

img_state_play = 0;

img_state_pause = 1;

img_state_stop = 2;

img_state_next = 3;

img_state_prev = 4;

img_state_repeat = 5;

img_state_random = 6;

img_state_fileOpen = 7;

img_state_dirrOpen = 8;

img_state_plOpen = 9;

img_state_plSave = 10;

img_state_plClear = 11;

img_state_error = 12;

img_state_close = 13;

img_state_find = 14;
//указатели на строки в листе

vlPlstringsCount = 4 ;

vlPlFilePach = vlPLstringsCount - 1 ;

vlPlAlbum = 0 ;

vlPlArtist = 1 ;

vlPlTime = 2 ;


var

DM: TDM;
CommandEvent: THandle;
implementation

uses main, forms, Graphics, Finder

;
{$R *.dfm}
{

************************************* TDM **************************************

}

procedure TDM.DataModuleCreate(Sender: TObject);

var

PNG: TPngImage;

BMP: TBitmap;

s: string;

SR: TSearchRec;

begin

t_check_index:=0; search_index:=0;

setlength(fmStrings,0);

new_search:=false;

try

//грузим иконку программы. НЕТ ??? - ну тогда фиг вам

//в трее ведь нужно что-нить отображать

s:=ExtractFilePath(Application.ExeName)+'image\Icon.ico';

application.Icon.LoadFromFile(s);

TrayIcon.Icon.LoadFromFile(s);

except

application.Terminate;

halt;

end;
PNG := TPngImage.Create;

bmp := TBitmap.Create;

try
//Ищем статусные иконки и грузим в память

if FindFirst(ExtractFilePath(Application.ExeName) + 'image\state-action\*.png', faAnyFile, SR) = 0 then

begin

repeat

if SR.Attr <> faDirectory then

begin

png.LoadFromFile(ExtractFilePath(Application.ExeName)+'image\state-action\'+sr.Name);

bmp.Assign(png); // рожу танком и утверждаем что это BMP

imgPlay.Add(bmp,nil); // и ведь согласится ^_^

end;

until FindNext(SR) <> 0;

FindClose(SR);

end;

finally

PNG := nil;

bmp := nil;

PNG.Free;

bmp.Free;

end;

// подключаем системный микшер

Mixer:= aMixer.TAudioMixer.Create(nil);

if Mixer.MixerCount=0 then

begin // 0 микшеров - о_О шо эт за пылесос >_< ....

MessageDlg ('Не найдены звуковые устройства',mtError,[mbOK],0);

halt; //валим отсюда хлопцы >_<

end;
TrayIcon.Visible:=true;//рисуем в трее иконку

memFree; // высвобождаем лишнюю память
end;
procedure TDM.DataModuleDestroy(Sender: TObject);

begin

TrayIcon.Visible:=false;

mixer.free;

mixer:=nil;

imgPlay.Clear;

imgPlay.Free;

end;
procedure TDM.DXAudioOutDone(Sender: TComponent);

begin

face.plPlay.ImageIndex:=0;

t3.Enabled:=false;

dxaudioout.Stop(false);

with face do

begin

resetPlStatus(getPlayingIndex);

plPlay.ImageIndex:=0;

tb.Position:=0;

tb.Max:=0;

if getPlayingIndex<>play_list.Items.Count-1 then

plNextClick(face)

else

if plRepeat.down then

plNextClick(face)

else

tb.Enabled:=false;

end;

end;
procedure TDM.DXAudioOutProgress(Sender: TComponent);

var

t: Real;

begin

t:= (TAuFileIn(sBalance.Input).SampleRate*TAuFileIn(sBalance.Input).Channels

*(TAuFileIn(sBalance.Input).BitsPerSample shr 3));

scroll_b:=false;

t1.Enabled:=false;

face.TB.Position:=trunc(sBalance.Input.Position/t);

setVolume;

end;
function TDM.fiTeest(index:integer): Boolean;

begin

fiTeest:=false;

with face do

if ((play_list.Items.Count-1) >= index)and(play_list.Items.Item[index].SubItems.Strings[vlPlstringsCount]<>'') then

if strtoint(play_list.Items.Item[index].SubItems.Strings[vlPlstringsCount])=getPlayingID then

fiTeest:=true;

end;
function TDM.FormatedTime(time:integer): string;

var

sec, min: Integer;

Fmt: string;

begin

Sec := Time;

Min := Sec div 60;

Sec := Sec - Min*60;

if Sec < 10 then Fmt := '%d:0%d'

else Fmt := '%d:%d';

result:=Format(Fmt, [Min, Sec]);

end;
function TDM.GetplAddCol: Integer;

begin

result:=plcoladd;

end;
function TDM.GetplAddSpeed: Integer;

begin

result:=plspeedadd;

end;
function TDM.mediaType(Send: string): TMediaType;

begin

Send := ExtractFileExt(send);

Send := AnsiLowerCase(Send);

if Send = '.mp3' then begin result:=mp3; exit; end;

if Send = '.ogg' then begin result:=ogg; exit; end;

if Send = '.flac' then begin result:=flac; exit; end;

if Send = '.wav' then begin result:=wav; exit; end;

if Send = '.wma' then begin result:=wma; exit; end;

if Send = '.aac' then begin result:=aac; exit; end;

if Send = '.ape' then begin result:=ape; exit; end;

if Send = '.cda' then begin result:=cda; exit; end;
if Send = '.bml' then begin result:=bml; exit; end;

result:=mNull;

end;
procedure TDM.scanfile(FileName:string);

var

SR: TSearchRec;

begin

if (mediaType(FileName)<>mNull)AND(mediaType(FileName)<>bml) then

begin

setlength(fmStrings,length(fmStrings)+1);

fmStrings[length(fmStrings)-1]:=FileName;

end

else

if (mediaType(FileName)=bml)and(length(fmStrings)<=1) then face.readBML(FileName)

else

if FindFirst(FileName + '\*.*', faAnyFile, SR) = 0 then

begin

repeat

if (SR.Name<>'.')and(SR.Name<>'..') then

scanfile(FileName+'\'+SR.Name);

until FindNext(SR) <> 0;

FindClose(SR);

end;

t4.Enabled:=true;

end;
procedure TDM.SetplAddCol(Value: Integer);

begin

plcoladd:=value;

end;
procedure TDM.SetplAddSpeed(Value: Integer);

begin

plspeedadd:=value;

end;
procedure TDM.SetTrayInfo(Hint:string);

begin

TrayIcon.Hint:=hint;

end;
procedure TDM.setVolume;

var

tB: Boolean;

a, b, tc: Integer;

getMasterVolume, getWaveVolume: Integer;

begin

mixer.GetVolume(DXAudioOut.DeviceNumber,0,a,b,tc,tB,tB,tB); //получаем текущую громкость Wave канала

if a>=b then getWaveVolume:=a //выбираем который канал громче

else getWaveVolume:=b; //с ним и работает
mixer.GetVolume(DXAudioOut.DeviceNumber,-1,a,b,tc,tB,tB,tB); //получаем текущую громкость Master канала

if a>=b then getMasterVolume:=a //аналогично тому что выше

else getMasterVolume:=b;
with face do

tc:=round(0-(100-(tb2.Position*(ln(tb2.Position*2)/ln(10))))*((getMasterVolume/655.35+(getWaveVolume/655.36)/(ln(getMasterVolume/655.35)/ln(15)))/2));

DXAudioOut.Volume:=tc;

end;
procedure TDM.ShowHideClick(Sender: TObject);

begin

TrayIcon.OnDblClick(nil);

end;
procedure TDM.T1Timer(Sender: TObject);

var

t: Real;

begin

t1.Enabled:=false;

with dm do

with face do

t:=(tb.Position/(tb.Max/100)/100)*(TAuFileIn(sBalance.Input).TotalSamples);

TAuFileIn(sBalance.Input).Seek(round(t));

end;
procedure TDM.t2Timer(Sender: TObject);

var

FileName: string;

fi: TAuFileIn;

begin

with face do

if (t_check_index<>play_list.Items.Count)and(t_check_index


begin

if play_list.Items.Item[t_check_index].Checked=false then

begin

try

inc(t_check_index);

FileName := play_list.Items.Item[t_check_index-1].SubItems[vlPlFilePach];

FI := nil;
case mediaType(FileName) of

mNull : exit;

mp3 : FI := MP3t;

wav : FI := Wavet;

wma : FI := WMt;

ogg : FI := Vorbist;

flac : FI := FLACt;

ape : FI := MacT;
bml : readBML(FileName);

end;

if FI = nil then exit;
FI.FileName := FileName;
play_list.Items.Item[t_check_index-1].SubItems.Strings[vlPlTime]:=FormatedTime(FI.TotalTime);

tagID3(FI,t_check_index-1);

except

play_list.Items.Item[t_check_index-1].StateIndex:=img_state_error;

end;

play_list.Items.Item[t_check_index-1].Checked:=true;

end

else

begin

while (play_list.Items.Item[t_check_index].Checked=true)AND(t_check_index

inc(t_check_index);

end;

end

else

begin

t2.Enabled:=false;

t_check_index:=0;

memFree;

end;

end;
procedure TDM.T3Timer(Sender: TObject);

var

time: Cardinal;

t: Real;

begin

with face do

begin

t:= (TAuFileIn(sBalance.Input).SampleRate*TAuFileIn(sBalance.Input).Channels

*(TAuFileIn(sBalance.Input).BitsPerSample shr 3));

time:=trunc(sBalance.Input.Position/t);

LCD.Lines[0]:= FormatedTime(time)+'/'+

FormatedTime(TAuFileIn(sBalance.Input).TotalTime-time);

LCD.Refresh;

end;

end;
procedure TDM.t4Timer(Sender: TObject);

var

t: Byte;

i: Integer;

begin

t4.Interval:=plAddSpeed;

t:=0;
with face do

while (t<>0) do

begin

play_list.Items.Add.Caption:=(ExtractFileName(fmStrings[0]));

for i := 0 to vlPlstringsCount do

play_list.Items.Item[play_list.Items.Count-1].SubItems.Add('');

play_list.Items.Item[play_list.Items.Count-1].SubItems.Strings[vlPlFilePach]:=fmStrings[0];

play_list.Items.Item[play_list.Items.Count-1].Checked:=false;

inc(t);

i:=1;

while i<=length(fmStrings)-1 do

begin

fmStrings[i-1]:=fmStrings[i];

inc(i);

end;

setlength(fmStrings,length(fmStrings)-1);

end;

if length(fmStrings)=0 then T4.Enabled:=false;

t2.Enabled:=true;

end;
procedure TDM.tagID3(Send: TAuFileIn;index:integer);

var

Media1: TWMIn;

Media2: TVorbisin;

Media3: TFLACin;

Media4: TMacin;

mb: Boolean;

Artist, Album, Title: string;

begin

mb:=false;

Artist := '';Album := '';Title := '';

with face do

begin

try

case mediaType(send.FileName) of

wav: ;

aac: ;

cda: ;

mp3: mb:=true;

wma: mb:=true;

ogg: begin

Media2:= TVorbisin(send);

if Media2.Valid then

begin

Title := pchar(Media2.Comments.Title) ;

Artist := pchar(Media2.Comments.Artist);

Album := pchar(Media2.Comments.Album) ;

end;

end;

Flac: begin

Media3:= TFLACin(send);

if Media3.Valid then

begin

Title := pchar(Media3.VorbisComments.Title) ;

Artist := pchar(Media3.VorbisComments.Artist);

Album := pchar(Media3.VorbisComments.Album) ;

end;

end;

ape: begin

Media4:=TMACin(send);

if Media4.Valid then

begin

Title := pchar(Media4.APEv2Tags.Title) ;

Artist := pchar(Media4.APEv2Tags.Artist);

Album := pchar(Media4.APEv2Tags.Album) ;

end;

end;

end;
if mb then

begin

Media1:=TWMIn(Send);

if media1.Valid then

begin

Title :=pchar(Media1.Id3v2Tags.Title);

Artist :=pchar(Media1.Id3v2Tags.Artist);

Album :=pchar(Media1.Id3v2Tags.Album);

end;

end;

if Title='' then Title := ExtractFileName(play_list.Items.Item[index].SubItems.Strings[vlPlFilePach]);

play_list.Items.Item[index].Caption := Title ;

play_list.Items.Item[index].SubItems.Strings[vlPlArtist] := Artist ;

play_list.Items.Item[index].SubItems.Strings[vlPlAlbum] := Album ;

except

play_list.Items.Item[index].ImageIndex:=img_state_error;

end;

end;

end;



procedure TDM.tmCloseClick(Sender: TObject);

begin

face.appClose;

end;
procedure TDM.tmNextClick(Sender: TObject);

begin

face.plNext.Click;

end;
procedure TDM.tmPlayClick(Sender: TObject);

begin

face.plPlay.Down:=true;

face.playClick(nil);

end;
procedure TDM.tmPrevClick(Sender: TObject);

begin

face.plPrev.Click;

end;



procedure TDM.tmRandomClick(Sender: TObject);

begin

if face.plRandom.Down then

face.plRandom.Down:=false

else

face.plRandom.Down:=true;

end;
procedure TDM.tmRepeatClick(Sender: TObject);

begin

if face.plRepeat.Down then

face.plRepeat.Down:=false

else

face.plRepeat.Down:=true;

end;
procedure TDM.TrayIconDblClick(Sender: TObject);

begin

if face.Visible then

face.Visible:=false

else

begin

face.Visible:=true;

memFree;

end;
end;
procedure TDM.TrayMenuPopup(Sender: TObject);

begin

tmPlay.ImageIndex :=face.plPlay.ImageIndex;

tmNext.ImageIndex :=face.plNext.ImageIndex;

tmPrev.ImageIndex :=face.plPrev.ImageIndex;

tmStop.ImageIndex :=face.plStop.ImageIndex;

tmRepeat.ImageIndex :=face.plRepeat.ImageIndex;

tmRepeat.Checked :=face.plRepeat.Down;

tmRandom.ImageIndex :=face.plRandom.ImageIndex;

tmRandom.Checked :=face.plRandom.Down;

tmClose.ImageIndex :=img_state_close;

end;
end.

unit finder;
interface
uses

Classes, sysutils, Windows;
type

TFinder = class(TThread)

protected

procedure Execute; override;

end;
var

CommandEvent: THandle;
implementation

uses

controlls_comp, main;
{ TFinder }
{

*********************************** TFinder ************************************

}

procedure TFinder.Execute;

var

i, y: Integer;

begin

y:=0;

with main.face do

with dm do

while y < play_list.Items.Count do

begin

if (new_search)and(search_index > 0) then

begin

i:=0;

new_search:=false;

while i < SearchList.Items.Count do

begin

with play_list.Items.Item[i] do

if not ((pos(LowerCase(edSearch.Text),LowerCase(Caption))<>0)

or (pos(LowerCase(edSearch.Text),LowerCase(SubItems.Strings[vlPlAlbum]))<>0)

or (pos(LowerCase(edSearch.Text),LowerCase(SubItems.Strings[vlPlArtist]))<>0))

then

begin

SearchList.Items.Item[i].Delete;

dec(i);

end;

inc(i);

end;

end;

if (play_list.Items.Count > search_index)and(play_list.Items.Count > 0) then

begin

SearchProgress.Max:=play_list.Items.Count;

with play_list.Items.Item[search_index] do

if (pos(LowerCase(edSearch.Text),LowerCase(Caption))<>0)

or (pos(LowerCase(edSearch.Text),LowerCase(SubItems.Strings[vlPlAlbum]))<>0)

or (pos(LowerCase(edSearch.Text),LowerCase(SubItems.Strings[vlPlArtist]))<>0)

then

begin

SearchList.Items.Add.Caption:=play_list.Items.Item[search_index].Caption;

SearchList.Items.Item[SearchList.Items.Count-1].SubItems.add(SubItems.Strings[vlPlAlbum]);

SearchList.Items.Item[SearchList.Items.Count-1].SubItems.add(SubItems.Strings[vlPlArtist]);

SearchList.Items.Item[SearchList.Items.Count-1].SubItems.add(SubItems.Strings[vlPlTime]);

SearchList.Items.Item[SearchList.Items.Count-1].SubItems.add(inttostr(search_index));

end;

inc(search_index);

SearchProgress.Position:=search_index;

end

else

begin

search_index:=0;

SearchProgress.Visible:=false;

SearchProgress.Position:=0;

end;

inc(y);

end;

face.SearchProgress.Visible:=false;

face.finderdest;

end;
end.
unit EventWaitThread;
interface
uses

Windows, Classes, Messages;

const

WM_CommandArrived = WM_USER + 1;
type

TEventWaitThread = class(TThread)

protected

procedure Execute; override;

end;
var

CommandEvent: THandle;
implementation

uses main;
{

******************************* TEventWaitThread *******************************

}

procedure TEventWaitThread.Execute;

begin

while True do

begin

if WaitForSingleObject(CommandEvent, INFINITE) <> WAIT_OBJECT_0 then Exit;

PostMessage(face.Handle, WM_CommandArrived, 0, 0);

end;

end;
end
unit tech_unit;
interface

uses Windows, SysUtils, Classes;
function readStartParam:string;

procedure memFree;
implementation
function readStartParam;

var

i: byte;

begin

result:='';

for I := 1 to ParamCount do

if i = ParamCount then

result := result + ParamStr(i)

else

result := result + ParamStr(i)+ ' ';

end;
procedure memFree;

var

MainHandle: THandle;

begin

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

MainHandle := OpenProcess(PROCESS_ALL_ACCESS, false, GetCurrentProcessID);

SetProcessWorkingSetSize(MainHandle, DWORD(-1), DWORD(-1));

CloseHandle(MainHandle);

end;

end;
end.

unit regftyp;
interface

uses windows,registry,dialogs;
procedure registerfiletype(ft,key,desc,icon,prg:string);
implementation
procedure registerfiletype(ft,key,desc,icon,prg:string);

var myreg : treginifile;

ct : integer;

begin
// make a correct file-extension

ct := pos('.',ft);

while ct > 0 do begin

delete(ft,ct,1);

ct := pos('.',ft);

end;

if (ft = '') or (prg = '') then exit; //not a valid file-ext or ass. app

ft := '.'+ft;

try

myreg := treginifile.create('');

myreg.rootkey := hkey_classes_root; // where all file-types are described

if key = '' then key := copy(ft,2,maxint)+'_auto_file'; // if no key-name is given,

// create one

myreg.writestring(ft,'',key); // set a pointer to the description-key

myreg.writestring(key,'',desc); // write the description

if icon <> '' then

myreg.writestring(key+'\DefaultIcon','',icon); // write the def-icon if given

myreg.writestring(key+'\shell\open\command','',prg+' "%1"'); //association

finally

myreg.free;

end;

//showmessage('File-Type '+ft+' associated with'#13#10+prg+#13#10);


end;

end.

unit PathUtils;
interface
uses

SysUtils {must be before var PathDelim declaration};
function RelativePathToAbsolute(const ABasePath, APath: String): String;

function AbsolutePathToRelative(const ABasePath, APath: String): String;

function WideRelativePathToAbsolute(const ABasePath, APath: WideString): WideString;

function WideAbsolutePathToRelative(const ABasePath, APath: WideString): WideString;

function GetRoot(const APath: String): String;

function WideGetRoot(const APath: WideString): WideString;
var

PathDelim: Char;

CaseSensitive: Boolean;
implementation
type TStringArray = array of String;
procedure ResemblePath(const APath: String; var Parts: TStringArray); overload;

var

i, j, k: Integer;

S: String;

begin

j := 1;

k := 0;

Parts := nil;

for i := 1 to Length(APath) do

if APath[i] = PathDelim then

begin

S := Copy(APath, j, i-j);

if S <> '' then

begin

SetLength(Parts, k+1);

Parts[k] := S;

Inc(k);

end;

j := i+1;

end;

if j <= Length(APath) then

begin

SetLength(Parts, k+1);

Parts[k] := Copy(APath, j, MaxInt);

end;

end;
function RelativePathToAbsolute(const ABasePath, APath: String): String;

var

i, j, k: Integer;

TmpPath, S: String;

RootLevel: Integer;

Strs1: TStringArray;

begin

if (Length(APath) > 1) and ((APath[2] = DriveDelim) or // локальный диск

((APath[1] = PathDelim) and (APath[2] = PathDelim))) then // или сетевой путь

begin

Result := APath; // в таком случае путь не является относительным

Exit;

end;
RootLevel := Ord((Length(ABasePath) > 1) and ((ABasePath[2] = DriveDelim) // локальный диск

or ((ABasePath[1] = PathDelim) and (ABasePath[2] = PathDelim))))-1; // или сетевой путь

// Выше этого уровня в базовом дереве подняться нельзя: ([A..Z]:) или (\\server_name).

// Если RootLevel = 0, то это может быть каталог в корне юниксового дерева (\home),

// или что-то неопределенное (если нет первого слэша) - выше такого каталога можно

// подняться (перейти на соседний в корне)
Result := '';

ResemblePath(ABasePath, Strs1);
j := 1;

k := Length(Strs1)-1;

if APath[Length(APath)] = PathDelim

then TmpPath := APath

else TmpPath := APath + PathDelim;

for i := 1 to Length(TmpPath) do

if TmpPath[i] = PathDelim then

begin

S := Copy(TmpPath, j, i-j);

if (S <> '') and (S <> '.') then

begin

if S = '..' then

begin

Dec(k);

if k < RootLevel then k := RootLevel; // выше корня не прыгнешь :)

// Игнорируем лишние ссылки на родителя или тут нужно исключение?

end

else

begin

Inc(k);

if k = Length(Strs1) then

SetLength(Strs1, k+1);

Strs1[k] := S;

end;

end;

j := i+1;

end;

for i := 0 to k do

Result := Result + Strs1[i] + PathDelim;
// Немного уточняем рузультат

if (Length(APath) > 0) and (APath[Length(APath)] <> PathDelim) then

SetLength(Result, Length(Result)-1); // в конце нет слэша - м.б. имя файла

if (Length(ABasePath) > 0) and (ABasePath[1] = PathDelim) then

Result := PathDelim + Result; // слэш в начале - юниксовый путь

if (Length(ABasePath) > 1) and (ABasePath[2] = PathDelim) then

Result := PathDelim + Result; // два слэша в начале - сетевой путь

end;
function GetRoot(const APath: String): String;

var

i: Integer;

begin

Result := '';

if Length(APath) > 0 then

if APath[1] = PathDelim then

if (Length(APath) > 1) and (APath[2] = PathDelim) then

begin

for i := 3 to Length(APath) do // сетевой путь

if APath[i] = PathDelim then

begin

Result := Copy(APath, 3, i-3);

Break;

end;

if Result = '' then Result := Copy(APath, 3, MaxInt);

end

else Result := PathDelim // корень файловой системы

else if (Length(APath) > 1) and (APath[2] = DriveDelim) then

Result := APath[1] // локальный диск

else

Result := PathDelim;

end;
function SameString(const S1, S2: String): Boolean; overload;

begin

if CaseSensitive

then Result := CompareText(S1, S2) = 0

else Result := CompareStr(S1, S2) = 0;

end;
function AbsolutePathToRelative(const ABasePath, APath: String): String;

var

Strs1, Strs2: TStringArray;

i, j, k, l: Integer;

begin

if (Length(ABasePath) = 0) or (Length(APath) = 0) then

begin

Result := APath; // (*)

Exit;

end;
// пути на разных сетевых шарах или дисках

if not SameString(GetRoot(ABasePath), GetRoot(APath)) then

begin

Result := APath;

Exit;

end;
ResemblePath(ABasePath, Strs1);

ResemblePath(APath, Strs2);
Result := '';

k := Length(Strs1); l := 0;

for i := 0 to Length(Strs2)-1 do

if i < k then

begin

if not SameString(Strs2[i], Strs1[i]) then

begin

for j := i to k-1 do Result := Result + '..' + PathDelim;

Break;

end

else Inc(l);

end

else

begin

Result := '.' + PathDelim;

Break;

end;

// путь меньше или равен базовому

if l >= Length(Strs2) then

if l = k then Result := Result + '.' + PathDelim

else

for i := l to k-1 do Result := Result + '..' + PathDelim

else

for i := l to Length(Strs2)-1 do

Result := Result + Strs2[i] + PathDelim;

if (Length(APath) > 0) and (APath[Length(APath)] <> PathDelim) then

SetLength(Result, Length(Result)-1); // в конце нет слэша - м.б. имя файла

end;
//------------------------------------------------------------------------------

// Wide-версии
type TWideStringArray = array of WideString;
procedure ResemblePath(const APath: WideString; var Parts: TWideStringArray); overload;

var

i, j, k: Integer;

S: WideString;

PathDelimW: WideChar;

begin

j := 1;

k := 0;

Parts := nil;

PathDelimW := WideChar(PathDelim);

for i := 1 to Length(APath) do

if APath[i] = PathDelimW then

begin

S := Copy(APath, j, i-j);

if S <> '' then

begin

SetLength(Parts, k+1);

Parts[k] := S;

Inc(k);

end;

j := i+1;

end;

if j <= Length(APath) then

begin

SetLength(Parts, k+1);

Parts[k] := Copy(APath, j, MaxInt);

end;

end;
function WideRelativePathToAbsolute(const ABasePath, APath: WideString): WideString;

var

i, j, k: Integer;

TmpPath, S: WideString;

RootLevel: Integer;

Strs1: TWideStringArray;

DriveDelimW, PathDelimW: WideChar;

begin

DriveDelimW := WideChar(DriveDelim);

PathDelimW := WideChar(PathDelim);
if (Length(APath) > 1) and ((APath[2] = DriveDelimW) or // локальный диск

((APath[1] = PathDelimW) and (APath[2] = PathDelimW))) then // или сетевой путь

begin

Result := APath; // в таком случае путь не является относительным

Exit;

end;
RootLevel := Ord((Length(ABasePath) > 1) and ((ABasePath[2] = DriveDelimW) // локальный диск

or ((ABasePath[1] = PathDelimW) and (ABasePath[2] = PathDelimW))))-1; // или сетевой путь

// Выше этого уровня в базовом дереве подняться нельзя: ([A..Z]:) или (\\server_name).

// Если RootLevel = 0, то это может быть каталог в корне юниксового дерева (\home),

// или что-то неопределенное (если нет первого слэша) - выше такого каталога можно

// подняться (перейти на соседний в корне)
Result := '';

ResemblePath(ABasePath, Strs1);
j := 1;

k := Length(Strs1)-1;

if APath[Length(APath)] = PathDelimW

then TmpPath := APath

else TmpPath := APath + PathDelimW;

for i := 1 to Length(TmpPath) do

if TmpPath[i] = PathDelimW then

begin

S := Copy(TmpPath, j, i-j);

if (S <> '') and (S <> WideString('.')) then

begin

if S = WideString('..') then

begin

Dec(k);

if k < RootLevel then k := RootLevel; // выше корня не прыгнешь :)

// Игнорируем лишние ссылки на родителя или тут нужно исключение?

end

else

begin

Inc(k);

if k = Length(Strs1) then

SetLength(Strs1, k+1);

Strs1[k] := S;

end;

end;

j := i+1;

end;

for i := 0 to k do

Result := Result + Strs1[i] + PathDelimW;
// Немного уточняем рузультат

if (Length(APath) > 0) and (APath[Length(APath)] <> PathDelimW) then

SetLength(Result, Length(Result)-1); // в конце нет слэша - м.б. имя файла

if (Length(ABasePath) > 0) and (ABasePath[1] = PathDelimW) then

Result := PathDelimW + Result; // слэш в начале - юниксовый путь

if (Length(ABasePath) > 1) and (ABasePath[2] = PathDelimW) then

Result := PathDelimW + Result; // два слэша в начале - сетевой путь

end;
function WideGetRoot(const APath: WideString): WideString;

var

i: Integer;

PathDelimW: WideChar;

begin

PathDelimW := WideChar(PathDelim);

Result := '';

if Length(APath) > 0 then

if APath[1] = PathDelimW then

if (Length(APath) > 1) and (APath[2] = PathDelimW) then

begin

for i := 3 to Length(APath) do // сетевой путь

if APath[i] = PathDelimW then

begin

Result := Copy(APath, 3, i-3);

Break;

end;

if Result = '' then Result := Copy(APath, 3, MaxInt);

end

else Result := PathDelim // корень файловой системы

else if (Length(APath) > 1) and (APath[2] = WideChar(DriveDelim)) then

Result := APath[1] // локальный диск

else

Result := PathDelimW;

end;
function SameString(const S1, S2: WideString): Boolean; overload;

begin

if CaseSensitive

then Result := WideCompareText(S1, S2) = 0

else Result := WideCompareStr(S1, S2) = 0;

end;
function WideAbsolutePathToRelative(const ABasePath, APath: WideString): WideString;

var

Strs1, Strs2: TStringArray;

i, j, k, l: Integer;

PathDelimW: WideChar;

begin

PathDelimW := WideChar(PathDelim);
if (Length(ABasePath) = 0) or (Length(APath) = 0) then

begin

Result := APath;

Exit;

end;
// пути на разных сетевых шарах или дисках

if not SameString(WideGetRoot(ABasePath), WideGetRoot(APath)) then

begin

Result := APath;

Exit;

end;
ResemblePath(ABasePath, Strs1);

ResemblePath(APath, Strs2);
Result := '';

k := Length(Strs1); l := 0;

for i := 0 to Length(Strs2)-1 do

if i < k then

begin

if not SameString(Strs2[i], Strs1[i]) then

begin

for j := i to k-1 do Result := Result + '..' + PathDelimW;

Break;

end

else Inc(l);

end

else

begin

Result := WideString('.') + PathDelimW;

Break;

end;

// путь меньше или равен базовому

if l >= Length(Strs2) then

if l = k then Result := Result + '.' + PathDelimW

else

for i := l to k-1 do Result := Result + '..' + PathDelimW

else

for i := l to Length(Strs2)-1 do

Result := Result + Strs2[i] + PathDelimW;

if (Length(APath) > 0) and (APath[Length(APath)] <> PathDelimW) then

SetLength(Result, Length(Result)-1); // в конце нет слэша - м.б. имя файла

end;
initialization

PathDelim := SysUtils.PathDelim;

{$if defined(MSWINDOWS) or defined(WINDOWS)}

CaseSensitive := False;

{$else}

CaseSensitive := True;

{$ifend}

end.

Киров. 2009.
</0>
1   2   3   4

Похожие:

Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon «Разработка и стандартизация программных средств и информационных технологий»
Целью подготовки студентов по дисциплине является формирование целостной системы знаний о принципах, моделях и методах, используемых...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Техническое задание на разработку программы 2 Пояснительная записка
Данный курсовой проект был написан в рамках дисциплины «Технология разработки программных продуктов», на тему «Диспансеризация детей...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Руководство к выполнению курсовой работы по курсу «Современные средства...
Вся необходимая информация находится на сайте каф. Иус (в адресной строке Internet Explorer ius студентам учебные пособия субд и...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект по дисциплине «Физические процессы нефтегазового производства»
Тема проекта «Физические процессы при проведении гидравлического разрыва пласта для интенсификации добычи нефти»
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Программа курса «Формальные методы разработки программных систем»
Дисциплина «Формальные методы разработки программных систем» предназначена для изучения основных формальных методов спецификации...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект 3 Тема, которую нам предписано
Целью курсовой работы является закрепление теоретического материала, приобретение практических навыков проектирования Windows приложений...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект «К защите допущена»
Тема курсового проекта «Разработка и применение прикладных приложений на базе MapInfo»
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Содержание курсовой работы
Курсовая работа по дисциплине «Теория вероятностей и математическая статистика» имеет целью получение навыков самостоятельного анализа...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект по дисциплине "механизация процессов переработки продукции животноводства"
Кафедра технологического оборудования в животноводстве и перерабатывающих производств
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект по дисциплине «Эксплуатация автомобильных дорог»
В соответствии с заданием на курсовое проектирование, следует разработать проект ремонта и содержания участка автомобильной дороги....
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект по дисциплине: «Технологические методы управления качеством изделия»
Государственное образовательное учреждение высшего профессионального образования «Санкт-Петербургский государственный инженерно-экономический...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Пояснительная записка к курсовой работе по дисциплине «Эксплуатация...
Тема: «Организация технического обслуживания и ремонта оборудования железнодорожной электросвязи в региональном центре связи»
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект был создан с помощью среды разработки Visual Studio...
Разработка приложения для построения динамической изображения трехмерной модели объекта «Паровоз»
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовой проект по дисциплине «Технология производства и ремонта вагонов»
Объектом исследования является тележка грузового вагона модели 18-100, сборочная единица – тормозной башмак с подвеской, деталь –...
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Организационное поведение и национальный менталитет Вопросы для подготовки...
Варианты контрольных работ по дисциплине «Теория менеджмента: организационное поведение»
Курсовой проект по дисциплине “Теория Разработки Программных Продуктов” Тема: «Аудио проигрыватель» icon Курсовая работа по дисциплине «Производственная санитария и гигиена труда»
Целью курсовой работы является улучшение условий труда рабочего места вулканизаторщика путем проведения его санитарно гигиенического...

Руководство, инструкция по применению






При копировании материала укажите ссылку © 2024
контакты
rykovodstvo.ru
Поиск