Delphi控件源码

开发平台：
C++ Builder

ucopy.pas：源码内容
							unit ucopy;
interface
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Gauges;
  type EMFheader = record
         Signature: Integer;
         EMFsize: Integer;
       end;
  const EMFheaderSignature = $0C;
  type TForm1 = class(TForm)
      Label1: TLabel;
      Label2: TLabel;
      Gauge: TGauge;
  procedure FormActivate(Sender: TObject);
  procedure FormDestroy(Sender: TObject);
  private
    { Private-Deklarationen }
    nThreadsRunning : Integer;  // not used
    nFileCounter : Integer;     // index for filename
    StringList : TStrings;
    strTempDir : string;        // the <temp> / source directory
  public
    { Public-Deklarationen }
  end;
var
  Form1: TForm1;
  strOSVer : string;     // OS version
const
  PMON_KEY = 'SYSTEMCurrentControlSetControlPrintEnvironmentsWindows NT x86Print Processors';
implementation
Uses
  WinReg;
{$R *.DFM}
type
    TWindowsVersion = (wvUnknown,
                     wvWin95, wvWin95OSR2, wvWin98, wvWin98SE, wvWinME, wvWinNT3, wvWinNT4, wvWin2000, wvWinXP);
//=================================================================================================================
// Win32Platform        1           1           1        1         1        2         2          2           2
// Win32MajorVersion    4           4           4        4         4        3         4          5           5
// Win32MinorVersion    0           0           10       10        90       ?         0          0           1
// Win32BuildNumber     ?        67109975    67766222  67766446  73010104   ?        1381       2195         ?
// Win32CSDVersion      ?          'B'          ''       A         SP       SP        SP         ?           ?
//
// this nice function taken from http://www.delphi-fundgrube.de/faq12.htm (reinhardt@pics-software.de)
//
function GetWindowsVersion(var VerString:string): TWindowsVersion;
var
  osInfo : tosVersionInfo;
begin
  Result := wvUnknown;
  osInfo.dwOSVersionInfoSize:= Sizeof( osInfo );
  GetVersionEx( osInfo );
  with osInfo do begin
    VerString:='Version ' + IntToStr( osInfo.dwMajorVersion ) +
               '.' + IntToStr( osInfo.dwMinorVersion ) + ', Build ';
    case dwPlatformId of
      VER_PLATFORM_WIN32_WINDOWS : begin
        case dwMinorVersion of
          0 : if Trim(szCSDVersion[1]) = 'B' then
                Result:= wvWin95OSR2
              else
                Result:= wvWin95;
         10 : if Trim(szCSDVersion[1]) = 'A' then
                Result:= wvWin98SE
              else
                Result:= wvWin98;
         90 : if (dwBuildNumber = 73010104) then
                Result:= wvWinME;
        end;
        VerString:=VerString + IntToStr(LoWord( osInfo.dwBuildNumber ));
      end;
      VER_PLATFORM_WIN32_NT : begin
        case dwMajorVersion of
          3 : Result:= wvWinNT3;
          4 : Result:= wvWinNT4;
          5 : case dwMinorVersion of
                0 : Result:= wvWin2000;
                1 : Result:= wvWinXP;
              end;
        end;
        VerString:=VerString + IntToStr(osInfo.dwBuildNumber );
      end;
    end;
  end;
end;
//
// this nice function taken from http://www.delphi-fundgrube.de/faq12.htm (reinhardt@pics-software.de)
//
function GetOSName : string;
var
  osVerInfo : TOSVersionInfo;
  majorVer,
  minorVer  : Integer;
