ucustommodule.pas

想做个图片存取的程序

{
  Function:
    Set media audio off
  Parameter:
    DeviceID: Media device ID
  Return value:
    None
  Example:
    //Play AVI file silently
    MediaPlayer1.FileName := 'speedis.avi';
    MediaPlayer1.Display := Panel1;
    MediaPlayer1.Open;
    MediaPlayer1.Play;
    SetMediaAudioOff(MediaPlayer1.DeviceId);
}
procedure SetMediaAudioOff(const DeviceID: word);

//-------------------------------//
//80. Set media audio on
//-------------------------------//
{
  Function:
    Set media audio on
  Parameter:
    DeviceID: Media device ID
  Return value:
    None
  Example:
    //Play AVI with sound
    MediaPlayer1.FileName := 'speedis.avi';
    MediaPlayer1.Display := Panel1;
    MediaPlayer1.Open;
    MediaPlayer1.Play;
    SetMediaAudioOn(MediaPlayer1.DeviceId);
}
procedure SetMediaAudioOn(const DeviceID: word);

//-------------------------------//
//81. Wait until execute files finished
//-------------------------------//
{
  Function:
    Wait until execute files finished
  Parameter:
    sExeName: Execute files name
  Return value:
    None
  Example:
    WaitExeFinish('NotePad.exe');
}
procedure WaitExeFinish(const sExeName: string);

//_____________________________________________________________________//
//                                                                     //
//                        Constant define                              //
//_____________________________________________________________________//

const
  csRoot: string = '我的电脑';

implementation

//_____________________________________________________________________//

//**************************************************
//Note:The files name no longer than 8 characters.
//     Position will rewrite with custom value.
//**************************************************

procedure CustomCursor(const objControl: TObject;const iPosition,
  iMode: integer;const sFilePath: string);
var
  tt: PChar;
  Size: integer;
  s: string;
begin
  tt := '';
  Size := 0;
  try
    Size := Length(sFilePath);
    GetMem(tt,size);
    s := sFilePath;
    StrpCopy(tt,s);
    Screen.Cursors[iPosition] := LoadCursorFromFile(tt);
    case iMode of
      1: (objControl as TForm).Cursor := iPosition; //Set form icon
      2: (objControl as TImage).Cursor := iPosition; //Set image icon
      3: (objControl as TPanel).Cursor := iPosition; //Set panel icon
    end;
  finally
    FreeMem(tt,Size);
  end;
end;

//_____________________________________________________________________//

function ReadRegKey(const iMode:integer; const sPath,
  sKeyName: string): string;
var
  rRegObject: TRegistry;
  sResult: string;
begin
  rRegObject := TRegistry.Create;
  try
    with rRegObject do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey(sPath, True) then
      begin
        case iMode of
          1: sResult := ReadString(sKeyName);
          2: sResult := IntToStr(ReadInteger(sKeyName));
          //3: sResult := ReadBinaryData(sKeyName, Buffer, BufSize);
        end;
        Result := sResult;
      end
      else
        Result := '';
      CloseKey;
    end;
  finally
    rRegObject.Free;
  end;
end;

//_____________________________________________________________________//

function WriteRegKey(const iMode:integer; const sPath, sKeyName,
  sKeyValue: string): Boolean;
var
  rRegObject: TRegistry;
  bData: byte;
begin
  rRegObject := TRegistry.Create;
  try
    with rRegObject do
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      if OpenKey(sPath, True) then
      begin
        case iMode of
          1: WriteString(sKeyName, sKeyValue);
          2: WriteInteger(sKeyName, StrToInt(sKeyValue));
          3: WriteBinaryData(sKeyName, bData, 1 );
        end;
        Result := true;
      end
      else
        Result := false;
      CloseKey;
    end;
  finally
    rRegObject.Free;
  end;
end;

//_____________________________________________________________________//

function GetExePath():string;
var
  ExePath:string;
  iPos,Index:integer;
