开源了

Question

unit MainN;interface
  uses Windows, DSPack, Directshow9, StrUtils, SysUtils,Graphics, Classes, Controls, Forms, Menus, MMSystem, ComCtrls, ADODB, shlobj;  function GetRst(lstrSql:string):TadoDataSet;
  function SetLastsName(lstr:string):string;
  function GetBilInfo(lindex:integer):boolean;
  function GetLastFiles(a:string;c:string):string;
  function SetMenuInfos(lstr:string):string;
  function SetDrivers(lstr:string):string;
  function GetNullchar(lindex:integer):string;
  procedure SetDriverInfo;
  procedure GetVoicVolue;
  procedure SetVoicVolue;
  procedure SetsysIniInfo;
  procedure SetSysIniInfo1;  
  procedure SetMoveType(ltype:integer);
  procedure systemchked(lstrSql:string);
  procedure SetDirFile;
  procedure SetParamInfo;
  procedure SetiniZfile;
  procedure SetiniFfile;
  Procedure PlayFile(lName:string);
  procedure SetFListInfo;
  procedure Setpostion(lIndex:int64);
  procedure SetShowRect;
  Procedure SetStatusInfo(lstr:string);
  Procedure SetDirSet;
  Procedure SetSizType(linted:integer);
  Procedure SetPrcType(linted:integer);
  procedure SetMenuLists;
  procedure SetMenuInfo(ltype:integer;lstr:string);var
  HMovewidth:integer;
  HMoveHeight:integer;
  HstusHeight:integer;
  HMoveType:integer;
  HProCheck:boolean;
  HVoic:boolean;
  cn:TADOConnection;
  rs:TadoDataSet;
  VolumeType:integer;
  HSizType:integer;
  HPrcType:double;
  HWinFull:boolean;
  HOpenfs:string;
  HOpenStus:int64;
  strparam:array [1..2] of string;
  OpenFiles:string;
  Pi:integer;
  ri:array [1..7] of trect;
  p1:integer;
  r1:array [1..5] of trect;
  PStoped:string;
  IsMusc:boolean;
  Plength:int64;
  Pposed:int64;
  Prate:double;
  IsExit:integer;
  IsSizd:boolean;
  IsMint:boolean;
  rt:trect;
  SystemPath:string;
  PicLujin:string;
  bzt:tbitmap;
  SaveF:string;implementationuses MainF;function GetLastFiles(a:string;c:string):string;
var
  s,f:textfile;
  b:string;
begin
  assignfile(s,a);
  assignfile(f,SaveF);
  reset(s);
  rewrite(f);
  repeat
  readln(s,b);
  b:=trimleft(b);
  if (c='.asx') and (lowercase(leftbstr(b,9))='<ref href') or (c='.wpl') and (lowercase(leftbstr(b,9))='<media sr') then
  begin
  delete(b,1,pos('"',b));
  writeln(f,leftbstr(b,pos('"',b)-1));
  end;
  if (c='.pls') and (lowercase(leftbstr(b,4))='file') then
  begin
  delete(b,1,pos('=',b));
  writeln(f,b);
  end;
  until eof(s);
  closefile(s);
  closefile(f);
  GetLastFiles:=SaveF;
end;Procedure SetPrcType(linted:integer);
begin
  with maininfo do begin
  VPind.Items[linted].Checked:=true;
  case linted of
  0:HPrcType:=0.5;
  1:HPrcType:=1;
  2:HPrcType:=2;
  end;
  IsSizd:=true;
  SetShowRect;
  end;
end;Procedure SetSizType(linted:integer);
begin
  with maininfo do
  begin
  VPrev.Items[HSizType].Checked:=false;
  VPrev1.Items[HSizType].Checked:=false;
  VPrev.Items[linted].Checked:=true;
  VPrev1.Items[linted].Checked:=true;
  HSizType:=linted;
  IsSizd:=true;
  SetShowRect;
  end;
end;Procedure SetStatusInfo(lstr:string);
begin
  with maininfo.FilterGraph1 do
  if Prate<>rate then rate:=prate;
  if IsMusc=false then
  lstr:=lstr+GetNullchar(15)+inttostr(HMovewidth)+' x '+inttostr(HMoveheight);
  if Prate<>1 then
  lstr:=lstr+GetNullchar(5)+'x'+floattostr(prate);
  if HWinFull then
  lstr:=lstr+GetNullchar(3)+extractfilename(OpenFiles);
  maininfo.Titles.Caption:=lstr;