begin
  result := 'Unknown';
  osVerInfo.dwOSVersionInfoSize := Sizeof(TOSVersionInfo);
  if GetVersionEx(osVerInfo) then begin
    majorVer := osVerInfo.dwMajorVersion;
    minorVer := osVerInfo.dwMinorVersion;
    case osVerInfo.dwPlatformId of
      VER_PLATFORM_WIN32_NT : { Windows NT/2000 }
        begin
          if majorVer <= 4 then
            result := 'Windows NT'
          else if (majorVer = 5) and (minorVer= 0) then
            result := 'Windows 2000'
          else if (majorVer = 5) and (minorVer = 1) then
            result := 'Windows XP'
          else
            result := 'Unknown';
        end;
      VER_PLATFORM_WIN32_WINDOWS :  { Windows 9x/ME }
        begin
          if (majorVer = 4) and (minorVer = 0) then
            result := ' Windows 95'
          else if (majorVer = 4) and (minorVer = 10) then begin
            if osVerInfo.szCSDVersion[1] = 'A' then
              result := 'Windows 98SE'
            else
              result := 'Windows 98';
          end
          else if (majorVer = 4) and (minorVer = 90) then
            result := 'Windows ME'
          else
            result := 'Unknown';
        end;
    else
      result := 'Unknown';
    end;
  end else
    result := 'Unknown';
end;
//
// this function by Alex Mokrov (almk@mail.ru)
// detects six emf header bytes
//
function fDetectHeaderBytes(InFileName: String) : string;
var i      : Integer;
    F      : TFileStream; // spl file
    Head   : EMFheader;
    strTmp : string;
    Buf    : array[0..5] of char; // six emf header bytes
begin
  F:= TFileStream.Create(InFileName, 0);
  // Read SPL signature
  F.Read(i, 4);
  if i <> $00010000 then begin
    // bad file -> abort
    MessageBox(0, 'This is not a valid spooler file', 'Error', mb_Ok or mb_DefButton1);
    F.Free;
    Exit;
  end;
  // Read first emf chunk
  F.Read(i, 4);
  F.Position := i;
  F.Read(Head, sizeof(Head));
  if (Head.Signature <> EMFheaderSignature) or (Head.EMFsize = 0) then begin
    // bad file
    MessageBox(0, 'This is not a valid spooler file', 'Error', mb_Ok or mb_DefButton1);
    Buf := '';
  end else
    f.ReadBuffer(Buf, SizeOf(Buf));
  F.Free;
  // Buf contains the six emf header bytes
  for i:=0 to length(Buf) - 1 do
    strTmp := strTmp + Buf[i];
  fDetectHeaderBytes := strTmp;
end;
procedure ReadBinaryDataFile(strFilename : string; strDestDir : string);
// this reads an nt spool file (.spl), extracts the emfs out of
// it and writes *.emf files into strDestDir
var
  fFromF, fToF           : file; // input / output files
  strEMFFileName, strTmp : string;
  nRead, nWritten, i, nReadTotal, nNextFilePos : Integer;
  Buf                    : array[1..2048] of Char; // buffer to read emf data into
  nPixFound, test        : Integer; // # of pictures found
  PosList                : TStringList; // list of emf's positions within spl file
  strHeaderBytes         : string; // six emf header bytes read from fDetectHeaderBytes
begin
  if not FileExists(strFileName) then
    raise Exception.Create('Cannot read ' + strFileName)
  else begin
    strHeaderBytes := fDetectHeaderBytes(strFileName);
    AssignFile(fFromF, strFileName);
  end;
  Reset(fFromF, 1);
  PosList := TStringList.Create;
  nPixFound := 0;
  nReadTotal := 0;
  // check # of emf's in spl-file
  repeat
    // #s of files: nPixFound
    // PosList: Positions of file beginnings in emf
    BlockRead(fFromF, Buf, SizeOf(Buf), nRead);
    test := Pos(strHeaderBytes, Buf);
    if (test > 0) then begin
      Inc(nPixFound);
      if test<>0 then PosList.Add(IntToStr(test + nReadTotal));
    end;
    Inc(nReadTotal, nRead);
  until (nRead = 0) ; // or (nWritten <> nRead);
  // open output
  for i:=1 to nPixFound do begin
    // extract emfs
    strTmp := IntToStr(i);
    while Length(strTmp)< 8 do
      Insert('0', strTmp, 1);
    strEMFFileName := Concat(strDestDir, strTmp,'.EMF');
    AssignFile(fToF, strEMFFileName);
    Rewrite(fToF, 1);
    try
      Seek(fFromf, StrToInt(PosList.Strings[i-1])-1);
      repeat
        BlockRead(fFromF, Buf, SizeOf(Buf), nRead);
        BlockWrite(fToF, Buf, nRead, nWritten);
        if i<nPixFound then
          nNextFilePos := StrToInt(PosList.Strings[i])
        else
          nNextFilePos := FileSize(fFromF);
      until (FilePos(fFromF)>=nNextFilePos);
    except
      on EInOutError do ShowMessage('Read Error');
    end;
    CloseFile(fToF);
  end;
  CloseFile(fFromF);
  PosList.Free;
  // now delete *.spl file
  DeleteFile(strFilename);
