ucustommodule.pas

想做个图片存取的程序

procedure ConvertJPGtoBMP(const sFileName, sToFileName: string);
var
  J: TJpegImage;
  I: TBitmap;
  S: string;
begin
  S := sFileName;
  I := TBitmap.Create;
  try
    J := TJpegImage.Create;
    try
      J.LoadFromFile(S);
      I.Assign(J);
    finally
      J.Free;
    end;
    S := ChangeFileExt(sToFileName, '.bmp');
    I.SaveToFile(S);
    Application.ProcessMessages;
  finally
    I.Free;
  end;
end;

//_____________________________________________________________________//

function Replacing(S, source, target: string): string;
var
  site,StrLen:integer;
begin
  {source在S中出现的位置}
  site := pos(source, S);
  if site = 0 then
  begin
    Result := S;
    exit;
  end;
  {source的长度}
  StrLen := length(source);
  {删除source字符串}
  Delete(S, site, StrLen);
  {插入target字符串到S中}
  Insert(target, S, site);
  {返回新串}
  Replacing := S;
end;

//_____________________________________________________________________//

function SmallTOBig(const small: real; const iPosition: integer): string;
var
  SmallMonth, BigMonth: string;
  wei1, qianwei1: string[2];
  qianwei, dianweizhi, qian: integer;
begin
  {------- 修改参数令值更精确 -------}
  qianwei := iPosition;{小数点后的位置，需要的话也可以改动-2值}
  Smallmonth := FormatFloat('0.00', small);{转换成货币形式，需要的话小数点后加多几个零}
  {---------------------------------}
  dianweizhi := pos('.', Smallmonth);{小数点的位置}
  for qian := length(Smallmonth) downto 1 do{循环小写货币的每一位，从小写的右边位置到左边}
  begin
    if qian <> dianweizhi then{如果读到的不是小数点就继续}
    begin
      case strtoint(copy(Smallmonth, qian, 1)) of{位置上的数转换成大写}
        1: wei1 := '壹'; 2: wei1 := '贰';
        3: wei1 := '叁'; 4: wei1 := '肆';
        5: wei1 := '伍'; 6: wei1 := '陆';
        7: wei1 := '柒'; 8: wei1 := '捌';
        9: wei1 := '玖'; 0: wei1 := '零';
      end;
      case qianwei of{判断大写位置，可以继续增大到real类型的最大值}
        -3: qianwei1 := '厘';
        -2: qianwei1 := '分';
        -1: qianwei1 := '角';
        0 : qianwei1 := '元';
        1 : qianwei1 := '拾';
        2 : qianwei1 := '佰';
        3 : qianwei1 := '千';
        4 : qianwei1 := '万';
        5 : qianwei1 := '拾';
        6 : qianwei1 := '佰';
        7 : qianwei1 := '千';
        8 : qianwei1 := '亿';
        9 : qianwei1 := '十';
        10: qianwei1 := '佰';
        11: qianwei1 := '千';
      end;
      inc(qianwei);
      BigMonth := wei1 + qianwei1 + BigMonth;{组合成大写金额}
    end;
  end;
  SmallTOBig := BigMonth;
end;

//_____________________________________________________________________//

procedure CreateShortCut(const sPath: string; sShortCutName: WideString);
var
  tmpObject: IUnknown;
  tmpSLink: IShellLink;
  tmpPFile: IPersistFile;
  PIDL: PItemIDList;
  StartupDirectory: array[0..MAX_PATH] of Char;
  StartupFilename: String;
  LinkFilename: WideString;
begin
  StartupFilename := sPath;
  tmpObject := CreateComObject(CLSID_ShellLink);//创建建立快捷方式的外壳扩展
  tmpSLink := tmpObject as IShellLink;//取得接口
  tmpPFile := tmpObject as IPersistFile;//用来储存*.lnk文件的接口
  tmpSLink.SetPath(pChar(StartupFilename));//设定notepad.exe所在路径
  tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename)));//设定工作目录
  SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL);//获得桌面的Itemidlist
  SHGetPathFromIDList(PIDL, StartupDirectory);//获得桌面路径
  sShortCutName := '\' + sShortCutName + '.lnk';
  LinkFilename := StartupDirectory + sShortCutName;
  tmpPFile.Save(pWChar(LinkFilename), FALSE);//保存*.lnk文件
