【巨分贴，望版主置顶】，请大家将自认为实用，精彩的Delphi代码（包括自己写的！）贴出来！供彼此共同交流学习！

此念头源于在jsp论坛看到的这样的建议。请大家踊跃参加，由于每次最多只能给分100，（同时希望版主放宽分数限制给我 ：））我会另开贴加分的！自己抛砖引玉先。
                 


                DELPHI程序注册码设计（转载）
思路是这样的:程序运行时先检测注册表,如果找到注册项,则表明已经注册,如果没有找到注册项,则提示要求注册.

<注册例程>

在DELPHI下新建一工程,放置Edit1,Edit2,Label1,Label2,Button1组件.具体代码如下:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,Registry;//在此加上Registry以便调用注册表.

type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
Label1: Tlabel;
Label2: Tlabel;
procedure Button1Click(Sender: Tobject);
procedure FormCreate(Sender: Tobject);
private
Function Check():Boolean;
Procedure CheckReg();
Procedure CreateReg();
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
Pname:string; //全局变量,存放用户名和注册码.
Ppass:integer;

implementation

{$R *.DFM}

Procedure TForm1.CreateReg();//创建用户信息.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,True);//键名为AngelSoftDemo,可自行修改.
Rego.WriteString(‘Name‘,Pname);//写入用户名.
Rego.WriteInteger(‘Pass‘,Ppass);//写入注册码.
Rego.Free;
ShowMessage(‘程序已经注册,谢谢!‘);
CheckReg; //刷新.
end;

Procedure TForm1.CheckReg();//检查程序是否在注册表中注册.
var Rego:Tregistry;
begin
Rego:=Tregistry.Create;
Rego.RootKey:=HKEY_USERS;
IF Rego.OpenKey(‘.DEFAULTSoftwareAngelSoftDemo‘,False) then
begin
Form1.Caption:=‘软件已经注册‘;
Button1.Enabled:=false;
Label1.Caption:=rego.ReadString(‘Name‘);//读用户名.
Label2.Caption:=IntToStr(Rego.ReadInteger(‘Pass‘)); //读注册码.
rego.Free;
end
else Form1.Caption:=‘软件未注册,请注册‘;
end;

Function TForm1.Check():Boolean;//检查注册码是否正确.
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);

for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c); //将用户名每个字符转换为ASCII码后相加.
end;
if StrToInt(Edit2.Text)=pass then
begin
Result:=True;
Pname:=Name;
Ppass:=Pass;
end
else Result:=False;
end;

procedure TForm1.Button1Click(Sender: Tobject);
begin
if Check then CreateReg
else ShowMessage(‘注册码不正确,无法注册‘);
end;

procedure TForm1.FormCreate(Sender: Tobject);
begin
CheckReg;
end;

end.


<注册器>

在DELPHI下新建一工程,放置Edit1,Edit2,Button1组件.具体代码如下:

unit Unit1;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;

type
TForm1 = class(Tform)
Button1: Tbutton;
Edit1: Tedit;
Edit2: Tedit;
procedure Button1Click(Sender: Tobject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.Button1Click(Sender: Tobject);
var
Temp:pchar;
Name:string;
c:char;
I,Long,Pass:integer;
begin
Pass:=0;
Name:=edit1.Text;
long:=length(Name);

for I:=1 to Long do
begin
temp:=pchar(copy(Name,I,1));
c:=temp^;
Pass:=Pass+ord(c);
end;
edit2.text:=IntToStr(pass);
end;

end.

从<注册器>中取得注册码,便可在<注册例程>中进行注册.原理是使用ORD函数取得用户名每单个字符的ASCII码值,并进行相加得到注册码.

282 个解决方案

#1

up

#2

up

#3

我好像并没有写过什么特别好的东东！

#4

function  FilterNumber(keyval: char; me: TEdit; dot, Minus: string; ExtLen: integer): boolean;
var
   s: string;
   c: string;
   p: Integer;
begin  
    result := false;
    s := '0123456789';
    c := keyval;
    if (dot = '.') then
        s := s + '.';
    if (minus = '-') then
        s := s + '-';
    if (c = dot) and (TRIM(me.text) = '') then
        Exit;
    if (c = dot) and (Pos(dot, me.text) > 0) then
        Exit;
    if (c = dot) and (trim(me.text) = minus) then
        Exit;
    if (c = minus) and (Pos(minus, me.Text) > 0) then
        Exit;
    if (c = minus) and (pos(minus, me.Text) < 1) and (Me.SelStart > 0) then
        Exit;
    if (c = minus) and (trim(me.Text) = dot) then
        Exit;
    result := (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
        or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK)) or (Pos(c, s) > 0);
    p := Pos(dot, Me.Text + c);
    if (p > 0) then
        if (length(Me.text + c) - P) > ExtLen then
            result := (false) or (keyval = chr(vk_return)) or (keyval = Chr(vk_tab))
                or (keyval = chr(VK_DELETE)) or (keyval = chr(VK_BACK));
end;

procedure TForm1.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
    if not filterNumber(key, Edit1, '.', '-', 6) then
        key := #0;
end;

#5

//////如何用代码自动建ODBC

以下是在程序中动态创建ODBC的DSN数据源代码： 
procedure TCreateODBCDSNfrm.CreateDSNBtnClick(Sender: TObject); 
var 
  registerTemp : TRegistry; 
  bData : array[ 0..0 ] of byte; 