end;procedure Setpostion(lIndex:int64);
var
  c:IMediaSeeking;
  a,b:int64;
begin
  maininfo.FilterGraph1.QueryInterface(IMediaSeeking,c);
  a:=lIndex*lLens;
  b:=Plength*lLens;
  c.SetPositions(a,AM_SEEKING_AbsolutePositioning,b,AM_SEEKING_AbsolutePositioning);
end;function SetLastsName(lstr:string):string;
var
  i:integer;
  a:string;
begin
  a:=lstr;
  i:=pos('/',a);
  if lowercase(leftbstr(a,7))='http://' then
  repeat
  delete(a,1,i);
  i:=pos('/',a);
  until i=0;
  SetLastsName:=extractfilename(a);
end;procedure SetFListInfo;
var
  a:int64;
  b:IBasicVideo;
  c:IMediaSeeking;
begin
  maininfo.FilterGraph1.QueryInterface(IBasicVideo,b);
  HMovewidth:=0;
  HMoveheight:=0;
  b.get_VideoWidth(HMovewidth);
  b.get_VideoHeight(HMoveheight);
  IsMusc:=false;
  if (HMovewidth=0) or (HMoveheight=0) then IsMusc:=true;
  maininfo.FilterGraph1.QueryInterface(IMediaSeeking,c);
  c.GetDuration(a);
  Plength:=a div llens;
  PStoped:=format('%d:%2.2d:%2.2d',[Plength div 3600000,(Plength mod 3600000) div 60000,((Plength mod 3600000) mod 60000) div 1000]);
end;Procedure PlayFile(lName:string);
begin
  if (fileexists(lName)=false) and (lowercase(leftbstr(lName,7))<>'http://') and (lowercase(leftbstr(lName,6))<>'ftp://') then exit;
  OpenFiles:=lName;
  with maininfo do
  begin
  caption:=WinTitle+' - '+SetLastsName(lName);
  FilterGraph1.Active:=false;
  FilterGraph1.Active:=true;
  FilterGraph1.RenderFile(OpenFiles);
  SetFListInfo;
  IsSizd:=true;
  SetShowRect;
  FilterGraph1.Play;
  if HOpenstus<>-1 then Setpostion(HOpenstus);
  timer1.Enabled:=true;
  SetMenuLists;
  tlbplay.Click;
  treeview1.Items[pindex].Selected:=true;
  end;
end;procedure SetShowRect;
var
  b:IBasicVideo;
  a:boolean;
begin
  if (OpenFiles='') or (IsExit=0) then exit;
  a:=IsSizd;
  with maininfo do
  begin
  if (HSizType=1) or HWinFull then
  rt:=rect(0,0,panel5.Width,panel5.Height)
  else
  begin
  rt.Right:=HMovewidth*trunc(2*HPrcType) div 2;
  if a then
  if rt.Right>panel5.Width then
  width:=width+rt.Right-panel5.Width;
  if rt.Right>panel5.Width then
  rt.Right:=panel5.Width;
  case HSizType of
  0:rt.Bottom:=HMoveheight*trunc(2*HPrcType) div 2;
  2:rt.Bottom:=rt.Right*3 div 4;
  3:rt.Bottom:=rt.Right*4 div 5;
  4:rt.Bottom:=rt.Right*9 div 16;
  end;
  if a then
  if rt.Bottom>panel5.Height then
  height:=height+rt.Bottom-panel5.Height;
  if rt.Bottom>panel5.Height then
  rt.Bottom:=panel5.Height;
  rt.Left:=(panel5.Width-rt.Right) div 2;
  rt.Top:=(panel5.Height-rt.Bottom) div 2;
  end;
  FilterGraph1.QueryInterface(IBasicVideo,b);
  b.SetDestinationPosition(rt.Left,rt.Top,rt.Right,rt.Bottom);
  end;
end;procedure SetParamInfo;
begin
  if strparam[1]<>'Players' then exit;
  systemchked('update 2 set [openname]="'+strparam[2]+'",[Openstatus]=0');
  systemchked('delete from 0');
  systemchked('insert into 0([id],[name]) values(1,"'+strparam[2]+'")');
end;Procedure SetDirSet;
var  
  b:tbrowseinfo;  
  d:array[0..260] of char;  
  i:pitemidlist;  
  a:string;
