Delphi经典实例源码详解

#源码分析 #实例详解 #技术实现 #代码展示

本文深入解析"其他源码光盘1"中的经典Delphi实例，展示每个示例的核心源代码和关键技术实现。通过详细的代码分析，帮助开发者理解这些经典解决方案的实现原理。

    源码价值：42个实例的完整源代码展示，涵盖系统编程、数据库操作、硬件接口等核心技术领域，每个示例都包含关键实现代码和设计思路。
  

数据库操作实例

实例12：ADO控件开发框架

完整的数据库连接管理和操作框架，封装了ADO组件的核心功能。

核心连接管理类：

type
  TConnection = class
  private
    FADOConnection: TADOConnection;
    function ConstructorConnStr: string;
  public
    constructor Create(LoginPrompt: Boolean);
    property ADOConnection: TADOConnection read FADOConnection;
  end;

constructor TConnection.Create(LoginPrompt: Boolean);
begin
  inherited Create;
  FADOConnection := TADOConnection.Create(nil);
  FADOConnection.ConnectionString := ConstructorConnStr;
  FADOConnection.LoginPrompt := LoginPrompt;
  try
    FADOConnection.Open;
  except
    on E: Exception do
      raise Exception.Create('数据库连接失败: ' + E.Message);
  end;
end;

function TConnection.ConstructorConnStr: string;
begin
  // 构造连接字符串
  Result := 'Provider=SQLOLEDB.1;Integrated Security=SSPI;'+
            'Persist Security Info=False;Initial Catalog=TestDB;'+
            'Data Source=localhost';
end;

通用查询类：

type
  TADOCommonQuery = class(TObject)
  private
    FADOQuery: TADOQuery;
    FParameters: TParameters;
  public
    procedure ImportQryParam(sSqlStatement: string; 
      ArgName: array of string; ArgValue: array of Const);
    function GetADOQuery: TADOQuery;
    property NoRowSelected: Boolean read Get_NoRowSelected;
  end;

procedure TADOCommonQuery.ImportQryParam(sSqlStatement: string; 
  ArgName: array of string; ArgValue: array of Const);
var
  i: Integer;
begin
  FADOQuery.Close;
  FADOQuery.SQL.Text := sSqlStatement;
  
  // 设置参数
  for i := 0 to High(ArgName) do
  begin
    FADOQuery.Parameters.ParamByName(ArgName[i]).Value := ArgValue[i];
  end;
  
  FADOQuery.Open;
end;

组件经典解析02：DBISAM数据库创建

使用DBISAM组件创建和管理数据库表的完整示例。

procedure CreateTables(CreateDatabaseName: string);
var
   TableToCreate: TDBISAMTable;
   StopWords: TStrings;
begin
   TableToCreate:=TDBISAMTable.Create(Application);
   try
      with TableToCreate do
      begin
         DatabaseName:=CreateDatabaseName;
         TableName:='animals';
         Exclusive:=True;
         
         // 定义字段结构
         with FieldDefs do
         begin
            Clear;
            Add('NAME',ftString,30,False);
            Add('SIZE',ftSmallint,0,False);
            Add('WEIGHT',ftSmallint,0,False);
            Add('AREA',ftString,20,False);
            Add('BMP',ftGraphic,0,False);
         end;
         
         // 定义索引
         with IndexDefs do
         begin
            Clear;
            Add('NAME','NAME',[]);
         end;
         
         if not Exists then
         begin
            CreateTable;
            // 表结构重组和优化
            RestructureTable(0,0,3,12,False,'','',512,-1,'',
              StopWords, '*+,-./:;<=>\`',
              '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ_abcdefghijklmnopqrstuvwxyz',
              True);
         end;
      end;
   finally
      TableToCreate.Free;
   end;
end;

系统工具实例

实例20：系统进程查看器

使用Windows API获取和管理系统进程信息的核心实现。

获取系统进程列表：

procedure TForm1.GetProcesses;
var
  hSnap: THandle;
  ProcessEntry: TProcessEntry32;
  Proceed: Boolean;