begin 
  registerTemp := TRegistry.Create; 
  //建立一个Registry实例 
  with registerTemp do 
       begin 
      RootKey:=HKEY_LOCAL_MACHINE; 
      //设置根键值为HKEY_LOCAL_MACHINE 
      //找到Software\ODBC\ODBC.INI\ODBC Data Sources 
      if OpenKey('Software\ODBC\ODBC.INI 
      \ODBC Data Sources',True) then 
     begin //注册一个DSN名称 
     WriteString( 'MyAccess', 'Microsoft 
      Access Driver (*.mdb)' ); 
           end 
         else 
           begin//创建键值失败 
     memo1.lines.add('增加ODBC数据源失败'); 
     exit; 
      end; 
      CloseKey; 
//找到或创建Software\ODBC\ODBC.INI 
 \MyAccess,写入DSN配置信息 
      if OpenKey('Software\ODBC\ODBC.INI 
      \MyAccess',True) then 
     begin 
     WriteString( 'DBQ', 'C:\inetpub\wwwroot 
     \test.mdb' );//数据库目录，连接您的数据库 
     WriteString( 'Description', 
     '我的新数据源' );//数据源描述 
     WriteString( 'Driver', 'C:\PWIN98\SYSTEM\ 
     odbcjt32.dll' );//驱动程序DLL文件 
     WriteInteger( 'DriverId', 25 ); 
     //驱动程序标识 
     WriteString( 'FIL', 'Ms Access;' ); 
     //Filter依据 
     WriteInteger( 'SafeTransaction', 0 ); 
     //支持的事务操作数目 
     WriteString( 'UID', '' );//用户名称 
     bData[0] := 0; 
     WriteBinaryData( 'Exclusive', bData, 1 ); 
     //非独占方式 
     WriteBinaryData( 'ReadOnly', bData, 1 ); 
     //非只读方式 
           end 
         else//创建键值失败 
           begin 
     memo1.lines.add('增加ODBC数据源失败'); 
     exit; 
      end; 
      CloseKey; 
//找到或创建Software\ODBC\ODBC.INI 
\MyAccess\Engines\Jet 
    //写入DSN数据库引擎配置信息 
      if OpenKey('Software\ODBC\ODBC.INI 
     \MyAccess\Engines\Jet',True) then 
     begin 
     WriteString( 'ImplicitCommitSync', 'Yes' ); 
     WriteInteger( 'MaxBufferSize', 512 );//缓冲区大小 
     WriteInteger( 'PageTimeout', 10 );//页超时 
     WriteInteger( 'Threads', 3 );//支持的线程数目 
     WriteString( 'UserCommitSync', 'Yes' ); 
           end 
         else//创建键值失败 
           begin 
     memo1.lines.add('增加ODBC数据源失败'); 
     exit; 
      end; 
      CloseKey; 
         memo1.lines.add('增加新ODBC数据源成功'); 
      Free; 
       end; 
end;

#6

收藏

#7

好像没多少人响应，不知道为啥？：（

#8

一个管理最近使用过的文件的类：

{-----------------------------------------------------------------------------
 Unit Name: RcntFileMgr
 Author:    tony
 Purpose:   Manager the recent file list.
 History:   2004.06.08    create
-----------------------------------------------------------------------------}


unit RcntFileMgr;

interface

uses
  Classes, SysUtils, Inifiles;

type
  TRecentFileChangedEvent = procedure(Sender:TObject) of object;
  
  TRecentFileManager=class(TObject)
  private
    FRecentFileList:TStringList;
    FMaxRecentCount:Integer;
    FOnRecentFileChanged:TRecentFileChangedEvent;
  protected
    function GetRecentFileCount():Integer;
    function GetRecentFile(Index:Integer):String;
    procedure LoadFromConfigFile();
    procedure SaveToConfigFile();
  public
    constructor Create();
    destructor Destroy();override;
    procedure AddRecentFile(const AFileName:String);
    property RecentFileCount:Integer read GetRecentFileCount;
    property RecentFile[Index:Integer]:String read GetRecentFile;
    property OnRecentFileChanged:TRecentFileChangedEvent read FOnRecentFileChanged write FOnRecentFileChanged;
  end;
  
implementation

{ TRecentFileManager }

function TRecentFileManager.GetRecentFileCount():Integer;
begin
  Result:=FRecentFileList.Count;
end;

function TRecentFileManager.GetRecentFile(Index:Integer):String;
begin
  Result:=FRecentFileList.Strings[Index];
end;

procedure TRecentFileManager.LoadFromConfigFile();
var
  Ini:TInifile;
  KeyList:TStringList;
  I:Integer;
begin
  Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
  KeyList:=TStringList.Create();
  try
    Ini.ReadSection('RecentFile',KeyList);
    for I:=0 to KeyList.Count-1 do begin
      FRecentFileList.Add(Ini.ReadString('RecentFile',KeyList.Strings[I],''));
    end;
    if Assigned(FOnRecentFileChanged) then begin
      FOnRecentFileChanged(self);
    end;
  finally
    Ini.Free;
    KeyList.Free;
  end;
end;

procedure TRecentFileManager.SaveToConfigFile();
var
  Ini:TInifile;
  I:Integer;
begin
  Ini:=TInifile.Create(ExtractFilePath(ParamStr(0))+'config.ini');
  try
    Ini.EraseSection('RecentFile');
    for I:=0 to FRecentFileList.Count-1 do begin
      Ini.WriteString('RecentFile','Recent'+IntToStr(I),FRecentFileList.Strings[I]);
    end;
  finally
    Ini.Free;
  end;
end;

constructor TRecentFileManager.Create();
begin
  inherited Create();
  FRecentFileList:=TStringList.Create();
  FMaxRecentCount:=5;
  LoadFromConfigFile();
end;

destructor TRecentFileManager.Destroy();
begin
  if Assigned(FRecentFileList) then begin
    try
      SaveToConfigFile();
    except
      //ignore any exceptions
    end;
    FreeAndNil(FRecentFileList);
  end;
  inherited Destroy();
end;

procedure TRecentFileManager.AddRecentFile(const AFileName:String);
var
  RecentIndex:Integer;
begin
  RecentIndex:=FRecentFileList.IndexOf(AFileName);
  if RecentIndex>=0 then begin
    FRecentFileList.Delete(RecentIndex);
  end;
  FRecentFileList.Insert(0,AFileName);
  while FRecentFileList.Count>FMaxRecentCount do begin
    FRecentFileList.Delete(FRecentFileList.Count-1);
  end;
  if Assigned(FOnRecentFileChanged) then begin
    FOnRecentFileChanged(self);
  end;
end;

end.

#9

一个SDI类型的文件管理器，可以管理新建，保存，另存为，以及关闭时提示保存等功能：
unit FileMgr;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Forms, Controls, Dialogs,
  QuickWizardFrm, TLMObject;

type
  TNewFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
  TStartWizardEvent = procedure (Sender:TObject;Info:TQuickWizardInfo;var Successful:Boolean) of object;
  TOpenFileEvent = procedure (Sender:TObject;const FileName:String;var 
          Successful:Boolean) of object;
  TSaveFileEvent = procedure (Sender:TObject;const FileName:String;var 
          Successful:Boolean) of object;
  TCloseFileEvent = procedure (Sender:TObject;var Successful:Boolean) of object;
  TFileNameChangedEvent = procedure (Sender:TObject;const FileName:String) of 
          object;
  TFileManager = class (TObject)
  private
    FFileName: String;
    FIsNewFile:Boolean;
    FModified: Boolean;
    FFileFilter:String;
    FDefaultExt:String;
    FtlmObject:TtlmObject;
    FOnCloseFile: TCloseFileEvent;
    FOnFileNameChanged: TFileNameChangedEvent;
    FOnNewFile: TNewFileEvent;
    FOnStartWizard: TStartWizardEvent;
    FOnOpenFile: TOpenFileEvent;
    FOnSaveFile: TSaveFileEvent;
  protected
    procedure SetModified(AValue: Boolean);
  public
    constructor Create;
    destructor Destroy; override;
    function DoCloseFile: Boolean;
    function DoNewFile: Boolean;
    function DoStartWizard:Boolean;
    function DoOpenFile: Boolean;overload;
    function DoOpenFile(const AFileName:String):Boolean;overload;
    function DoSaveAsFile: Boolean;
    function DoSaveFile: Boolean;
    property FileName: string read FFileName;
    property Modified: Boolean read FModified write SetModified;
    property FileFilter:String read FFileFilter write FFileFilter;
    property DefaultExt:String read FDefaultExt write FDefaultExt;
    property OnCloseFile: TCloseFileEvent read FOnCloseFile write FOnCloseFile;
    property OnFileNameChanged: TFileNameChangedEvent read FOnFileNameChanged
            write FOnFileNameChanged;
    property OnNewFile: TNewFileEvent read FOnNewFile write FOnNewFile;
    property OnStartWizard: TStartWizardEvent read FOnStartWizard write FOnStartWizard;
    property OnOpenFile: TOpenFileEvent read FOnOpenFile write FOnOpenFile;
    property OnSaveFile: TSaveFileEvent read FOnSaveFile write FOnSaveFile;
  end;
  
implementation
  
{
********************************* TFileManager *********************************
}
constructor TFileManager.Create;
begin
  inherited Create();
  FtlmObject:=TtlmObject.Create(self);
  FFileName:='';
  FIsNewFile:=true;
  Modified:=false;
  if Assigned(FOnFileNameChanged) then begin
    FOnFileNameChanged(self,FFileName);
  end;
end;

destructor TFileManager.Destroy;
begin
  if Assigned(FtlmObject) then begin
    FreeAndNil(FtlmObject);
  end;
  inherited Destroy();
end;

function TFileManager.DoCloseFile: Boolean;
var
  MsgResult: TModalResult;
  Succ: Boolean;
begin
  if FModified then begin
    Result:=false;
    MsgResult:=MessageBox(Application.Handle,
        PChar(FtlmObject.Translate('FileModified','File ''%s'' had been modified, do you want to save it?',[FFileName])),
        pchar(Application.Title),MB_ICONQUESTION or MB_YESNOCANCEL);
    if MsgResult=mrYES then begin
      if not DoSaveFile() then
        exit;
    end
    else if MsgResult=mrCancel then begin
      exit;
    end;
    if Assigned(FOnCloseFile) then begin
      Succ:=false;
      FOnCloseFile(self,Succ);
      Result:=Succ;
      if Result then begin
        FFileName:='';
        FIsNewFile:=false;
        FModified:=false;
        if Assigned(FOnFileNameChanged) then begin
          FOnFileNameChanged(self,FFileName);
        end;
      end;
    end;
  end
  else begin
    if Assigned(FOnCloseFile) then begin
      Succ:=false;
      FOnCloseFile(self,Succ);
      Result:=Succ;
      if Result then begin
        FFileName:='';
        FIsNewFile:=false;
        FModified:=false;
        if Assigned(FOnFileNameChanged) then begin
          FOnFileNameChanged(self,FFileName);
        end;
      end;
    end;
    Result:=true;
  end;
end;

#10

function TFileManager.DoNewFile: Boolean;
var
  Succ: Boolean;
begin
  Result:=false;
  if not DoCloseFile() then
    exit;
  if Assigned(FOnNewFile) then begin
    Succ:=false;
    FOnNewFile(self,Succ);
    Result:=Succ;
    if Result then begin
      FFileName:=FtlmObject.Translate('NewAlbum','New Album');
      FIsNewFile:=true;
      FModified:=false;
      if Assigned(FOnFileNameChanged) then begin
        FOnFileNameChanged(self,FFileName);
      end;
    end;
  end;
end;

function TFileManager.DoStartWizard:Boolean;
var
  Succ:Boolean;
  Info:TQuickWizardInfo;
begin
  Result:=false;
  if Assigned(FOnStartWizard) then begin
    Info.ImageList:=TStringList.Create();
    Info.FileName:=FtlmObject.Translate('NewAlbum','New Album');
    Info.CopyImage:=false;
    Info.CreateContent:=true;
    try
      if not ShowQuickWizardForm(nil,Info) then
        exit;
      if not DoCloseFile() then
        exit;
      Succ:=false;
      FOnStartWizard(self,Info,Succ);
      Result:=Succ;
      if Result then begin
        FFileName:=Info.FileName;
        FIsNewFile:=true;
        FModified:=true;
        if Assigned(FOnFileNameChanged) then begin
          FOnFileNameChanged(self,FFileName + ' *');
        end;
      end
      else begin
        DoNewFile();
      end;
    finally
      Info.ImageList.Free;
    end;
  end;
end;

function TFileManager.DoOpenFile: Boolean;
var
  Succ: Boolean;
  OpenDialog: TOpenDialog;
  FileNameTmp: string;
begin
  Result:=false;
  if Assigned(FOnOpenFile) then begin
    OpenDialog:=TOpenDialog.Create(nil);
    try
      OpenDialog.Filter:=FFileFilter;
      OpenDialog.FilterIndex:=0;
      OpenDialog.DefaultExt:=FDefaultExt;
      if OpenDialog.Execute then begin
        FileNameTmp:=OpenDialog.FileName;
        if (CompareText(FileNameTmp,FFileName)=0) and (not FIsNewFile) then begin  //if the file already opened
          if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
              PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
            exit;
          end;
        end;
        if not DoCloseFile() then
          exit;
        Succ:=false;
        FOnOpenFile(self,FileNameTmp,Succ);
        Result:=Succ;
        if Result then begin
          FFileName:=FileNameTmp;
          FIsNewFile:=false;
          FModified:=false;
          if Assigned(FOnFileNameChanged) then begin
            FOnFileNameChanged(self,FFileName);
          end;
        end
        else begin
          DoNewFile();
        end;
      end;
    finally
      OpenDialog.Free;
    end;
  end;
end;

function TFileManager.DoOpenFile(const AFileName:String):Boolean;
var
  Succ:Boolean;
begin
  Result:=false;
  if Assigned(FOnOpenFile) then begin
    if (CompareText(AFileName,FFileName)=0) and (not FIsNewFile) then begin  //if the file already opened
      if MessageBox(Application.Handle,PChar(FtlmObject.Translate('FileAlreadyOpened','This file already opened, do you want to open it anyway?')),
          PChar(Application.Title),MB_ICONQUESTION+MB_YESNO)=mrNo then begin
        exit;
      end;
    end;
    if not DoCloseFile() then
      exit;
    Succ:=false;
    FOnOpenFile(self,AFileName,Succ);
    Result:=Succ;
    if Result then begin
      FFileName:=AFileName;
      FIsNewFile:=false;
      FModified:=false;
      if Assigned(FOnFileNameChanged) then begin
        FOnFileNameChanged(self,FFileName);
      end;
    end
    else begin
      DoNewFile();
    end;
  end;
end;

function TFileManager.DoSaveAsFile: Boolean;
var
  Succ: Boolean;
  SaveDialog: TSaveDialog;
  FileNameTmp: string;
begin
  Result:=false;
  if Assigned(FOnSaveFile) then begin
    SaveDialog:=TSaveDialog.Create(nil);
    try
      SaveDialog.Filter:=FFileFilter;
      SaveDialog.FilterIndex:=0;
      SaveDialog.DefaultExt:=FDefaultExt;
      SaveDialog.FileName:=FFileName;
      SaveDialog.Options:=SaveDialog.Options+[ofOverwritePrompt];
      if SaveDialog.Execute then begin
        FileNameTmp:=SaveDialog.FileName;
        Succ:=false;
        FOnSaveFile(self,FileNameTmp,Succ);
        Result:=Succ;
        if Result then begin
          FFileName:=FileNameTmp;
          FIsNewFile:=false;
          FModified:=false;
          if Assigned(FOnFileNameChanged) then begin
            FOnFileNameChanged(self,FFileName);
          end;
        end;
      end;
    finally
      SaveDialog.Free;
    end;
  end;
end;

function TFileManager.DoSaveFile: Boolean;
var
  Succ: Boolean;
begin
  Result:=false;
  if (FileExists(FFileName)) and (not FIsNewFile) then begin
    if Assigned(FOnSaveFile) then begin
      Succ:=false;
      FOnSaveFile(self,FFileName,Succ);
      Result:=Succ;
      if Result then begin
        FIsNewFile:=false;
        FModified:=false;
        if Assigned(FOnFileNameChanged) then begin
          FOnFileNameChanged(self,FFileName);
        end;
      end;
    end;
  end
  else begin
    Result:=DoSaveAsFile();
  end;
end;

procedure TFileManager.SetModified(AValue: Boolean);
begin
  if FModified<>AValue then begin
    if Assigned(FOnFileNameChanged) then begin
      if AValue then begin
        FOnFileNameChanged(self,FFileName+' *');
      end
      else begin
        FOnFileNameChanged(self,FFileName);
      end;
    end;
    FModified:=AValue;
  end;
end;

end.

#11

一段支持Splash启动窗体，以及在Splash窗体中显示启动的进度：
{-----------------------------------------------------------------------------
 Unit Name: AppLdr
 Author:    tony
 Purpose:   Application Loader
 History:   2004.07.08 create
-----------------------------------------------------------------------------}

unit AppLdr;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, Forms, SplashForm,
  TLMIniFilter, ActiveX, Common;

type
  TAppLoader = class (TObject)
  private
    FSplashForm: TfrmSplash;
    FtlmIniFilter:TtlmIniFilter;
    procedure OnAppLoading(ASender:TObject;AEvent:String;ADelay:Integer=50);
  public
    constructor Create();
    destructor Destroy();override;
    function DoLoad: Boolean;
  end;

var
  GAppLoader:TAppLoader;

implementation

uses
  SkinMdl, ConfigMgr, CommMgr, ICDeviceMgr, HdgClient, C1;

{
********************************** TAppLoader **********************************
}
constructor TAppLoader.Create();
begin
  inherited Create();
  FtlmIniFilter:=TtlmIniFilter.Create(Application);
  FtlmIniFilter.LanguageFiles.Add('HDG2.chs');
  FtlmIniFilter.LanguageExt:='.chs';
  FtlmIniFilter.Active:=true;
end;

destructor TAppLoader.Destroy();
begin
  if Assigned(frmC1) then begin
    GCommManager.EndListen();
    FreeAndNil(frmC1);
  end;
  if Assigned(GHdgClient) then begin
    FreeAndNil(GHdgClient);
  end;
  if Assigned(GCommManager) then begin
    FreeAndNil(GCommManager);
  end;
  if Assigned(GICDevice) then begin
    FreeAndNil(GICDevice);
  end;
  if Assigned(GSkinModule) then begin
    FreeAndNil(GSkinModule);
  end;
  if Assigned(GConfigManager) then begin
    FreeAndNil(GConfigManager);
  end;
  if Assigned(FtlmIniFilter) then begin
    FreeAndNil(FtlmIniFilter);
  end;
  inherited Destroy();
end;

function TAppLoader.DoLoad: Boolean;
begin
  Result:=false;
  Application.Title:='HDG2';
  FSplashForm:=TfrmSplash.Create(nil);
  try
    try
      FSplashForm.Show;
      OnAppLoading(nil,'Starting...');
      Sleep(200);

      GConfigManager:=TConfigManager.Create();
      GSkinModule:=TSkinModule.Create(nil);

      GICDevice:=TICDeviceDecorator.Create();
      GICDevice.OnAppLoading:=OnAppLoading;
      GICDevice.Initialize();
      GICDevice.OnAppLoading:=nil;
      
      GCommManager:=TCommManagerDecorator.Create(nil);
      GCommManager.ConfigManager:=GConfigManager;
      GCommManager.ICDevice:=GICDevice;
      GCommManager.OnAppLoading:=OnAppLoading;
      GCommManager.Initialize(true,false,false);
      GCommManager.OnAppLoading:=nil;

      GHdgClient:=THdgClient.Create();
      GHdgClient.OnAppLoading:=OnAppLoading;
      GHdgClient.Initialize();
      GHdgClient.OnAppLoading:=nil;
      
      OnAppLoading(nil,'Ending...');

      Screen.Cursors[crNo]:=LoadCursor(hInstance,'None');
      Application.CreateForm(TfrmC1, frmC1);
      
      GCommManager.BeginListen(frmC1);
      frmC1.SysCaption:=GConfigManager.SysCaption;
{$IFNDEF HDGCLIENT}
      frmC1.SysLedCaption:=GConfigManager.SysLedCaption;
{$ENDIF}

      Result:=true;
    except
      on E:Exception do begin
        MessageBox(Application.Handle,PChar(E.ClassName+':'+#13+#10+E.Message),
            PChar(Application.Title),MB_ICONERROR);
      end;
    end;
  finally
    FreeAndNil(FSplashForm);
  end;
end;

procedure TAppLoader.OnAppLoading(ASender:TObject;AEvent:String;
        ADelay:Integer);
begin
  if Assigned(FSplashForm) then begin
    if Assigned(ASender) then begin
      FSplashForm.lbl1.Caption:=ASender.ClassName+': '+AEvent;
    end
    else begin
      FSplashForm.lbl1.Caption:=AEvent;
    end;
    FSplashForm.Update;
    if ADelay>0 then
      Sleep(ADelay);
  end;
end;

end.

工程的dpr中这样用：
begin
  Application.Initialize;
  GAppLoader:=TAppLoader.Create();
  try
    if GAppLoader.DoLoad() then begin
  Application.Run;
    end;
  finally
    GAppLoader.Free;
  end;
end.

#12

获得Memo、RichEdit的光标位置：
--------------------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
var Row, Col : integer;
begin
  Row := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
  Col := CustEdit.SelStart - SendMessage(Memo1.Handle, EM_LINEINDEX, -1, 0);
  Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);
end;

#13

一个可以为其父控件提供从浏览器拖入文件功能的类：

{-----------------------------------------------------------------------------
 Unit Name: ImgDropper
 Author:    tony
 Purpose:   provide the function for drop image from explorer.
            this class should be created as an member of TPhotoPage.
 History:   2004.01.31  create
-----------------------------------------------------------------------------}


unit ImgDropper;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Controls, Graphics,
  Forms, ShellAPI, TLMObject;

type
  TImageDropper = class(TObject)
  private
    FParent:TWinControl;
    FOldWindowProc:TWndMethod;
    FtlmObject:TtlmObject;
  protected
    procedure ParentWindowProc(var Message: TMessage);
  public
    constructor Create(AParent:TWinControl);
    destructor Destroy();override;
  end;

implementation

uses
  AlbumMgr, PhotoPge, ImgDropFrm, ImageLdr;

{ TImageDropper }

procedure TImageDropper.ParentWindowProc(var Message: TMessage);
  procedure EnumDropFiles(AFileList:TStringList);
  var
    pcFileName:PChar;
    i,iSize,iFileCount:Integer;
  begin
    try
      pcFileName:='';
      iFileCount:=DragQueryFile(Message.WParam,$FFFFFFFF,pcFileName,MAX_PATH);
      for I:=0 to iFileCount-1 do begin
        iSize:=DragQueryFile(Message.WParam,i,nil,0)+1;
        pcFileName:=StrAlloc(iSize);
        DragQueryFile(Message.WParam,i,pcFileName,iSize);
        AFileList.Add(pcFileName);
        StrDispose(pcFileName);
      end;
    finally
      DragFinish(Message.WParam);
    end;
  end;
var
  FileList:TStringList;
  RdPage:TRdPage;
  DropInfo:TImgDropInfo;
  I:Integer;
  NewRdPage:TRdPage;
  ImageLoader:TImageLoader;
  Bmp:TBitmap;
begin
  if Message.Msg=WM_DROPFILES then begin
    FileList:=TStringList.Create();
    try
      if not (FParent is TPhotoPage) then
        exit;
      RdPage:=TPhotoPage(FParent).RdPage;
      if not Assigned(RdPage) then
        exit;
      EnumDropFiles(FileList);
      if FileList.Count=1 then begin        //only dropped one image
        RdPage.DoAddImageItem(FileList.Strings[0]);
      end
      else begin                           //dropped several images
        DropInfo.PlaceEachPage:=true;
        if not ShowImgDropForm(nil,DropInfo) then begin
          exit;
        end;
        if DropInfo.PlaceEachPage then begin
          ImageLoader:=TImageLoader.Create();
          Bmp:=TBitmap.Create();
          try
            for I:=0 to FileList.Count-1 do begin
              NewRdPage:=RdPage.Parent.DoInsertPage(RdPage.PageIndex+1);
              if not Assigned(NewRdPage) then begin
                break;
              end;
              ImageLoader.LoadFromFile(FileList.Strings[I],Bmp);
              NewRdPage.DoAddImageItem(FileList.Strings[I],Bmp.Width,Bmp.Height);
            end;
          finally
            ImageLoader.Free;
            Bmp.Free;
          end;
        end
        else begin
          for I:=0 to FileList.Count-1 do begin
            RdPage.DoAddImageItem(FileList.Strings[I]);
          end;
        end;
        MessageBox(FParent.Handle,PChar(FtlmObject.Translate('ImagesAdded','%d images had been added!',[FileList.Count])),PChar(Application.Title),MB_ICONINFORMATION);
      end;
    finally
      FileList.Free;
    end;
  end
  else begin
    FOldWindowProc(Message);
  end;
end;

constructor TImageDropper.Create(AParent:TWinControl);
begin
  inherited Create();
  FParent:=AParent;
  DragAcceptFiles(FParent.Handle,true);
  FOldWindowProc:=FParent.WindowProc;
  FParent.WindowProc:=ParentWindowProc;
  FtlmObject:=TtlmObject.Create(self);
end;

destructor TImageDropper.Destroy();
begin
  if Assigned(FtlmObject) then begin
    FreeAndNil(FtlmObject);
  end;
  DragAcceptFiles(FParent.Handle,false);
  FParent.WindowProc:=FOldWindowProc;
  inherited Destroy();
end;

end.

#14

还有好多，但是规模太大了，没法一一给出。。。。

#15

获得Memo、RichEdit的光标位置：
--------------------------------------------------------------------------------

procedure TForm1.Button1Click(Sender: TObject);
var Row, Col : integer;
begin
  Row := SendMessage(Memo1.Handle, EM_LINEFROMCHAR, Memo1.SelStart, 0);
  Col := CustEdit.SelStart - SendMessage(Memo1.Handle, EM_LINEINDEX, -1, 0);
  Edit1.Text:='行,列:'+IntToStr(Row)+','+IntToStr(Col);
end;

#16

//--[Yoyoworks]---------------------------------------------------------------- 
//工程名称：prjPowerFlashPlayer 
//软件名称：iPowerFlashPlayer 
//单元作者：许子健 
//开始日期：2004年03月14日，14:31:16 
//单元功能：用于音量调整的类。 
//-----------------------------------------------------------[SHANGHAi|CHiNA]-- 



Unit untTVolume; 

Interface 

Uses 
  MMSystem, SysUtils; 

Type 
  TVolume = Class(TObject) 
  Private 
    FVolume: LongInt; //存储音量。 
    FIsMute: Boolean; //存储静音值。 
    Procedure SetLeftVolume(Volume: Integer); //设置左声道的音量。 
    Function GetLeftVolume: Integer; //获得左声道的音量。 
    Procedure SetRightVolume(Volume: Integer); //设置右声道的音量。 
    Function GetRightVolume: Integer; //获得右声道的音量。 
    Procedure SetIsMute(IsMute: Boolean); //设置是否静音。 
  Public 
    Constructor Create; 
    Destructor Destroy; Override; 
  Published 
    Property LeftVolume: Integer Read GetLeftVolume Write SetLeftVolume; 
    Property RightVolume: Integer Read GetRightVolume Write SetRightVolume; 
    Property Mute: Boolean Read FIsMute Write SetIsMute; 
  End; 

Implementation 

// ----------------------------------------------------------------------------- 
// 过程名：   TVolume.Create 
// 参数：     无 
// 返回值：   无 
// ----------------------------------------------------------------------------- 

Constructor TVolume.Create; 
Begin 
  Inherited Create; 
  FVolume := 0; 
  FIsMute := False; 
  //初始化变量 
  waveOutGetVolume(0, @FVolume); //得到现在音量 
End; 

// ----------------------------------------------------------------------------- 
// 过程名：   TVolume.Destroy 
// 参数：     无 
// 返回值：   无 
// ----------------------------------------------------------------------------- 

Destructor TVolume.Destroy; 
Begin 
  Inherited Destroy; 
End; 

// ----------------------------------------------------------------------------- 
// 过程名：   TVolume.SetLeftVolume 
// 参数：     Volume: Integer 
// 返回值：   无 
// ----------------------------------------------------------------------------- 

Procedure TVolume.SetLeftVolume(Volume: Integer); 
Begin 
  If (Volume < 0) Or (Volume > 255) Then 
    Raise Exception.Create('Range error of the left channel [0 to 255].'); 
  //如果“Volume”参数不在0至255的范围里，则抛出异常。 

  If FIsMute = False Then 
    Begin 
      waveOutGetVolume(0, @FVolume); 
      //@示指向变量Volume的指针（32位），调用此函数的用意就是得到右声道的值，做到在调节左声道的时候，不改变右声道。 
      FVolume := FVolume And $FFFF0000 Or (Volume Shl 8); //数字前加$表示是十六进制 
      waveOutSetVolume(0, FVolume); 
    End 
      //如果不是静音状态，则改变音量； 
  Else 
    FVolume := FVolume And $FFFF0000 Or (Volume Shl 8); 
  //否则，只改变变量。 

End; 

// ----------------------------------------------------------------------------- 
// 过程名：   TVolume.SetRightVolume 
// 参数：     Volume: Integer 
// 返回值：   无 
// ----------------------------------------------------------------------------- 

Procedure TVolume.SetRightVolume(Volume: Integer); 
Begin 
  If (Volume < 0) Or (Volume > 255) Then 
    Raise Exception.Create('Range error of the right channel [0 to 255].'); 

  If FIsMute = False Then 
    Begin 
      waveOutGetVolume(0, @FVolume); 
      FVolume := FVolume And $0000FFFF Or (Volume Shl 24); 
      waveOutSetVolume(0, FVolume); 
    End 
  Else 
    FVolume := FVolume And $0000FFFF Or (Volume Shl 24); 
End; 

// ----------------------------------------------------------------------------- 
// 过程名：   TVolume.SetIsMute 
// 参数：     IsMute: Boolean 
// 返回值：   无 
// ----------------------------------------------------------------------------- 

Procedure TVolume.SetIsMute(IsMute: Boolean); 
Begin 
  FIsMute := IsMute; 
  If FIsMute = True Then 
    waveOutSetVolume(0, 0) 
  Else 
    waveOutSetVolume(0, FVolume); 
End; 

// ----------------------------------------------------------------------------- 
// 函数名：   TVolume.GetLeftVolume 
// 参数：     无 
// 返回值：   Integer 
// ----------------------------------------------------------------------------- 

Function TVolume.GetLeftVolume: Integer; 
Begin 
  If FIsMute = False Then 
    waveOutGetVolume(0, @FVolume); //得到现在音量 
  Result := Hi(FVolume); //转换成数字 

End; 

// ----------------------------------------------------------------------------- 
// 函数名：   TVolume.GetRightVolume 
// 参数：     无 
// 返回值：   Integer 
// ----------------------------------------------------------------------------- 

Function TVolume.GetRightVolume: Integer; 
Begin 
  If FIsMute = False Then 
    waveOutGetVolume(0, @FVolume); //得到现在音量 
  Result := Hi(FVolume Shr 16); //转换成数字 
End; 

End.

#17

感谢：GreatSuperYoyoNC(幽幽)   tonylk(=www.tonixsoft.com=)
希望其他人能领悟，致用！

#18

感谢，

手头上没有什么值得贴的东西，只能帮顶了

#19

www.yixel.com/files/LexLib.rar
打包了,太多了贴不上来

#20

点击DBGrid的Title对查询结果排序 关键词:DBGrid 排序  

   欲实现点击DBGrid的Title对查询结果排序，想作一个通用程序，不是一事一议，例如不能在SQL语句中增加Order by ...，因为SQL可能原来已经包含Order by ...，而且点击另一个Title时又要另外排序，目的是想作到象资源管理器那样随心所欲。

procedure TFHkdata.SortQuery(Column:TColumn);
var
SqlStr,myFieldName,TempStr: string;
OrderPos: integer;
SavedParams: TParams;
begin
if not (Column.Field.FieldKind in [fkData,fkLookup]) then exit;
if Column.Field.FieldKind =fkData then
   myFieldName := UpperCase(Column.Field.FieldName)
else
   myFieldName := UpperCase(Column.Field.KeyFields);
while Pos(myFieldName,';')<>0 do
myFieldName := copy(myFieldName,1,Pos(myFieldName,';')-1)+ ',' + copy(myFieldName,Pos(myFieldName,';')+1,100);
with TQuery(TDBGrid(Column.Grid).DataSource.DataSet) do
begin
   SqlStr := UpperCase(Sql.Text);
   // if pos(myFieldName,SqlStr)=0 then exit;
   if ParamCount>0 then
   begin
     SavedParams := TParams.Create;
     SavedParams.Assign(Params);
   end;
   OrderPos := pos('ORDER',SqlStr);
   if (OrderPos=0) or (pos(myFieldName,copy(SqlStr,OrderPos,100))=0) then
     TempStr := ' Order By ' + myFieldName + ' Asc'
   else if pos('ASC',SqlStr)=0 then
     TempStr := ' Order By ' + myFieldName + ' Asc'
   else
     TempStr := ' Order By ' + myFieldName + ' Desc';
   if OrderPos<>0 then SqlStr := Copy(SqlStr,1,OrderPos-1);
   SqlStr := SqlStr + TempStr;
   Active := False;
   Sql.Clear;
   Sql.Text := SqlStr;
   if ParamCount>0 then
   begin
     Params.AssignValues(SavedParams);
     SavedParams.Free;
   end;
   Prepare;
   Open;
end;
end;


   去掉DbGrid的自动添加功能 
    
   移动到最后一条记录时再按一下“下”就会追加一条记录，如果去掉这项功能 
   procedure TForm1.DataSource1Change(Sender: TObject; Field: TField);
   begin
     if TDataSource(Sender).DataSet.Eof then TDataSource(Sender).DataSet.Cancel;
   end;


    DBGrid不支持鼠标的上下移动的解决代码自己捕捉WM_MOUSEWHEEL消息处理
private
OldGridWnd : TWndMethod;
procedure NewGridWnd (var Message : TMessage);
public

procedure TForm1.NewGridWnd(var Message: TMessage);
var
IsNeg : Boolean;
begin
if Message.Msg = WM_MOUSEWHEEL then
begin
   IsNeg := Short(Message.WParamHi) < 0;
   if IsNeg then
     DBGrid1.DataSource.DataSet.MoveBy(1)
   else
     DBGrid1.DataSource.DataSet.MoveBy(-1)
end
else
   OldGridWnd(Message);
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
OldGridWnd := DBGrid1.WindowProc ;
DBGrid1.WindowProc := NewGridWnd;
end;      

   dbgrid中移动焦点到指定的行和列   dbgrid是从TCustomGrid继承下来的，它有col与row属性，只不过是protected的，不能直接访问，要处理一下，可以这样：

   TDrawGrid(dbgrid1).row:=row;
   TDrawGrid(dbgrid1).col:=col;
   dbgrid1.setfocus;
就可以看到效果了。

   1 这个方法是绝对有问题的，它会引起DBGrid内部的混乱，因为DBGrid无法定位当前纪录，如果DBGrid只读也就罢了（只读还是会出向一些问题，比如原本只能单选的纪录现在可以出现多选等等，你可以自己去试试），如果DBGrid可编辑那问题就可大了，因为当前纪录的关系，你更改的数据字段很可能不是你想象中的
   2 我常用的解决办法是将上程序改为（随便设置col是安全的，没有一点问题）

   Query1.first;
   TDrawGrid(dbgrid1).col:=1;
   dbgrid1.setfocus;

   这就让焦点移到第一行第一列当中 

    如何使DBGRID网格的颜色随此格中的数据值的变化而变化？   在做界面的时候，有时候为了突出显示数据的各个特性（如过大或者过小等），需要通过改变字体或者颜色，本文就是针对这个情况进行的说明。

   如何使DBGRID网格的颜色随此格中的数据值的变化而变化。如<60的网格为红色？
   Delphi中数据控制构件DBGrid是用来反映数据表的最重要、也是最常用的构件。在应用程序中，如果以彩色的方式来显示DBGrid，将会增加其可视性，尤其在显示一些重要的或者是需要警示的数据时，可以改变这些数据所在的行或列的前景和背景的颜色。
　　DBGrid属性DefaultDrawing是用来控制Cell（网格）的绘制。若DefaultDrawing的缺省设置为True，意思是Delphi使用DBGrid的缺省绘制方法来制作网格和其中所包含的数据，数据是按与特定列相连接的Tfield构件的DisplayFormat或EditFormat特性来绘制的；若将DBGrid的DefaultDrawing特性设置成False，Delphi就不绘制网格或其内容，必须自行在TDBGrid的OnDrawDataCell事件中提供自己的绘制例程（自画功能）。
　　在这里将用到DBGrid的一个重要属性：画布Canvas，很多构件都有这一属性。Canvas代表了当前被显示DBGrid的表面，你如果把另行定义的显示内容和风格指定给DBGrid对象的Canvas，DBGrid对象会把Canvas属性值在屏幕上显示出来。具体应用时，涉及到Canvas的Brush属性和FillRect方法及TextOut方法。Brush属性规定了DBGrid.Canvas显示的图像、颜色、风格以及访问Windows GDI 对象句柄，FillRect方法使用当前Brush属性填充矩形区域，方法TextOut输出Canvas的文本内容。

　　以下用一个例子来详细地说明如何显示彩色的DBGrid。在例子中首先要有一个DBGrid构件，其次有一个用来产生彩色筛选条件的SpinEdit构件，另外还有ColorGrid构件供*选择数据单元的前景和背景的颜色。

　　1.建立名为ColorDBGrid的Project，在其窗体Form1中依次放入所需构件，并设置属性为相应值，具体如下所列：

　　 Table1 DatabaseName: DBDEMOS
    TableName: EMPLOYEE.DB
    Active: True;
　　DataSource1 DataSet: Table1
　　DBGrid1 DataSource1: DataSource1
    DefaultDrawing: False
　　SpinEdit1 Increment:200
    Value: 20000
　　ColorGrid1 GridOrdering: go16＊1

　　2.为DBGrid1构件OnDrawDataCell事件编写响应程序：

//这里编写的程序是<60的网格为红色的情况，其他的可以照此类推
　　procedure TForm1.DBGrid1DrawDataCell(Sender: TObject; const Rect: TRect;Field: TField; State: TGridDrawState);
　　begin
　　 if Table1.Fieldbyname(′Salary′).value<=SpinEdit1.value then
　　 DBGrid1.Canvas.Brush.Color:=ColorGrid1.ForeGroundColor
　　 else
　  　 DBGrid1.Canvas.Brush.Color:=ColorGrid1.BackGroundColor;
　　 DBGrid1.Canvas.FillRect(Rect);
　　 DBGrid1.Canvas.TextOut(Rect.left＋2,Rect.top＋2,Field.AsString);
　　end;

　　这个过程的作用是当SpinEdit1给定的条件得以满足时，如′salary′变量低于或等于SpinEdit1.Value时，DBGrid1记录以ColorGrid1的前景颜色来显示，否则以ColorGrid1的背景颜色来显示。然后调用DBGrid的Canvas的填充过程FillRect和文本输出过程重新绘制DBGrid的画面。

　　3.为SpinEdit1构件的OnChange事件编写响应代码：

　　procedure TForm1.SpinEdit1Change(Sender: TObject);
　　begin
　　 DBGrid1.refresh;  //刷新是必须的，一定要刷新哦
　　end;

　　当SpinEdit1构件的值有所改变时，重新刷新DBGrid1。

　　4.为ColorGrid1的OnChange事件编写响应代码：

　　procedure TForm1.ColorGrid1Change(Sender: TObject);
　　begin
　　 DBGrid1.refresh;    //刷新是必须的，一定要刷新哦
　  end;

　　当ColorGrid1的值有所改变时，即鼠标的右键或左键单击ColorGrid1重新刷新DBGrid1。

　　5.为Form1窗体（主窗体）的OnCreate事件编写响应代码：

　　procedure TForm1.FormCreate(Sender: TObject);
　　begin
　　 ColorGrid1.ForeGroundIndex:=9;
　 　 ColorGrid1.BackGroundIndex:=15;
　end;

　　在主窗创建时，将ColorGrid1的初值设定前景为灰色，背景为白色，也即DBGrid的字体颜色为灰色，背景颜色为白色。

　　6.现在，可以对ColorDBGrid程序进行编译和运行了。当用鼠标的左键或右键单击ColorGrid1时，DBGrid的字体和背景颜色将随之变化。

　　在本文中，只是简单展示了以彩色方式显示DBGrid的原理，当然，还可以增加程序的复杂性，使其实用化。同样道理，也可以将这个方法扩展到其他拥有Canvas属性的构件中，让应用程序的用户界面更加友好。

   
    判断Grid是否有滚动条？这是一个小技巧，如果为了风格的统一的话，还是不要用了。：）

。。。

if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_VSCROLL) <> 0 then
   ShowMessage('Vertical scrollbar is visible!');
if (GetWindowlong(Stringgrid1.Handle, GWL_STYLE) and WS_HSCROLL) <> 0 then
   ShowMessage('Horizontal scrollbar is visible!');

。。。 

#21

想问一个问题:如何得到局域网内的sql server服务器列表,供选择.

#22

{=================================================================  
功  能:  返回网络中SQLServer列表  
参  数:  
List:  需要填充的List  
返回值:  成功:  True,并填充List  失败  False  
=================================================================}  
Function  GetSQLServerList(var  List:  Tstringlist):  boolean;  
var  
 i:  integer;  
 SQLServer:  Variant;  
 ServerList:  Variant;  
begin  
   Result  :=  False;  
   List.Clear;  
   try  
     SQLServer  :=  CreateOleObject('SQLDMO.Application');  
     ServerList  :=  SQLServer.ListAvailableSQLServers;  
     for  i  :=  1  to  Serverlist.Count  do  
         list.Add  (Serverlist.item(i));  
     Result  :=  True;  
   Finally  
     SQLServer  :=null;  
     ServerList  :=null;  
   end;  
end;  

#23

to shepengtao(爱花) 
不是我写的，转贴。。



如何获取局域网中的所有 SQL Server 服务器

文献参考来源：Delphi 深度探索

我一直想在我的应用程序中获得关于 SQL Server 更详细的信息。直到最近利用 SQLDMO(SQL Distributed Management Objects) 才得以实现这个想法。SQLDMO 提供了非常强大的功能，我们几乎可以利用程序实现任何 SQL Server 拥有的功能。在这篇文章中我将向您展示如何得到局域网中所有 SQL Servers 服务器、如何连接、如何获得服务器中的所有数据库。

SQLDMO 对像来自 SQL Server 2000 提供的动态连接库 SQLDMO.dll。  这个 dll 本身是一个 COM 对像，首先你必须从类型库中引用Microsoft SQLDMO Object Library (Version 8.0). Delphi 会自动为你生成SQLDMO_TLB.PAS文件,文件中包括了所有 COM 对象的接口。

 
 

在这里我们需要注意，由于引入的SQLDMO “TDatabase”和 “TApplication”和其它几个缺省类名与 Delphi 自带的类名冲突，所以自己可以修改成 _TypeName 的形式。或者其它的名字，我在这里改成 T_Application 、T_Database 等。

我们下一步要做的是在我们的程序中引入单元文件 SQLDMO_TLB.PAS 。 应用程序单元名称是 SqlServers 

程序运行界面如下：

 


服务器列表中是局域网中所有的 SQL SERVER 服务器,选择服务器后输入用户名和密码，下拉数据库列表，程序会列出此服务器中的所有数据库.

程序源代码如下：

unit SqlServers;

interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

  StdCtrls, Buttons, ComCtrls , SQLDMO_TLB;//注意别忘了引入此文件

type

  TdmoObject = record

    SQL_DMO    : _SQLServer;

    lConnected : boolean;

  end;

 

type

  TFormServersList = class(TForm)

    Label1: TLabel;

    Label2: TLabel;

    CB_ServerNames: TComboBox;

    CB_DataNames: TComboBox;

    Label3: TLabel;

    Label4: TLabel;

    Ed_Login: TEdit;

    Ed_Pwd: TEdit;

    BitBtn1: TBitBtn;

    BitBtn2: TBitBtn;

    procedure FormCreate(Sender: TObject);

    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

    procedure FormClose(Sender: TObject; var Action: TCloseAction);

    procedure FormShow(Sender: TObject);

    procedure BitBtn2Click(Sender: TObject);

    procedure CB_DataNamesDropDown(Sender: TObject);

  private

    server_Names : TStringList;

    //对象集合   

    PdmoObject : array of TdmoObject;

    //获取所有的远程服务器

    Function GetAllServers(ServerList : TStringList) : Boolean;

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  FormServersList: TFormServersList;

implementation

 

{$R *.DFM}

 

{ TForm1 }

 

Function TFormServersList.GetAllServers(ServerList : TStringList) : Boolean;

var

  sApp : _Application ;

  sName : NameList;

  iPos : integer;

begin

  Result := True ;

  try

    sApp := CoApplication_.Create ; //创建的对象不用释放，delphi 自己会释放

    sName := sApp.ListAvailableSQLServers;

  except

    Result := False;

    Exit;

  end;

  if sName.Count > 0 then // 之所以　iPos 从１开始,是因为0 位置为空值即 ' '

  for iPos := 1 to sName.Count - 1 do

  begin

    CB_ServerNames.Items.Add(sName.Item(iPos));

    ServerList.Add(sName.Item(iPos));

  end;

end;

 

procedure TFormServersList.FormCreate(Sender: TObject);

var

  lcv : integer;

begin

  server_Names := TStringList.Create;

  if not GetAllServers(server_Names) then

  begin

    Application.MessageBox('无法获取服务器列表,可能缺少客户端DLL库函数','错误提示',MB_OK);

    exit;

  end;

  for lcv := 0 to server_Names.Count - 1 do

  begin

    SetLength(PdmoObject,lcv + 1);

    with PdmoObject[lcv] do

    begin

      SQL_DMO := CoSQLServer.Create;

      SQL_DMO.Name := Trim(server_Names[lcv]);

      //登陆安全属性，NT 身份验证

      SQL_DMO.LoginSecure := false;

      // 设置一个连接超时

      SQL_DMO.LoginTimeout := 3;

      //自动重新登陆，如果第一次失败后

      SQL_DMO.AutoReconnect := true;

      SQL_DMO.ApplicationName := server_Names[lcv];

      lConnected := false;

    end;

  end;

end;

 

procedure TFormServersList.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

  server_Names.Free;

end;

 

procedure TFormServersList.FormClose(Sender: TObject; var Action: TCloseAction);

begin

  Action := CaFree;

end;

 

procedure TFormServersList.FormShow(Sender: TObject);

begin

  if CB_ServerNames.Items.Count > 0 then //列举所有服务器名字

    CB_ServerNames.Text := CB_ServerNames.Items.Strings[0];

end;

 

procedure TFormServersList.BitBtn2Click(Sender: TObject);

begin

  Close ;

end;

 

procedure TFormServersList.CB_DataNamesDropDown(Sender: TObject);

var

  icount ,Server_B : integer;

begin

  CB_DataNames.Clear;

  Screen.Cursor := CrHourGlass;

  Server_B := CB_ServerNames.Items.IndexOf(CB_ServerNames.Text) ;

  with PdmoObject[Server_B].SQL_DMO do

  begin

    if not PdmoObject[Server_B].lConnected then

    try

      Connect(Name,Trim(Ed_Login.Text),Trim(Ed_Pwd.Text));

    except

      Screen.Cursor := CrDefault ;

      Application.MessageBox('请检查用户名或密码是否正确','连接失败',MB_OK);

      Exit ;

    end;

    if not VerifyConnection(SQLDMOConn_ReconnectIfDead) then

    begin

      ShowMessage('在试图连接到SQL SERVER 2000 时出现错误' + #10#13 +

                             '确信是否加在了动态连接库SQLDMO.DLL');

      exit;

    end else

      PdmoObject[Server_B].lConnected := True ;

    Databases.Refresh(true);

    for icount := 1 to Databases.Count do

      CB_DataNames.Items.Add(Databases.Item(icount,null).name);

  end;

  Screen.Cursor := CrDefault ;

end

end.

#24

好帖，顶

#25

UP

#26

狂顶,我有好的东西一定会贴上来.

#27

一个使用了OpenGL的3D空间浏览程序。
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,OpenGL,
  ExtCtrls, StdCtrls, Buttons,math;

type
  TGLPoint3D=packed array[0..2] of GLFloat;
  TPoint3D=record
     x,y,z:Integer;
     color:Integer;
     end;
  TLine*=record
       TestLines:array[0..1] of Integer;
       MaxX,MinX:GLFloat;
       TestK,TestS:GLFloat;
       end;
  TPGLPoint3D=^TGLPoint3D;
  T3DObject=packed record
     ID:Integer;
     x,y,z,Orientx,Orienty,Orientz:Real;
     PointsNum:Integer;
     *sNum:Integer;
     *s:array of TLine*;
     Points:array of TGLPoint3D;
  end;
  TP3DObject=^T3DObject;
  TPerson=record
     orientx,orienty,orientz:Real;
     oldp,newp:TGLPoint3D;
  end;
  TForm1 = class(TForm)
    Timer1: TTimer;
    Panel1: TPanel;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Panel1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure Panel1Resize(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    DC:HDC;
    hglrc:HGLRC;
    mdx,mdy:Integer;
    numofpoints:Integer;
    points:array[0..$ffff] of TPoint3D;
    person:TPerson;
    objs:array[0..100] of T3DObject;
    procedure InitOpenGL;
    procedure UninitOpenGL;
    procedure DrawPic;
    procedure DrawPic2;
    procedure DrawObject(pObj:TP3DObject);
    procedure InitObjects;
    function Test*(pObj:TP3DObject;var p1,p2:TGLPoint3D):Boolean;
  end;

const MaxWidth=300.0;MaxHeight=300.0;MaxDepth=300.0;
      LeftKey=37;
      UpKey=37;
      RightKey=37;
      DownKey=37;
      ps:packed array[0..3] of TGLPoint3D=((0.0,0.0,0.0),(0.0,1.0,0.0),(-5.0,0.0,0.0),(-5.0,1.0,0.0));
var
  Form1: TForm1;


implementation

{$R *.DFM}

procedure TForm1.InitOpenGL;
var
     pfd:PIXELFORMATDESCRIPTOR;
     pf:Integer;
begin
     with pfd do
     begin
          nSize:=sizeof(PIXELFORMATDESCRIPTOR);
          nVersion:=1;
          dwFlags:= PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL
or PFD_DOUBLEBUFFER;
          iPixelType:= PFD_TYPE_RGBA;
          cColorBits:= 24;
          cRedBits:= 0;
          cRedShift:= 0;
          cGreenBits:= 0;
          cGreenShift:= 0;
          cBlueBits:= 0;
          cBlueShift:= 0;
          cAlphaBits:= 0;
          cAlphaShift:= 0;
          cAccumBits:=0;
          cAccumRedBits:= 0;
          cAccumGreenBits:= 0;
          cAccumBlueBits:= 0;
          cAccumAlphaBits:= 0;
          cDepthBits:= 32;
          cStencilBits:= 0;
          cAuxBuffers:= 0;
          iLayerType:= PFD_MAIN_PLANE;
          bReserved:= 0;
          dwLayerMask:= 0;
          dwVisibleMask:= 0;
          dwDamageMask:= 0;
  end;
     DC:=GetWindowDC(Panel1.Handle);
pf:=ChoosePixelFormat(DC,@pfd);
SetPixelFormat(DC,pf,@pfd);
hglrc:=wglCreateContext(DC);
     wglMakeCurrent(DC,hglrc);
     glMatrixMode(GL_PROJECTION);
     glLoadIdentity;
     glEnable(GL_DEPTH_TEST);
end;

procedure TForm1.UninitOpenGL;
begin
if hglrc<>0 then wglDeleteContext(hglrc);

end;

procedure TForm1.FormCreate(Sender: TObject);
begin
     person.orientx :=0;
     person.orienty :=0;
     person.orientz :=0;
     person.newp[0]:=0.0;
     person.newp[1]:=1.2;
     person.newp[2]:=-5.0;
     person.oldp[0]:=0.0;
     person.oldp[1]:=1.2;
     person.oldp[2]:=0.0;
     InitObjects;
     InitOpenGL;
end;

procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
     UninitOpenGL;
end;


procedure TForm1.DrawPic;
var
     i:Integer;
begin
     glClear(GL_COLOR_BUFFER_BIT);
     glBegin(GL_POINTS);
     for i:=0 to numofpoints-1 do
     begin
          glColor3ubv(@(points[i].color));
          glVertex3d(points[i].x/MaxWidth,points[i].y/MaxHeight,points[i].z/MaxDepth);
     end;
     glEnd;
     glEnable(GL_DEPTH_TEST);
     glClear(GL_DEPTH_BUFFER_BIT);
     glFlush;
     SwapBuffers(DC);
end;

#28

procedure TForm1.Panel1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
     mdx:=X;
     mdy:=Y;
end;


procedure TForm1.DrawPic2;
const MaxX=90.0;
      MinX=-90.0;
      MaxZ=90.0;
      MinZ=-90.0;
      StepX=(MaxX-MinX)/100;
      StepZ=(MaxZ-MinZ)/100;
var
     i:Real;
     gp:GLUquadricObj;
     j:Integer;
begin
     glClearColor(0.0,0.0,0.0,0.0);
     glClear(GL_COLOR_BUFFER_BIT);
     glColor3f(1.0,1.0,0.0);
     glPushMatrix;
     gp:=gluNewQuadric;
     gluQuadricDrawStyle(gp,GLU_LINE);
     glTranslatef(0.0,1.0,0.0);
     gluSphere(gp,0.8,20,20);
     glTranslatef(10.0,0.0,0.0);
     gluCylinder(gp,1.0,0.6,1.2,20,10);
     gluDeleteQuadric(gp);
     glPopMatrix;
     glColor3f(1.0,1.0,1.0);
     glBegin(GL_LINES);
     i:=MinX;
     while i<MaxX do
     begin
          glVertex3d(i,0,MinZ);
          glVertex3d(i,0,MaxZ);
          i:=i+StepX;
     end;
     i:=MinZ;
     while i<MaxZ do
     begin
          glVertex3d(MinX,0,i);
          glVertex3d(MaxX,0,i);
          i:=i+StepZ;
     end;
     glEnd;
     glBegin(GL_QUAD_STRIP);
     for j:=0 to 3 do
     begin
          glVertex3f(ps[j,0],ps[j,1],ps[j,2]);
     end;
     glEnd;
     DrawObject(@objs[0]);
     SwapBuffers(DC);
end;

procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
const
     StepA=0.8;
var
     ca,cr:Real;
     thenewp:TGLPoint3D;
begin
     ca:=0;
     cr:=0;
     case Key of
          38:
               cr:=0.1;
          40:
               cr:=-0.1;
          37:
               ca:=-StepA;
          39:
               ca:=StepA;
          13:
      end;
      person.orienty:=person.orienty+ca;
      person.oldp[0]:=person.newp[0];
      person.oldp[2]:=person.newp[2];
      thenewp[0]:= person.newp[0]+cr*sin(DegToRad(person.orienty));
      thenewp[2]:= person.newp[2]+cr*cos(DegToRad(person.orienty));
      if thenewp[0]>80 then thenewp[0]:=80;
      if thenewp[2]>80 then thenewp[2]:=80;
      if thenewp[0]<-80 then thenewp[0]:=-80;
      if thenewp[2]<-80 then thenewp[2]:=-80;
//      if not Test*(@objs[0],person.oldp,thenewp) then
      begin
           person.newp[0]:=thenewp[0];
           person.newp[2]:=thenewp[2];
           wglMakeCurrent(DC,hglrc);
           glMatrixMode(GL_PROJECTION);
           glLoadIdentity;
           gluPerspective(45.0,1.0,0.01,40.0);
           glRotatef(person.orientz,0.0,0.0,1.0);
           glRotatef(person.orientx,1.0,0.0,0);
           glRotatef(person.orienty,0.0,1.0,0);
           glTranslatef(-person.newp[0],-person.newp[1],person.newp[2]);
           glClear(GL_DEPTH_BUFFER_BIT);
           DrawPic2;
      end;
end;

procedure TForm1.Panel1Resize(Sender: TObject);
var
     a:Word;
begin
     a:=13;
     glViewPort(0,0,Panel1.Width,Panel1.Height);
     FormKeyDown(Sender,a,[]);
end;

procedure TForm1.DrawObject(pObj: TP3DObject);
var
     i:Integer;
begin
     case pObj^.ID of
     100:
     begin
          glBegin(GL_QUAD_STRIP);
          for i:=0 to pObj^.PointsNum-1 do
          begin
               glVertex3f(pObj^.Points[i,0],pObj^.Points[i,1],pObj^.Points[i,2]);
          end;
          glEnd;
     end;
     200:;
     300:;
     400:;
     end;
end;

procedure TForm1.InitObjects;
var
     k:GLFloat;
begin
     objs[0].ID:=100;
     objs[0].x:=0.0;
     objs[0].y:=0.0;
     objs[0].z:=0.0;
     objs[0].PointsNum :=4;
     objs[0].*sNum :=1;
     GetMem(objs[0].*s,SizeOf(TLine*));
     objs[0].*s[0].TestLines[0]:=0;
     objs[0].*s[0].TestLines[1]:=2;
     GetMem(objs[0].Points,SizeOf(ps));
     CopyMemory(Objs[0].Points,@ps,SizeOf(ps));
     k:=(objs[0].Points[objs[0].*s[0].TestLines[0],2]-objs[0].Points[objs[0].*s[0].TestLines[1],2])/(objs[0].Points[objs[0].*s[0].TestLines[0],0]-objs[0].Points[objs[0].*s[0].TestLines[1],0]);
     objs[0].*s[0].TestK:=k;
     objs[0].*s[0].TestS:=-objs[0].Points[objs[0].*s[0].TestLines[0],0]*k+objs[0].Points[objs[0].*s[0].TestLines[0],2];
     if objs[0].Points[objs[0].*s[0].TestLines[0],0]>objs[0].Points[objs[0].*s[0].TestLines[1],0] then
     begin
          objs[0].*s[0].MaxX:=objs[0].Points[objs[0].*s[0].TestLines[0],0];
          objs[0].*s[0].MinX:=objs[0].Points[objs[0].*s[0].TestLines[1],0];
     end
     else
     begin
          objs[0].*s[0].MaxX:=objs[0].Points[objs[0].*s[0].TestLines[1],0];
          objs[0].*s[0].MinX:=objs[0].Points[objs[0].*s[0].TestLines[0],0];
     end;
end;

function TForm1.Test*(pObj: TP3DObject;var p1,p2:TGLPoint3D): Boolean;
var
     MaxX,MinX,k:GLFloat;
begin
     if p1[0]>p2[0] then
     begin
          MaxX:=p1[0];
          MinX:=p2[0];
     end
     else
     begin
          MaxX:=p2[0];
          MinX:=p1[0];
     end;
     if MinX>pObj^.*s[0].MaxX then
          Result:=False
     else
     begin
         if pObj^.*s[0].MinX>MinX then
                    Result:=False
          else
          begin
               k:=(p1[2]-p2[2])/(p1[0]-p2[0]);
               MinX:=Max(MinX,pObj^.*s[0].MinX);
               MaxX:=Min(MaxX,pObj^.*s[0].MaxX);
               Result:=((k*(MaxX-p1[0])-MaxX*pObj^.*s[0].TestK+p1[2]+pObj^.*s[0].TestS)*(k*(MinX-p1[0])-MinX*pObj^.*s[0].TestK+p1[2]+pObj^.*s[0].TestS)<0);
          end;
     end;
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
     key:Word;
begin
     key:=13;
     FormKeyDown(Sender,key,[]);
end;

end.

#29

太多东西! 真的会消化不良!　：）

#30

MARK

#31

好贴，虽然看不懂

#32

“磁性”窗口
 
 

Winamp的用户都知道，Winamp的播放列表或均衡器在被移动的时候，仿佛会受到一股磁力，每当靠近主窗口时就一下子被“吸附”过去，自动沿边对齐。我想让我的Winamp插件也具备这种奇妙特性，于是琢磨出了一种“磁化”窗口的方法。该法适用于Delphi的各个版本。为了演示这种技术，请随我来制作一个会被Winamp“吸引”的样板程序。
　　先新建一应用程序项目，把主窗口Form1适当改小些，并将BorderStyle设为bsNone。放一个按钮元件，双击它并在OnClick事件中写“Close;”。待会儿就按它来结束程序。现在切换到代码编辑区，定义几个全局变量。
　　var
　　 Form1: TForm1; //“磁性”窗口
　　 LastX, LastY: Integer; //记录前一次的坐标
　　 WinampRect:Trect; //保存Winamp窗口的矩形区域
　　 hwnd_Winamp:HWND; //Winamp窗口的控制句柄
　　接着编写Form1的OnMouseDown和OnMouseMove事件。
　　procedure TForm1.FormMouseDown(Sender: Tobject; Button: TMouseButton;
　　 Shift: TShiftState; X, Y: Integer);
　　const
　　 ClassName=‘Winamp v1.x’; //Winamp主窗口的类名
　　 //如果改成ClassName=‘TAppBuilder’，你就会发现连Delphi也有引力啦！
　　begin
　　//记录当前坐标
　　LastX := X;
　　LastY := Y;
　　//查找Winamp
　　hwnd_Winamp := FindWindow(ClassName,nil);
　　if hwnd_Winamp>0 then //找到的话，记录其窗口区域
　　GetWindowRect(hwnd_Winamp, WinampRect);
　　end;
　　procedure TForm1.FormMouseMove(Sender: Tobject; Shift: TShiftState; X,
　　 Y: Integer);
　　var
　　 nLeft,nTop:integer; //记录新位置的临时变量
　　begin
　　//检查鼠标左键是否按下
　　 if HiWord(GetAsyncKeyState(VK_LBUTTON)) > 0 then
　　 begin
　　 //计算新坐标
　　 nleft := Left ＋ X － LastX;
　　 nTop := Top ＋ Y － LastY;
　　 //如果找到Winamp，就修正以上坐标，产生“磁化”效果
　　 if hwnd_Winamp>0 then
　　 Magnetize(nleft,ntop);
　　 //重设窗口位置
　　 SetBounds(nLeft,nTop,width,height);
　　 end;
　　end;
　　别急着，看Magnetize()过程，先来了解一下修正坐标的原理。根据对Winamp实现效果的观察，我斗胆给所谓“磁化”下一个简单的定义，就是“在原窗口与目标窗口接近到某种预定程度，通过修正原窗口的坐标，使两窗口处于同一平面且具有公共边的过程”。依此定义，我设计了以下的“磁化”步骤。第一步，判断目标窗口(即Winamp)和我们的Form1在水平及垂直方向上的投影线是否重叠。“某方向投影线有重叠”是“需要进行坐标修正”的必要非充分条件。判断依据是两投影线段最右与最左边界的差减去它们宽度和的值的正负。第二步，判断两窗口对应边界是否靠得足够近了。肯定的话就让它们合拢。
　　好了，下面便是“神秘”的Magnetize过程了……
　　procedure TForm1.Magnetize(var nl,nt:integer);
　　 //内嵌两个比大小的函数
　　 function Min(a,b:integer):integer;
　　 begin
　　 if a>b then result:=b else result:=a;
　　 end;
　　 function Max(a,b:integer):integer;
　　 begin
　　 if a 　　 end;
　　var
　　 H_Overlapped,V_Overlapped:boolean; //记录投影线是否重叠
　　 tw,ww,wh:integer; //临时变量
　　const
　　 MagneticForce:integer=50; //“磁力”的大小。
　　 //准确的说，就是控制窗口边缘至多相距多少像素时需要修正坐标
　　 //为了演示，这里用一个比较夸张的数字――50。
　　 //一般可以用20左右，那样比较接近Winamp的效果
　　begin
　　//判断水平方向是否有重叠投影
　　ww := WinampRect.Right－WinampRect.Left;
　　tw := Max(WinampRect.Right,nl＋Width)－Min(WinampRect.Left,nl);
　　H_Overlapped := tw<=(Width＋ww);
　　//再判断垂直方向
　　wh := WinampRect.Bottom－WinampRect.Top;
　　tw := Max(WinampRect.Bottom,nt＋Height)－Min(WinampRect.Top,nt);
　　V_Overlapped := tw<=(Height＋wh);
　　//足够接近的话就调整坐标
　　if H_Overlapped then
　　 begin
　　 if Abs(WinampRect.Bottom－nt) 　　 
else if Abs(nt＋Height－WinampRect.Top) 　　 
end;
　　if V_Overlapped then
　　 begin
　　 if Abs(WinampRect.Right－nl) 　　 
else if Abs(nl＋Width－WinampRect.Left) 　　 
end;
　　end;
　　怎么样？运行后效果不错吧！

#33

to:ayukowa(很爱一个人) 
有同感，大家还是贴一点短小精悍的吧！ ：）

#34

//我再来一个:
//移动无标题栏窗口
//在Form1的“Private”部分声明过程：
procedure wmnchittest(var msg:twmnchittest);message wm_nchittest;
//在程序部分加入以下代码：
procedure TForm1.wmnchittest(var msg:twmnchittest);
begin
  inherited;
  if (htclient=msg.result) then msg.result:=htcaption;
end;

#35

up,hehe

#36

up
不过没什么有新意的东西，上面的基本上都是一些很简单的技巧或者在本版faq、大富翁离线数据库或者Delphi超级猛料等里面找得到

#37

mark

#38

哪位有关于多文件一起压缩和解压缩的代码？

#39

Procedure TForm1.FormCreate(Sender: TObject);
Begin
  Form1.Top := Screen.Height;
  Form1.Left := Screen.Width - Form1.Width;
  SysTmrTimer.Enabled := True;
End;

Procedure TForm1.SysTmrTimerTimer(Sender: TObject);//SysTmrTimer是个Timer
Begin
  //请将Interval属性设为10…
  Form1.Top := Form1.Top - 1;
  If Form1.Top = Screen.Height - Form1.Height Then
    SysTmrTimer.Enabled := False;
End;

End.

#40

上面那个是我刚刚写的……

#41

//将一个字符串转换成日期格式，如果转换失败，抛出异常
//参数如：04年1月、04-1、04/1/1、04.1.1
//返回值：2004-1-1
function ToDate(aDate: WideString): TDateTime;
var
  y, m, d, tmp: String;
  i, kind: integer;
  token: WideChar;
  date: TDateTime;
begin
  kind:= 0;
  for i:= 1 to length(aDate) do
  begin
    token:= aDate[i];
    if (ord(token) >= 48) and (ord(token) <= 57) then
    begin
      tmp:= tmp + token;
    end else
    begin
      case kind of
        0: y:= tmp;
        1: m:= tmp;
        2: d:= tmp;
      end;
      tmp:= '';
      inc(kind);
    end;
  end;
  if tmp <> '' then
  begin
    case kind of
      1: m:= tmp;
      2: d:= tmp;
    end;
  end;
  if d = '' then d:= '1';
  if TryStrToDate(y+'-'+m+'-'+d, date) then
    result:= date
  else
    raise Exception.Create('无效的日期格式：' + aDate);
end;

#42

可以收藏.

#43

//当你做数据导入导出的时候，最好还是用这个，呵呵
//不然，你会倒霉的。
procedure IniDateFormat(ChangeSystem: Boolean = False);
//Initialize the DatetimeFormat
//If ChangeSystem is True the system configuration will be changed
//else only change the program configuration
//Copy Right 549@11:03 2003-9-1
begin
  //--Setup user DateSeparator
  DateSeparator := '-';
  ShortDateFormat := 'yyyy-M-d';

  if not ChangeSystem then Exit;

  //--Setup System DateSeparator
  SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SDATE, '-');
  SetLocaleInfo(LOCALE_SLONGDATE, LOCALE_SSHORTDATE, 'yyyy-M-d');
end;

#44

//试试这个效果如何：P
procedure AlignCtrls(Controls: array of TControl; IsHorizontal: Boolean = True);
//Align the TControls horizontal or vercial space equally
//Use this procedure in FormResize
//Copy Right 549@17:53 2004-1-24
var
  Cnt: Integer;
  AllCtrlWidth: Integer;
  AllCtrlHeight: Integer;
  SpaceWidth: Integer;
  SpaceHeight: Integer;
  Count: Integer;
  Parent: TWinControl;
begin
  Count := Length(Controls);
  if Count = 0 then Exit;
  Parent := Controls[0].Parent;
  AllCtrlWidth := 0;
  AllCtrlHeight := 0;
  for Cnt := 0 to Count - 1 do begin//&frac14;&AElig;&Euml;&atilde;Controls×&Uuml;&iquest;í&para;&Egrave;&ordm;&Iacute;&cedil;&szlig;&para;&Egrave;
    AllCtrlWidth := AllCtrlWidth + Controls[Cnt].Width;
    AllCtrlHeight := AllCtrlHeight + Controls[Cnt].Height;
  end;

  if Parent.Width > AllCtrlWidth then//&frac14;&AElig;&Euml;&atilde;Controls&Ouml;&reg;&frac14;&auml;&micro;&Auml;&iquest;í&para;&Egrave;
    SpaceWidth := (Parent.Width - AllCtrlWidth) div (Count + 1)
  else
    SpaceWidth := 0;

  if Parent.Height > AllCtrlHeight then//&frac14;&AElig;&Euml;&atilde;Controls&Ouml;&reg;&frac14;&auml;&micro;&Auml;&cedil;&szlig;&para;&Egrave;
    SpaceHeight := (Parent.Height - AllCtrlHeight) div (Count + 1)
  else
    SpaceHeight := 0;

  if IsHorizontal then
    for Cnt := 0 to Count - 1 do//&acute;&brvbar;&Agrave;íControls&Euml;&reg;&AElig;&frac12;&Icirc;&raquo;&Ouml;&Atilde;
      if Cnt > 0 then
        Controls[Cnt].Left := Controls[Cnt - 1].Left + Controls[Cnt - 1].Width +
                              SpaceWidth
      else
        Controls[Cnt].Left := SpaceWidth
  else
    for Cnt := 0 to Count - 1 do//&acute;&brvbar;&Agrave;íControls&acute;&sup1;&Ouml;±&Icirc;&raquo;&Ouml;&Atilde;
      if Cnt > 0 then
        Controls[Cnt].Top := Controls[Cnt - 1].Top + Controls[Cnt - 1].Height +
                             SpaceHeight
      else
        Controls[Cnt].Top := SpaceHeight;
end;

#45

up

#46

up

#47

up up

#48

to：楼主：ShowMessage(‘注册码不正确,无法注册‘);
注册的时候最好别出现这样的提示，比较容易跟踪和破解！！

#49

procedure TForm1.FormCreate(Sender: TObject);
begin
AnimateWindow(Handle,500,AW_CENTER);//啟動時以0.5秒速度顯示窗體;
end;

#50

procedure TForm1.FormCreate(Sender: TObject);
begin
  AnimateWindow(Handle,500,AW_BLEND);
{ 动画显示窗体^_^
  AW_HOR_POSITIVE = $00000001;
  AW_HOR_NEGATIVE = $00000002;
  AW_VER_POSITIVE = $00000004;
  AW_VER_NEGATIVE = $00000008;
  AW_CENTER = $00000010;
  AW_HIDE = $00010000;
  AW_ACTIVATE = $00020000;
  AW_SLIDE = $00040000;
  AW_BLEND = $00080000;
}
end;