begin  
  b.hwndowner:=maininfo.handle;
  b.pidlroot:=nil;  
  b.pszdisplayname:=nil;  
  b.lpsztitle:='请选择一个路径:';
  b.ulflags:=0;  
  b.lpfn:=nil;  
  b.lparam:=0;  
  b.iimage:=0;  
  i:=shbrowseforfolder(b);
  if i=nil then exit;
  shgetpathfromidlist(i,@d);
  a:=string(d);
  if OpenFiles<>'' then maininfo.Quit.Click;
  maininfo.TreeView1.Items.Clear;
  systemchked('delete from 0');
  chdir(a);
  SetDirFile;
end;

Answer 1

procedure SetDirFile;
var
  r:tsearchrec;
  e:integer;
  a:string;
  n:ttreenode;
begin
  e:=findfirst('*.*',$37,r);
  if e<>0 then exit;
  repeat
  if (r.name[1] <>'.') then
  begin
  if (r.attr and fadirectory)=0 then
  begin
  a:=extractfileext(r.Name);
  with maininfo.TreeView1 do
  if pos(lowercase(a+';'),'.mp3;.dat;')>0 then
  begin
  a:=expandfilename(r.name);
  new(PLists);
  plists.ID:=items.Count+1;
  plists.Name:=a;
  n:=items.AddObject(nil,extractfilename(a),plists);
  n.SelectedIndex:=1;
  systemchked('insert into 0([id],[name]) values('+inttostr(items.Count)+',"'+a+'")');
  end;
  end;
  if (r.attr and fadirectory)=16 then
  begin
  chdir(r.name);
  SetDirFile;
  chdir('..');
  end;
  end;
  e:=findnext(r);
  until e<>0;
end;function GetNullchar(lindex:integer):string;
var
  a:string;
begin
  a:='';
  repeat
  a:=a+chr(32);
  lindex:=lindex-1;
  until lindex=0;
  GetNullchar:=a;
end;function GetRst(lstrSql:string):TadoDataSet;
var
  rs1:TadoDataSet;
begin
  rs1:=TadoDataSet.Create(nil);
  rs1.Connection:=cn;
  rs1.CursorType:=ctDynamic;
  rs1.LockType:=ltBatchOptimistic;
  rs1.CommandText:=lstrSql;
  rs1.open;
  GetRst:=rs1;
end;procedure SetSysIniInfo1;  
begin  
  cn:=TADOConnection.Create(nil);
  cn.CursorLocation:=clUseClient;
  cn.ConnectionString:='Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source='+extractfilePath(application.ExeName)+'List\DateBase.mdb';  
  cn.Open;
end;procedure GetVoicVolue;
var   
  v:longint;
begin  
  waveOutGetVolume(0,@v);  
  case VolumeType of
  0:if hi(v)>hi(v shr 16) then
  v:=hi(v)
  else
  v:=hi(v shr 16);
  1:v:=hi(v);
  2:v:=hi(v shr 16);
  end;
  maininfo.LVOut.Items[VolumeType].Checked:=true;
  maininfo.LVOut1.Items[VolumeType].Checked:=true;
  maininfo.imgvoic.left:=52+(100*v) div 255;
end;procedure SetVoicVolue;
var  
  v,t:longint;  
begin  
  with maininfo do
  t:=(imgvoic.left-52)*255 div Voic.Width;
  waveoutgetvolume(0,@v);
  case volumetype of
  -1:v:=0;
  0:v:=(t shl 8)or(t shl 24);
  1:v:=v and $ffff0000 or (t shl 8);
  2:v:=v and $0000ffff or (t shl 24);
  end;
  waveOutSetVolume(0,v);  
end;  procedure systemchked(lstrSql:string);
begin
  cn.execute(lstrSql);
end;function GetBilInfo(lindex:integer):boolean;
begin
  GetBilInfo:=strtobool(inttostr(lindex));
end;procedure SetMoveType(ltype:integer);
begin
  with MainInfo do
  begin
  Atype.Items[HMoveType].Checked:=false;
  Atype.Items[ltype].Checked:=true;
  popupmenu3.Items[HMoveType].Checked:=false;
  popupmenu3.Items[ltype].Checked:=true;
  HMoveType:=ltype;
  end;
end;procedure SetMenuInfo(ltype:integer;lstr:string);
var
  m:tmenuitem;
  ml:tmenuitem;
  l:integer;
begin
  m:=tmenuitem.Create(nil);
  m.Caption:=SetMenuInfos(lstr);
  if ltype=0 then
  ml:=maininfo.OpenD
  else
  ml:=maininfo.His;
  l:=ml.Count;
  if ltype=-1 then l:=4;
  if ltype=0 then
  m.OnClick:=maininfo.DVDClick
  else
  m.OnClick:=maininfo.mainClick;
  ml.Insert(l,m);
  maininfo.xp.ActivateMenuItem(m,false);
