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