begin
  // 创建系统快照
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0);
  if HSnap <> INVALID_HANDLE_VALUE then
  begin
    ProcessEntry.dwSize := SizeOf(TProcessEntry32);
    Proceed := Process32First(hSnap, ProcessEntry);
    
    while Proceed do
    begin
      with ProcessEntry do
      with ListView_pro.Items.Add do
      begin
        Caption := szEXEFile;                    // 进程名称
        SubItems.Add(IntToStr(Th32ProcessID));   // 进程ID
        SubItems.Add(IntToStr(th32ParentProcessID)); // 父进程ID
        SubItems.Add(IntToStr(Th32ModuleID));    // 模块ID
        SubItems.Add(IntToStr(cntUsage));        // 引用计数
        SubItems.Add(IntToStr(cntThreads));      // 线程数
        SubItems.Add(IntToStr(pcPriClassBase));  // 优先级
      end;
      Proceed := Process32Next(hSnap, ProcessEntry);
    end;
    CloseHandle(hSnap);
  end
  else
    ShowMessage('无法创建系统快照: ' + SysErrorMessage(GetLastError));
end;

获取进程模块信息：

procedure TForm1.GetModules(ProcessID: DWORD);
var 
  hSnap: THandle;
  ModuleEntry: TModuleEntry32;
  Proceed: Boolean;
begin
  hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, ProcessID);
  if HSnap <> INVALID_HANDLE_VALUE then
  begin
    ModuleEntry.dwSize := SizeOf(TModuleEntry32);
    Proceed := Module32First(hSnap, ModuleEntry);
    
    while Proceed do
    begin
      with ModuleEntry do
      with ListView_mod.Items.Add do
      begin
        Caption := szModule;                     // 模块名称
        SubItems.Add(ExtractFilePath(szEXEPath)); // 路径
        SubItems.Add(IntToStr(Th32ModuleID));    // 模块ID
        SubItems.Add(FloatToStr(ModBaseSize/1024)); // 大小(KB)
        SubItems.Add(IntToStr(GlblCntUsage));    // 全局引用计数
      end;
      Proceed := Module32Next(hSnap, ModuleEntry);
    end;
    CloseHandle(hSnap);
  end
  else
    ShowMessage('无法获取模块信息: ' + SysErrorMessage(GetLastError));
end;

终止进程功能：

procedure TForm1.SpeedButton3Click(Sender: TObject);
var 
  uexitcode: byte;
  ProcessHandle: THandle;
begin
  if ListView_pro.Selected <> nil then
  begin
    if MessageDlg('终止进程可能导致系统不稳定！确认吗？', 
       mtConfirmation, [mbYes, mbNo], 0) = mrYes then
    begin
      ProcessHandle := OpenProcess(PROCESS_TERMINATE, False, 
        StrToInt(ListView_pro.Selected.SubItems[0]));
      if ProcessHandle <> 0 then
      begin
        TerminateProcess(ProcessHandle, uexitcode);
        ListView_pro.Selected.Delete;
        StatusBar1.Panels[0].Text := '系统进程数：' + 
          IntToStr(ListView_pro.Items.Count);
        CloseHandle(ProcessHandle);
      end
      else
        ShowMessage('无法打开进程句柄');
    end;
  end
  else
    ShowMessage('请选择一个进程！');
end;

界面开发实例

实例14：自定义窗口实现

创建无边框自定义窗口的核心技术实现。

程序入口和窗口句柄设置：

program Normal;

uses
  UnitDllExe in 'UnitDllExe.pas',
  Forms,
  FormMain in 'FormMain.pas' {MainForm};

{$R *.res}

begin
  Application.Initialize;
  Application.CreateForm(TMainForm, MainForm);
  // 关键：将应用程序句柄设置为窗体句柄
  Application.Handle := MainForm.Handle;
  Application.Run;
end.

DLL/EXE模式判断单元：

unit UnitDllExe;

interface

implementation

initialization
  // 设置是否为库模式
  IsLibrary := true;

end.

Web浏览器组件实现

基于IE内核的Web浏览器组件开发。

主窗体实现：

unit MainFrm;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw_TLB, ZoCWebBrowser;