end;procedure SetsysIniInfo;
begin
  rs:=Getrst('select * from 2');
  maininfo.ExitClr.Checked:=rs.FieldValues['openclr'];
  HOpenstus:=rs.FieldValues['openstus'];
  HOpenfs:=rs.FieldValues['openfs'];
  plist[1]:='.mlst';
  plist[2]:='.m3u';
  plist[3]:='.wax';
  plist[4]:='.asx';
  plist[5]:='.wpl';
  plist[6]:='.pls';
  IsMint:=false;
  HWinFull:=false;
  bzt:=tbitmap.Create;
  IsSizd:=false;
  Prate:=1;
  VolumeType:=0;
  HVoic:=true;
  HstusHeight:=15;
  HMoveType:=0;
  IsExit:=-1;
  HProCheck:=true;
  VolumeType:=0;
  HSizType:=0;
  HPrcType:=1;
  SystemPath:=extractfilepath(application.ExeName);
  PicLujin:=SystemPath+'PicSave\';
  SaveF:=SystemPath+'Bmp\SaveFile.txt';
  GetVoicVolue;
  SetParamInfo;
  SetDriverInfo;
  SetiniFfile;
  SetiniZfile;
  HOpenstus:=-1;
  HOpenfs:='';
end;function SetMenuInfos(lstr:string):string;
var  
  a:string;
begin  
  a:=extractfileName(lstr);
  with maininfo.Canvas do
  if textwidth(lstr)>300 then
  if textwidth(leftBstr(lstr,3)+'...\'+a)>300 then
  lstr:=leftBstr(lstr,3)+'...\'+RightbStr(a,(300-textwidth(leftbstr(lstr,3)+'...\')) div 6)
  else
  lstr:=leftbstr(lstr,(300-textwidth('...\'+a)) div 6)+'...\'+a;  
  SetMenuInfos:=lstr;
end;  function SetDrivers(lstr:string):string;
var  
  VolN:array[0..255] of Char;  
  n,l,f:Longword;  
  s:array[0..255] of Char;
begin
  GetVolumeInformation(PChar(lstr),VolN,255,@n,l,f,s,255);  
  SetDrivers:=VolN;  
end;  procedure SetDriverInfo;
var  
  i:Integer;
  a:string;
begin  
  i:=64;
  repeat
  i:=i+1;
  a:=chr(i)+':\';
  with maininfo do
  if GetDriveType(pchar(a))=drive_cdrom then
  if DVD.Caption='dvd' then
  dvd.Caption:=SetMenuInfos(a+SetDrivers(a))
  else
  SetMenuInfo(0,a+SetDrivers(a));
  until i=90;
end;procedure SetiniZfile;
var
  i:integer;
  n:ttreenode;
  rs1:TadoDataSet;
begin
  rs1:=Getrst('select * from 0');
  with maininfo.TreeView1 do
  for i:=1 to rs1.RecordCount do
  begin
  new(PLists);
  plists.ID:=rs1.FieldValues['id'];
  plists.Name:=rs1.FieldValues['name'];
  n:=items.AddObject(nil,extractfilename(plists.Name),plists);
  n.SelectedIndex:=1;
  if plists.Name=HOpenfs then playfile(HOpenfs);
  rs1.Next;
  end;
  rs1.Free;
end;procedure SetiniFfile;
var
  i:integer;
begin
  rs:=Getrst('select * from 1 order by id desc');
  for i:=1 to rs.RecordCount do
  begin
  SetMenuInfo(-2,rs.FieldValues['name']);
  rs.Next;
  end;
end;procedure SetMenuLists;
var
  i:integer;
begin
  if Getrst('select * from 1 where [name]="'+OpenFiles+'"').Eof=false then
  begin
  maininfo.his.Delete(3+Getrst('select * from 1 where id>=(select id from 1 where [name]="'+OpenFiles+'")').RecordCount);
  systemchked('delete from 1 where [name]="'+OpenFiles+'"');
  end;
  if Getrst('select * from 1').RecordCount=0 then
  i:=1
  else
  i:=Getrst('select max(id) as id from 1').FieldValues['id']+1;
  systemchked('insert into 1([id],[name]) values('+inttostr(i)+',"'+OpenFiles+'")');
  SetMenuInfo(-1,OpenFiles);
end;end.