end;
//
// preliminary stuff
//
procedure TForm1.FormActivate(Sender: TObject);
var
  reg       : TWinRegistry;
  SearchRes : TSearchRec;// search structure
  nGaugeCounter,         // makes nice gauge
  nFound, i : Integer;   // # of files found (when searching)
  strTemp : string[8];   // filename: <number>.emf
  strCnt : string;       // <full path> + <emf-file>
  strSpoolDir : string;  // spool-directory (NT only)
  strOldFile, strNewFile : string; // filename (NT: spool file)
  m_strTempVar : string; // registry entry holding destination dir for print jobs
  strDestDir : string;   // destination directory for emfs
  strSHDFile : string;   // instruction file
  lpszTempDir : PChar;   // %TEMP% dir (w95 & nt)
  lpszSpoolDir : PChar;  // spool dir (nt only)
begin
  // inits and allocs
  nGaugeCounter := 0;
  nThreadsRunning := 0;
  GetMem(lpszTempDir, 255);
  GetMem(lpszSpoolDir, 255);
  // %temp%-var set?
  if (GetEnvironmentVariable('temp', lpszTempDir, 255) = 0) then begin
    MessageDlg('Environment Variable %temp% not set!' + #13 +
               'Either install driver properly or' + #13 + 'define a %temp% environment variable.', mtError, [mbAbort], 0);
    FreeMem(lpszTempDir);
    Application.Terminate;
  end;
  strTempDir := string(lpszTempDir);
  FreeMem(lpszTempDir);
  // try to get registry settings for destdir
  reg := TWinRegistry.CreateWithKey(HKEY_LOCAL_MACHINE, PMON_KEY);
  m_strTempVar := reg.ReadString('vprproc', 'DestDir', '');
  if (m_strTempVar = '') then
    ShowMessage('vprproc registry settings not yet set!' + #13 + 'Please select destination directory for print jobs' + #13 +
                'using the Installer Tool!' + #13 + 'I will use your temp directory at' + #13 + strTempDir)
  else
    strTempDir := m_strTempVar;
  if (strTempDir[Length(strTempDir)] <> '') then strTempDir := Concat(strTempDir, '');
  //  ShowMessage(strTempDir);
  reg.free;
  nFileCounter := 1;
  // get OS-Version
  strOSVer := GetOSName;
  if (strOSVer = 'Windows NT') or (strOSVer = 'Windows 2000') or (strOSVer = 'Windows XP') then begin
    // NT or higher detected; locate spool-directory
    GetEnvironmentVariable('windir', lpszSpoolDir, 255);
    strSpoolDir := string(lpszSpoolDir) + 'system32spoolPRINTERS';
    FreeMem(lpszSpoolDir);
  end;
  // delete old *.emf and *.spl files in temp-directory
  nFound := FindFirst(strTempDir + '*.emf', faAnyFile, SearchRes);
  while nFound = 0 do begin
    DeleteFile(PChar(strTempDir + SearchRes.Name));
    nFound := FindNext(SearchRes);
  end;
  FindClose(SearchRes);
  nFound := FindFirst(strTempDir + '*.spl', faAnyFile, SearchRes);
  while nFound = 0 do begin
    DeleteFile(PChar(strTempDir + SearchRes.Name));
    nFound := FindNext(SearchRes);
  end;
  FindClose(SearchRes);
  if (strOSVer = 'Windows 95') or (strOSVer = 'Windows98') or (strOSVer = 'Windows 98SE') or (strOSVer = 'Windows ME') then begin
    // op's for Win 95 and other DOS-based systems
    // get # of files to be copied
    nFound := FindFirst(strTempDir + '~emf*.tmp', faAnyFile, SearchRes);
    while nFound = 0 do begin
      Inc(nGaugeCounter);
      nFound := FindNext(SearchRes);
    end;
    FindClose(SearchRes);
    // copy files
    nFound := FindFirst(strTempDir+ '~emf*.tmp', faAnyFile, SearchRes);
    while nFound = 0 do begin
      Str(nFileCounter:8, strTemp);
      while Pos(' ', strTemp) > 0 do
        strTemp[Pos(' ', strTemp)] := '0';
      strCnt := strTempDir + strTemp + '.EMF';
      CopyFile(PChar(strTempDir + SearchRes.Name), PChar(strCnt), False);
      nFound := FindNext(SearchRes);
      Gauge.AddProgress(Round(100 / nGaugeCounter));
      Inc(nFileCounter);
      strCnt := '';
      strTemp := '';
    end;
    FindClose(SearchRes);
  end else begin
    // op's for Win NT
    // get # of files to be copied
    StringList := TStringList.Create;  // fill stringlist with possible *.spl files
    nFound := FindFirst(strSpoolDir + '*.SPL', faAnyFile, SearchRes);
    while nFound = 0 do begin
      Inc(nGaugeCounter);
      nFound := FindNext(SearchRes);
    end;
    FindClose(SearchRes);
    nFileCounter := 0;
    // copy *.spl file
    nFound := FindFirst(strSpoolDir+ '*.SPL', faAnyFile, SearchRes);
    if nFound = 0 then begin
      {$I-}
      DateSeparator := '-';
      TimeSeparator := '-';
      strDestDir := strTempDir + DateTimeToStr(Now);
      MkDir(strDestDir);
      // MessageDlg('Directory ' + strDestDir, mtInformation, [mbOk], 0);
      if IOResult <> 0 then raise Exception.Create('Cannot create directory ' + strDestDir + ': ' + IntToStr(IOResult))
    end;
    while nFound = 0 do begin
      strOldFile := strSpoolDir + SearchRes.Name;
      strSHDFile := StringReplace(strOldFile, '.SPL', '.SHD', [rfIgnoreCase]);
      strNewFile := strDestDir + '' + SearchRes.Name;
      StringList.Add(strNewFile);
      // MessageDlg('Add to StringList: ' + strNewFile, mtInformation, [mbok], 0);
      // 1st copy .spl file to temp directory
      if not FileExists(strOldFile) then
        raise Exception.Create('Spool File not found: ' + strOldFile)
      else begin
        // MessageDlg('Copy ' + strOldFile + ' => ' + strNewFile, mtInformation, [mbok], 0);
        if not CopyFile(PChar(strOldFile), PChar(strNewFile), False) then raise Exception.Create('Cannot copy ' + strOldFile);
        // then delete original file
        // if not DeleteFile(PChar(strOldFile)) then ShowMessage('Cannot delete ' + strOldFile + '. Please delete it manually!');
      end;
      // if FileExists(strSHDFile) then
      //   if not DeleteFile(PChar(strSHDFile)) then ShowMessage('Cannot delete ' + strSHDFile + '. Please delete it manually!');
      nFound := FindNext(SearchRes);
      Inc(nFileCounter);
      strCnt := '';
      strTemp := '';
    end;
    FindClose(SearchRes);
    // now that the file(s) is / are copied analyse them
    for i:=0 to nFileCounter-1 do begin
      Gauge.AddProgress(Round(100 / nGaugeCounter));
      ReadBinaryDataFile(StringList.Strings[i], strDestDir + '');
    end;
  end;
  // end
  Application.Terminate;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
  StringList.Free;
end;
end.

						