type
  TMainForm = class(TForm)
    ZoCWebBrowser: TZoCWebBrowser;
    function ZoCWebBrowserGetExternal(out ppDispatch: IDispatch): HRESULT;
    procedure FormCreate(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

implementation

uses MyExternalImpl;

function TMainForm.ZoCWebBrowserGetExternal(
  out ppDispatch: IDispatch): HRESULT;
var
  MyExternal: TMyExternal;
begin
  MyExternal := TMyExternal.Create;
  ppDispatch := MyExternal;
  Result := S_OK;
end;

procedure TMainForm.FormCreate(Sender: TObject);
begin
  // 初始化Web浏览器
  ZoCWebBrowser.Navigate('http://www.example.com');
end;

硬件接口实例

串口通信核心实现

串口数据收发的基础框架代码。

串口初始化和配置：

type
  TSerialPort = class
  private
    FHandle: THandle;
    FPortName: string;
    FBaudRate: DWORD;
  public
    function OpenPort(PortName: string; BaudRate: DWORD): Boolean;
    function ClosePort: Boolean;
    function WriteData(Buffer: Pointer; Count: DWORD): DWORD;
    function ReadData(Buffer: Pointer; Count: DWORD): DWORD;
  end;

function TSerialPort.OpenPort(PortName: string; BaudRate: DWORD): Boolean;
var
  CommTimeouts: TCommTimeouts;
begin
  FPortName := PortName;
  FBaudRate := BaudRate;
  
  // 打开串口
  FHandle := CreateFile(PChar('\\.\' + PortName),
    GENERIC_READ or GENERIC_WRITE,
    0, nil, OPEN_EXISTING,
    FILE_ATTRIBUTE_NORMAL, 0);
    
  if FHandle = INVALID_HANDLE_VALUE then
  begin
    Result := False;
    Exit;
  end;
  
  // 配置串口参数
  SetupComm(FHandle, 4096, 4096);
  
  // 设置超时
  CommTimeouts.ReadIntervalTimeout := MAXDWORD;
  CommTimeouts.ReadTotalTimeoutMultiplier := 0;
  CommTimeouts.ReadTotalTimeoutConstant := 0;
  CommTimeouts.WriteTotalTimeoutMultiplier := 0;
  CommTimeouts.WriteTotalTimeoutConstant := 5000;
  SetCommTimeouts(FHandle, CommTimeouts);
  
  Result := True;
end;

实用工具实例

文件操作工具核心代码

批量文件处理和管理的基础实现。

type
  TFileProcessor = class
  private
    FSourcePath: string;
    FDestPath: string;
  public
    procedure BatchRename(const FileMask: string; const NewNamePattern: string);
    procedure CopyFiles(const FileMask: string; const DestFolder: string);
    function GetFileSize(const FileName: string): Int64;
  end;

procedure TFileProcessor.BatchRename(const FileMask: string; 
  const NewNamePattern: string);
var
  SearchRec: TSearchRec;
  Counter: Integer;
  NewName: string;
begin
  Counter := 1;
  if FindFirst(FSourcePath + FileMask, faAnyFile, SearchRec) = 0 then
  begin
    repeat
      if (SearchRec.Attr and faDirectory) = 0 then
      begin
        NewName := Format(NewNamePattern, [Counter]);
        RenameFile(FSourcePath + SearchRec.Name, 
          FSourcePath + NewName);
        Inc(Counter);
      end;
    until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
  end;
end;

function TFileProcessor.GetFileSize(const FileName: string): Int64;
var
  Handle: THandle;
  FindData: TWin32FindData;
begin
  Handle := FindFirstFile(PChar(FileName), FindData);
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    Result := Int64(FindData.nFileSizeHigh) shl 32 or 
              Int64(FindData.nFileSizeLow);
    Windows.FindClose(Handle);
  end
  else
    Result := -1;
end;

技术要点总结

    核心设计模式
    封装模式：将复杂API调用封装成易用的类和方法
异常处理：完善的错误处理和用户提示机制
资源管理：正确的句柄和内存资源释放
配置分离：将配置信息与核心逻辑分离

  

现代适配建议

Unicode支持：在现代Delphi版本中注意字符串编码处理
权限管理：系统级操作需要适当的权限声明
安全考虑：进程操作等功能需要用户确认和安全检查
组件更新：考虑使用FireDAC等现代数据访问组件

    学习价值
    掌握Windows系统编程的核心API调用
理解面向对象设计在实际项目中的应用
学习异常处理和资源管理的最佳实践
体会实用工具开发的完整思路和实现方法

  

总结

这些经典实例的源代码展现了Delphi开发者解决实际问题的技术智慧。每个示例都体现了：

实用性：解决真实开发场景中的具体问题
完整性：包含从设计到实现的完整解决方案
可扩展性：代码结构清晰，易于维护和扩展
教学价值：是学习Delphi系统编程的绝佳教材

    传承与创新：在学习这些经典代码的同时，我们应该思考如何将这些技术智慧应用到现代开发中，结合新技术创造出更有价值的解决方案。
  