begin
   ExePath:=Application.ExeName;
   iPos := 0;
   for Index := 1 to Length(ExePath) do
    if ExePath[Index] = '\' then
     iPos := Index;
   Result := copy(ExePath,1,iPos - 1);
end;

//_____________________________________________________________________//

function GetParameter(const FileName:string):WideString;
var
  f: TextFile;
  sPath, sValue: string;
begin
  sPath := GetExePath() + '\' + FileName;//Get exe program path from ini file
try
  AssignFile(f,sPath);
  Reset(f);
  while not eof(f) do
    Readln(f, sValue);
  if sValue <> '' then
    Result := sValue
  else begin
    Result := '';
    Application.MessageBox('错误提示','读取配置文件错误，可能是文件中不存在指定的参数！',MB_OK + MB_DEFBUTTON1 + MB_ICONERROR);
  end;
  CloseFile(f);
except
  Result := '';
  Application.MessageBox('错误提示','没有找到配置文件，请重新建立！',MB_OK + MB_DEFBUTTON1 + MB_ICONERROR);
end;
end;

//_____________________________________________________________________//

procedure RebootExpires();
begin
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 1, nil, 0);
end;

//_____________________________________________________________________//

procedure RebootRestore();
begin
  SystemParametersInfo(SPI_SCREENSAVERRUNNING, 0, nil, 0);
end;

//_____________________________________________________________________//

procedure CloseExpires();
var
  Handle: THandle;
begin
  Handle := 0;
  EnableMenuItem(GetSystemMenu(Handle, FALSE), SC_CLOSE, MF_BYCOMMAND or MF_GRAYED);
end;

//_____________________________________________________________________//

procedure CloseRestore();
var
  Handle: THandle;
begin
  Handle := 0;
  EnableMenuItem(GetSystemMenu(Handle, FALSE), SC_CLOSE, MF_BYCOMMAND or MF_ENABLED);
end;

//_____________________________________________________________________//

procedure HideDesktop();
var
  h, hChild: HWND;
begin
  h := FindWindow(nil, 'Program Manager');
  if h > 0 then
  begin
    h := GetWindow(h, GW_CHILD);
    ShowWindow(h, SW_HIDE);
    hChild := GetWindow(h, GW_CHILD);
    ShowWindow(hChild, SW_HIDE);
    ShowWindow(h, SW_SHOW);
  end;
end;

//_____________________________________________________________________//

procedure ShowDesktop();
var
  h, hChild: HWND;
begin
  h := FindWindow(nil, 'Program Manager');
  if h > 0 then
  begin
    h := GetWindow(h, GW_CHILD);
    ShowWindow(h, SW_SHOW);
    hChild := GetWindow(h, GW_CHILD);
    ShowWindow(hChild, SW_SHOW);
  end;
end;

//_____________________________________________________________________//

function ChangeWallPaper(const sPath: string): Boolean;
begin
  Result := SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, pChar(sPath),SPIF_UPDATEINIFILE);
end;

//_____________________________________________________________________//

function myGetWindowsDirectory(): string;
var
  pcWindowsDirectory: PChar;
  dwWDSize: DWORD;
begin
  dwWDSize := MAX_PATH + 1;
  Result := '';
  GetMem(pcWindowsDirectory, dwWDSize);
  try
    if Windows.GetWindowsDirectory(pcWindowsDirectory, dwWDSize) <> 0 then
      Result := pcWindowsDirectory;
  finally
    FreeMem( pcWindowsDirectory );
  end;
end;

//_____________________________________________________________________//

function myGetSystemDirectory(): string;
var
  pcSystemDirectory: PChar;
  dwSDSize: DWORD;
begin
  dwSDSize := MAX_PATH + 1;
  Result := '';
  GetMem(pcSystemDirectory, dwSDSize);
  try
    if Windows.GetSystemDirectory(pcSystemDirectory, dwSDSize) <> 0 then
      Result := pcSystemDirectory;
  finally
    FreeMem(pcSystemDirectory);
  end;