end;

//_____________________________________________________________________//

procedure myAddDocument(const sPath: string);
begin
  SHAddToRecentDocs(SHARD_PATH, pChar(sPath));
end;

//_____________________________________________________________________//

function GetFileIcon(const Filename: string; SmallIcon: Boolean): HICON;
var
  info: TSHFILEINFO;
  Flag: Integer;
begin
  if SmallIcon then
    Flag := (SHGFI_SMALLICON or SHGFI_ICON)
  else
    Flag := (SHGFI_LARGEICON or SHGFI_ICON);
  SHGetFileInfo(Pchar(Filename), 0, info, Sizeof(info), Flag);
  Result := info.hIcon;
end;

//_____________________________________________________________________//

function GetCDROMNumber(): string;
var
  mp: TMediaPlayer;
  msp: TMCI_INFO_PARMS;
  MediaString: array[0..255] of char;
  ret: longint;
begin
  mp := TMediaPlayer.Create(nil);
  try
    mp.Visible := false;
    mp.Parent := Application.MainForm;
    mp.Shareable := true;
    mp.DeviceType := dtCDAudio;
    mp.FileName := 'D:';
    mp.Open;
    Application.ProcessMessages;
    FillChar(MediaString, sizeof(MediaString), #0);
    FillChar(msp, sizeof(msp), #0);
    msp.lpstrReturn := @MediaString;
    msp.dwRetSize := 255;
    ret := mciSendCommand(Mp.DeviceId, MCI_INFO, MCI_INFO_MEDIA_IDENTITY, longint(@msp));
    if Ret <> 0 then
    begin
      MciGetErrorString(ret, @MediaString, sizeof(MediaString));
      Result := StrPas(MediaString);
    end
    else
      Result := StrPas(MediaString);
  finally
    mp.Close;
    Application.ProcessMessages;
    mp.free;
  end;
end;

//_____________________________________________________________________//

procedure SetCDAutoRun(AAutoRun: Boolean);
const
  DoAutoRun : array[Boolean] of Integer = (0,1);
var
  Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    if Reg.KeyExists('System\CurrentControlSet\Services\Class\CDROM')
    then
    if
    Reg.OpenKey('System\CurrentControlSet\Services\Class\CDROM',FALSE) then
    //Reg.WriteBinaryData('AutoRun',DoAutoRun[AAutoRun],1);
  finally
    Reg.Free;
  end;
  if AAutoRun then
    Application.MessageBox('设置光盘自动启动，您的设置在Windows重新启动后将生效！','信息',MB_IconInformation + MB_OK)
  else
    Application.MessageBox('禁止光盘自动启动，您的设置在Windows重新启动后将生效！','信息',MB_IconInformation + MB_OK);
end;

//_____________________________________________________________________//

procedure OpenCDROM();
begin
  mciSendString('Set cdaudio door open wait', nil, 0, Application.Handle);
end;

//_____________________________________________________________________//

procedure CloseCDROM();
begin
  mciSendString('Set cdaudio door closed wait', nil, 0, Application.Handle);
end;

//_____________________________________________________________________//

function GetDiskFreeSpaceEx(lpDirectoryName: PAnsiChar; 
var lpFreeBytesAvailableToCaller: Integer;
var lpTotalNumberOfBytes: Integer;
var lpTotalNumberOfFreeBytes: Integer): bool;
stdcall;
external kernel32
name 'GetDiskFreeSpaceExA';


procedure GetDiskSizeAvail(TheDrive: PChar; var TotalBytes, TotalFree: double);
var
  AvailToCall: integer;
  TheSize: integer;
  FreeAvail: integer;
begin
  GetDiskFreeSpaceEx(TheDrive, AvailToCall, TheSize, FreeAvail);
  {$IFOPT Q+}
  {$DEFINE TURNOVERFLOWON}
  {$Q-}
  {$ENDIF}
  if TheSize >= 0 then
    TotalBytes := TheSize
  else if TheSize = -1 then
  begin
    TotalBytes := $7FFFFFFF;
    TotalBytes := TotalBytes * 2;
    TotalBytes := TotalBytes + 1;
  end
  else begin
    TotalBytes := $7FFFFFFF;
    TotalBytes := TotalBytes + abs($7FFFFFFF - TheSize);
  end;

  if AvailToCall >= 0 then
    TotalFree := AvailToCall
  else if AvailToCall = -1 then
  begin
    TotalFree := $7FFFFFFF;
    TotalFree := TotalFree * 2;
    TotalFree := TotalFree + 1;
  end
  else begin
    TotalFree := $7FFFFFFF;
    TotalFree := TotalFree + abs($7FFFFFFF - AvailToCall);
  end;
end;

//_____________________________________________________________________//

procedure GetDiskSize(const sDriver: string; var TotalBytes, TotalFree: double);
var
  sec1, byt1, cl1, cl2: LongWord;
begin
  GetDiskFreeSpace(PChar(sDriver), sec1, byt1, cl1, cl2);
  TotalFree := cl1 * sec1 * byt1;
  TotalBytes := cl2 * sec1 * byt1;
end;

//_____________________________________________________________________//

//**************************************************
//  Use the function to call system bar items
//**************************************************

function SystemBarCall(const iNumber:integer):Boolean;
begin
  try
    case iNumber of
      //Call dial-up network control
      1: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,3',SW_SHOWNORMAL);
      //Call area and date set up
      2: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,4',SW_SHOWNORMAL);
      //Open control panel
      3: WinExec('RunDLL.exe Shell32.DLL,Control_RunDLL',SW_SHOWNORMAL);
      //Call ODBC connection
      4: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL ODBCCP32.CPL',SW_SHOWNORMAL);
      //Call BDE administrator
      5: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL BdeAdmin.CPL',SW_SHOWNORMAL);
      //Call internet properties
      6: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,0', SW_SHOWNORMAL);
      //Call safety properties
      7: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,1', SW_SHOWNORMAL);
      //Call content properties
      8: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,2', SW_SHOWNORMAL);
      //Call program properties
      9: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,4', SW_SHOWNORMAL);
      //Call advanced properties
      10: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL InetCpl.cpl,,5', SW_SHOWNORMAL);
      //Call phone dial-up properties
      11: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Telephon.cpl', SW_SHOWNORMAL);
      //Call power management properties
      12: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL PowerCfg.cpl', SW_SHOWNORMAL);
      //Call modem properties
      13: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Modem.cpl', SW_SHOWNORMAL);
      //Call mutil-media properties
      14: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,0', SW_SHOWNORMAL);
      //Call video properties
      15: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,1', SW_SHOWNORMAL);
      //Call MIDI properties
      16: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,2', SW_SHOWNORMAL);
      //Call CD properties
      17: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,3', SW_SHOWNORMAL);
      //Call fixture properties
      18: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Mmsys.cpl,,4', SW_SHOWNORMAL);
      //Call keyboard properties
      19: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,1',SW_SHOWNORMAL);
      //Call sound properties
      20: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,2', SW_SHOWNORMAL);
      //Call display properties
      21: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,3', SW_SHOWNORMAL);
      //Call mouse properties
      22: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,4', SW_SHOWNORMAL);
      //Call general properties
      23: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL access.cpl,,5', SW_SHOWNORMAL);
      //Call password properties
      24: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Password.cpl', SW_SHOWNORMAL);
      //Call area setup properties
      25: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,0', SW_SHOWNORMAL);
      //Call numberic properties
      26: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,1', SW_SHOWNORMAL);
      //Call currency properties
      27: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,2', SW_SHOWNORMAL);
      //Call time properties
      28: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,3', SW_SHOWNORMAL);
      //Call date properties
      29: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Intl.cpl,,4', SW_SHOWNORMAL);
      //Call date and time properties
      30: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL TimeDate.cpl,,0', SW_SHOWNORMAL);
      //Call time zone properties
      31: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL TimeDate.cpl,,1', SW_SHOWNORMAL);
      //Call mouse properties,no button and pointer and move items
      32: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Main.cpl', SW_SHOWNORMAL);
      //Call add/remove properties
      33: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,1', SW_SHOWNORMAL);
      //Call windows setup properties
      34: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,2', SW_SHOWNORMAL);
      //Call boot disk properties
      35: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL AppWiz.cpl,,3', SW_SHOWNORMAL);
      //Call network setup properties,no configure and sign and accessing control items
      36: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL NetCpl.cpl', SW_SHOWNORMAL);
      //Call general of system setup properties
      37: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,0', SW_SHOWNORMAL);
      //Call fixture management of system setup properties
      38: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,1', SW_SHOWNORMAL);
      //Call hardware configure file of system setup properties
      39: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,2', SW_SHOWNORMAL);
      //Call performance of system setup properties
      40: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL SysDm.cpl,,3', SW_SHOWNORMAL);
      //Call background of show setup properties
      41: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,0', SW_SHOWNORMAL);
      //Call screen savers of show setup properties
      42: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,1', SW_SHOWNORMAL);
      //Call appearance of show setup properties
      43: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,2', SW_SHOWNORMAL);
      //Call setup of show setup properties
      44: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL desk.cpl,,3', SW_SHOWNORMAL);
      //Call general of game controls properties
      45: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Joy.cpl,,0', SW_SHOWNORMAL);
      //Call advanced of game controls properties
      46: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL Joy.cpl,,1', SW_SHOWNORMAL);
      //Call scanner and numeric camera properties
      47: WinExec('RunDLL32.exe Shell32.dll,Control_RunDLL StiCpl.cpl', SW_SHOWNORMAL);
    end;
    Result := true;
  except
    Application.MessageBox('调用系统控制面板选项功能失败，确认您的操作系统是否为Windows 98！', '系统调用', MB_OK + MB_DEFBUTTON1 + MB_ICONWARNING);
    Result := false;
  end;
end;

//_____________________________________________________________________//

function GetUserNameAPI(): AnsiString;//取得用户名称
var
  lpName: PAnsiChar;
  lpUserName: PAnsiChar;
  lpnLength: DWORD;
begin
  Result := '';
  lpName := '';
  lpnLength := 0;
  WNetGetUser(nil, nil, lpnLength);// 取得字串长度
  if lpnLength > 0 then
  begin
    GetMem(lpUserName, lpnLength);
    if WNetGetUser(lpName, lpUserName, lpnLength) = NO_ERROR then Result := lpUserName;
    FreeMem(lpUserName, lpnLength);
  end;
end;

//_____________________________________________________________________//

function GetWindowsProductID(): string;// 取得 Windows 产品序号
var
  reg: TRegistry;
begin
  Result := '';
  reg := TRegistry.Create;
  with reg do
  begin
    RootKey := HKEY_LOCAL_MACHINE;
    OpenKey('Software\Microsoft\Windows\CurrentVersion', False);
    Result := ReadString('ProductID');
  end;
  reg.Free;
end;

//_____________________________________________________________________//

procedure HideTaskbar(); //隐藏
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_HIDE);
End;

//_____________________________________________________________________//

procedure ShowTaskbar();
var
  wndHandle: THandle;
  wndClass: array[0..50] of Char;
begin
  StrPCopy(@wndClass[0], 'Shell_TrayWnd');
  wndHandle := FindWindow(@wndClass[0], nil);
  ShowWindow(wndHandle, SW_RESTORE);
end;

//_____________________________________________________________________//

procedure MakeTree(const iMode: integer; const objName: TObject);
var
  Sr: TSearchRec;
  Err: Integer;
  FilePath: string;
begin
  if (iMode <> 1) and (iMode <> 2) then
  begin
    Application.MessageBox('模式选定超出范围，请检查！', '参数错误', MB_OK + MB_DEFBUTTON1 + MB_ICONERROR);
    exit;
  end;
  Err := FindFirst('*.*', $37, Sr);   //$37为除Volumn ID Files外的所有文件
  //如果找到文件
  while (Err = 0) do
  begin
    if Sr.Name[1] <> '.' then
    begi