end;

//_____________________________________________________________________//

function myGetTempPath(): string;
var
  nBufferLength: DWORD;
  lpBuffer: PChar;
begin
  nBufferLength := MAX_PATH + 1;
  GetMem(lpBuffer, nBufferLength);
  try
    if GetTempPath(nBufferLength, lpBuffer) <> 0 then
      Result := StrPas(lpBuffer)
    else
      Result := '';
  finally
     FreeMem(lpBuffer);
  end;
end;

//_____________________________________________________________________//

function myGetLogicalDrives(): string;
var
  drives: set of 0..25;
  drive: integer;
begin
  Result := '';
  DWORD( drives ) := Windows.GetLogicalDrives;
  for drive := 0 to 25 do
    if drive in drives then
      Result := Result + Chr(drive + Ord('A'));
end;

//_____________________________________________________________________//

function myGetUserName(): string;
var
  pcUser: PChar;
  dwUSize: DWORD;
begin
  dwUSize := 21; //用户名长度不大于20个字符
  Result := '';
  GetMem(pcUser, dwUSize);
  try
    if Windows.GetUserName(pcUser, dwUSize) then
      Result := pcUser;
  finally
    FreeMem(pcUser);
  end;
end;

//_____________________________________________________________________//

function myGetComputerName(): string;
var
  pcComputer: PChar;
  dwCSize: DWORD;
begin
  dwCSize := MAX_COMPUTERNAME_LENGTH + 1;
  Result := '';
  GetMem(pcComputer, dwCSize);
  try
    if Windows.GetComputerName(pcComputer, dwCSize) then
      Result := pcComputer;
  finally
    FreeMem(pcComputer);
  end;
end;

//_____________________________________________________________________//

function mySelectDirectory(const sDescription, sPath: string): string;
var
  sReturnPath: string;
begin
  if SelectDirectory(sDescription, sPath, sReturnPath) then
    Result := sReturnPath
  else
    Result := '';
end;

//_____________________________________________________________________//

procedure myClearDocument();
begin
  SHAddtoRecentDocs(SHARD_PATH, nil);
end;

//_____________________________________________________________________//

procedure SystemAbout(const sTitle, sContent: string);
begin
  ShellAbout(Application.Handle, PChar(sTitle), PChar(sContent), Application.Icon.Handle);
end;

//_____________________________________________________________________//

//如果取消取返回为空，否则返回选中的路径
function SelectDir(const iMode: integer; const sInfo: string): string;
var
  Info: TBrowseInfo;
  IDList: pItemIDList;
  Buffer: PChar;
begin
  Result:='';
  Buffer := StrAlloc(MAX_PATH);
  with Info do
  begin
    hwndOwner := application.mainform.Handle;  //目录对话框所属的窗口句柄
    pidlRoot := nil;                           //起始位置，缺省为我的电脑
    pszDisplayName := Buffer;                  //用于存放选择目录的指针
    lpszTitle := PChar(sInfo);                 //对话框提示信息
    //选择参数，此处表示显示目录和文件，如果只显示目录则将后一个去掉即可
    if iMode = 1 then
      ulFlags := BIF_RETURNONLYFSDIRS or BIF_BROWSEINCLUDEFILES
    else
      ulFlags := BIF_RETURNONLYFSDIRS;
    lpfn := nil;                               //指定回调函数指针
    lParam := 0;                               //传递给回调函数参数
    IDList := SHBrowseForFolder(Info);         //读取目录信息
  end;
  if IDList <> nil then
  begin
      SHGetPathFromIDList(IDList, Buffer);     //将目录信息转化为路径字符串
      Result := strpas(Buffer);
  end;
  StrDispose(buffer);
end;

//_____________________________________________________________________//

procedure HideFormOnTask();
begin
  SetWindowLong(Application.Handle,GWL_EXSTYLE,WS_EX_TOOLWINDOW);
end;

//_____________________________________________________________________//

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

//_____________________________________________________________________//