小氓男№部落-网吧专用游戏管理平台


5月16日更新
下载地址:
管理平台下载[带皮肤版]       管理平台下载[无皮肤，可以自己下载安装。] 皮肤下载

--------------------------------------------------------------------------------



分类: DELPHI代码预览模式: 普通 | 列表

form变身五法

作者:小氓男 日期:2010-06-28

你是不是厌倦了平时的form，不用担心我们可以利用winapi函数来改变它的模样。
1、使窗体没有边框
在form的create事件中
var
windowstyle:longint;

查看更多...

分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 79

自绘ListBox的两种效果

作者:小氓男 日期:2010-06-19

　本文利用Listbox自绘实现了两种特殊效果（见图），左边的风格是自己突然灵感触发想到的，右边的风格来自＂C++ Builder 研究＂的一个帖子，老妖用BCB实现了，这里则用Delphi实现它。


演示图片：
自绘ListBox的效果


 


//--------------------------------------------------------------------------

unit DrawListItem;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ImgList, jpeg, ExtCtrls;

type
TForm1 = class(TForm)
lsbRight: TListBox;
ImageList1: TImageList;
StaticText1: TStaticText;
lsbLeft: TListBox;
imgHouse: TImage;
imgHouseGray: TImage;
procedure FormCreate(Sender: TObject);
procedure lsbRightDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
procedure lsbRightClick(Sender: TObject);
procedure FormShow(Sender: TObject);
procedure lsbLeftDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
private

public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.dfm}

{========================================================================
  DESIGN BY :  彭国辉
  DATE:        2004-11-29
  SITE:        http://kacarton.yeah.net/
  BLOG:        http://blog.csdn.net/nhconch
  EMAIL:       kacarton#sohu.com

  文章为作者原创，转载前请先与本人联系，转载请注明文章出处、保留作者信息，谢谢支持！
=========================================================================}

procedure TForm1.FormCreate(Sender: TObject);
var
i: integer;
begin
  lsbRight.Style := lbOwnerDrawFixed;
  lsbRight.Ctl3D := false;
  lsbRight.ItemHeight := 50;
  lsbRight.Items.Add('C++ Builder 研究 致力于BCB的学习探讨和研究'#13'ccrun(老妖)');
  lsbRight.Items.Add('编程手札 My Developer Knowledge Base'#13'http://blog.csdn.net/nhconch'#13'天蝎蝴蝶');
  for i:=3 to 10 do begin
    lsbRight.Items.Add('ListBox Items of ' + IntTostr(i) + #13'Second of '
    + IntToStr(i) + #13'Third of ' + IntToStr(i));
  end;
  
  lsbLeft.Style := lbOwnerDrawFixed;
  lsbLeft.Ctl3D := false;
  lsbLeft.ItemHeight := 90;
  lsbLeft.Items.Add('编程手札');
  lsbLeft.Items.Add('My Developer Knowledge Base');
  lsbLeft.Items.Add('站长:天蝎蝴蝶');
  lsbLeft.Items.Add('http://blog.csdn.net/nhconch');
end;

procedure TForm1.lsbRightDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
strTemp: String;
begin
  //文字颜色
    lsbRight.Canvas.Font.Color := clBlack;
  //设置背景颜色并填充背景
    lsbRight.Canvas.Brush.Color := clWhite;
  lsbRight.Canvas.FillRect (Rect);
  //设置圆角矩形颜色并画出圆角矩形
    lsbRight.Canvas.Brush.Color := TColor($00FFF7F7);
  lsbRight.Canvas.Pen.Color := TColor($00131315);
  lsbRight.Canvas.RoundRect(Rect.Left + 3, Rect.Top + 3,
  Rect.Right - 2, Rect.Bottom - 2, 8, 8);
  //以不同的宽度和高度再画一次，实现立体效果
    lsbRight.Canvas.RoundRect(Rect.Left + 3, Rect.Top + 3,
  Rect.Right - 3, Rect.Bottom - 3, 5, 5);
  //如果是当前选中项
    if(odSelected in State) then
  begin
    //以不同的背景色画出选中项的圆角矩形
        lsbRight.Canvas.Brush.Color := TColor($00FFB2B5);
    lsbRight.Canvas.RoundRect(Rect.Left + 3, Rect.Top + 3,
    Rect.Right - 3, Rect.Bottom - 3, 5, 5);
    //选中项的文字颜色
        lsbRight.Canvas.Font.Color := clBlue;
    //如果当前项拥有焦点，画焦点虚框，当系统再绘制时变成XOR运算从而达到擦除焦点虚框的目的
        if(odFocused in State) then DrawFocusRect(lsbRight.Canvas.Handle, Rect);
  end;
  //画出图标
    ImageList1.Draw(lsbRight.Canvas, Rect.Left + 7,
  Rect.top + (lsbRight.ItemHeight - ImageList1.Height) div 2, Index, true);
  //分别绘出三行文字
    strTemp := lsbRight.Items.Strings[Index];
  lsbRight.Canvas.TextOut(Rect.Left + 32 + 10, Rect.Top + 4
  , Copy(strTemp, 1, Pos(#13, strTemp)-1));
  strTemp := Copy(strTemp, Pos(#13, strTemp)+1, Length(strTemp));
  lsbRight.Canvas.TextOut(Rect.Left + 32 + 10, Rect.Top + 18,
  Copy(strTemp, 1, Pos(#13, strTemp)-1));
  lsbRight.Canvas.TextOut(Rect.Left + 32 + 10, Rect.Top + 32,
  Copy(strTemp, Pos(#13, strTemp)+1, Length(strTemp)));
end;

procedure TForm1.lsbRightClick(Sender: TObject);
begin
  StaticText1.Caption := ' ' + lsbRight.Items.Strings[lsbRight.ItemIndex];
end;

procedure TForm1.FormShow(Sender: TObject);
begin
  lsbRight.ItemIndex := 0;
  lsbRight.Repaint();
  
  lsbLeft.ItemIndex := 0;
  lsbLeft.Repaint();
end;

procedure TForm1.lsbLeftDrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
r: TRect;
begin
  with lsbLeft.Canvas do begin
      //设置填充的背景颜色并填充背景
        Brush.Color := clWhite;
      FillRect (Rect);
      //绘制圆角矩形
        if (odSelected in State) then   //选中项的圆角矩形颜色
            Pen.Color := $FFB2B5
      else                            //未选中项的圆角矩形颜色
            Pen.Color := clSilver;
      Brush.Style := bsClear;
      SetRect(r, Rect.Left+3, Rect.Top+3, Rect.Right-3, Rect.Bottom-3);
      RoundRect(r.Left, r.Top, r.Right, r.Bottom, 10, 10);
      //画出图标
        if (odSelected in State) then   //选中项的图像
            Draw(r.Left + (r.Right - r.Left - imgHouse.Width) shr 1,
      r.Top + 2, imgHouse.Picture.Graphic)
      else                            //未选中项的图像
            Draw(r.Left + (r.Right - r.Left - imgHouseGray.Width) shr 1,
      r.Top + 2, imgHouseGray.Picture.Graphic);
      //填充文字区背景
        r.Top := r.Bottom - Abs(Font.Height) - 4;
      Brush.Style := bsSolid;
      if (odSelected in State) then   //选中项的背景颜色
            Brush.Color := $FFB2B5
      else                            //未选中项的背景颜色
            Brush.Color := clSilver;
      FillRect(r);
      //输出文字，仅支持单行
        Font.Color := clBlack;
      r.Top := r.Top + 2; //计算文字顶点位置，(水平居中,DT_CENTER不可用)
        DrawText(Handle, PChar(TListBox(Control).Items.Strings[Index]), -1, r
      , DT_CENTER or DT_END_ELLIPSIS{ or DT_WORDBREAK});
      //画焦点虚框，当系统再绘制时，变成XOR运算，从而达到擦除焦点虚框的目的
        if(odFocused in State) then DrawFocusRect(Rect);
    end;
  end;
  
end.
分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 84

动态创建、压缩Access数据库(*.MDB)

作者:小氓男 日期:2010-06-19

创建Access数据库几乎是所有Delphi+Access所遇到的难题，我经过两头(昨天上午到现在)的艰苦奋战，终于将它全部解开，现在一一奉献给大家：
　　一、通过OLE方式创建
　　 相信各位都用通过OLE方式访问Word、Excel文件的经历，具体我不说太多，直接把具体代码写出来就完了
　　 在引用部分加入：


　　 uses ComObj;


　　 实现部分：
 


　　 procedure TFormOffice.BitBtn1Click(Sender: TObject);
　　 var
　　 CreateAccess:OleVariant;
　　 begin
  　　 CreateAccess:=CreateOleObject('ADOX.Catalog');
  　　 CreateAccess.Create('Provider=Microsoft.Jet.OLEDB.4.0;Data Source=c:\Aceco.mdb');
  　　 end;


　　 说明：
　　 1、在C:\下创建Aceco.mdb；
　　 2、是Access2000格式，用Access97打不开；
　　 3、系统需安装MDAC，这是好消息，客户不需安装Access也可以
　　二、通过DBEngine创建
　　 这才是关键中的关键，是我一定要写出来的原因！
　　 各位是否还记得安装Delphi的时候，如果你选择自定义安装(我一般用Delphi写控件，所以当然是越小越好)，会有很多安装选项，让你选择Access97或Access2000，还有MDAC等，问题就在这里！Delphi5.0中早就封装了现成的类，只是大家都没有注意而已它位于：
　　 $Delphi5\Imports
　　 目录下！
　　 其中有DAO97.DCU文件，它是通过DAO350.DLL来完成的，其中的定义部分和DAO350.DLL如出一辙！OK，到现在，所有的一切都明白了(可惜我花了一天时间！)。那么具体实现起来就太方便了，具体过程如下：
　　 在引用部分加入：
 


　　 uses DAO97;


　　 实现部分：
 


　　 procedure TFormOffice.BitBtn4Click(Sender: TObject);
　　 var
　　 Engine:DBEngine;
　　 begin
  　　 Engine:=CoDBEngine.Create;
  　　 Engine.CreateDatabase('c:\NewAccess.mdb',';LANGID=0x0804;CP=936;COUNTRY=0;',dbEncrypt);
  　　 end;

查看更多...

分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 78

DLL调用EXE中的函数

作者:小氓男 日期:2010-06-19


///////////////////////////////////////////////////////////////////////////////
// dll 中的代码:
///////////////////////////////////////////////////////////////////////////////
library dllProj;
uses
Windows, SysUtils, Classes;
type
TmyProc=function (msg:PChar):Boolean;
// {$R *.RES}
function testCalls(i:DWord):Boolean;
var
p:TmyProc;
begin
  @p:=GetProcAddress(GetModuleHandle(nil),'TestExport');
  if @p <> nil then
  p(PChar('调用成功，返回变量是：'+intTostr(i)))
  else MessageBox(0,'调用 exe 内部例程没有成功','信息',MB_OK);
  result:=true;
end;
exports
testCalls index 0 name 'testCalls';
begin
end.




 


///////////////////////////////////////////////////////////////////////////////
// exe 中的代码:
///////////////////////////////////////////////////////////////////////////////
unit exeUnit;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
end;
TTestProc=function(i:DWord):Boolean;
function TestExport(Msg:PChar):Boolean;
var
Form1: TForm1;
exports
TestExport name 'TestExport';
implementation
{$R *.DFM}
function TestExport(Msg: PChar): Boolean;
begin
  MessageBox(0,Msg,'信息',MB_OK);
  result:=true;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
theHandle:THandle;
MyProc:TTestProc;
begin
  theHandle:=LoadLibrary('dllProj.dll');
  if theHandle <> 0 then
  begin
    @MyProc := GetProcAddress(theHandle,'testCalls');
    if @MyProc <> nil then
    begin
      MyProc(5);
      FreeLibrary(theHandle);
    end
    else MessageBox(0,'exe 在载入 dll 时失败','信息',MB_OK);
  end;
end;
end.  
分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 93

创建漂亮的气球提示(balloon tooltips)

作者:小氓男 日期:2010-06-18

创建漂亮的气球提示:


 

{....}

uses Commctrl;

{....}

const
TTS_BALLOON    = $40;
TTM_SETTITLE = (WM_USER + 32);

var
hTooltip: Cardinal;
ti: TToolInfo;
buffer : array[0..255] of char;

{....}



procedure CreateToolTips(hWnd: Cardinal);
begin
  hToolTip := CreateWindowEx(0, 'Tooltips_Class32', nil, TTS_ALWAYSTIP or TTS_BALLOON,
  Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT), Integer(CW_USEDEFAULT),
  Integer(CW_USEDEFAULT), hWnd, 0, hInstance, nil);
  if hToolTip <> 0 then
  begin
    SetWindowPos(hToolTip, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE or
    SWP_NOSIZE or SWP_NOACTIVATE);
    ti.cbSize := SizeOf(TToolInfo);
    ti.uFlags := TTF_SUBCLASS;
    ti.hInst  := hInstance;
  end;
end;

procedure AddToolTip(hwnd: DWORD; lpti: PToolInfo; IconType: Integer;
Text, Title: PChar);
var
Item: THandle;
Rect: TRect;
begin
  Item := hWnd;
  if (Item <> 0) and (GetClientRect(Item, Rect)) then
  begin
    lpti.hwnd := Item;
    lpti.Rect := Rect;
    lpti.lpszText := Text;
    SendMessage(hToolTip, TTM_ADDTOOL, 0, Integer(lpti));
    FillChar(buffer, SizeOf(buffer), #0);
    lstrcpy(buffer, Title);
    if (IconType > 3) or (IconType < 0) then IconType := 0;
    SendMessage(hToolTip, TTM_SETTITLE, IconType, Integer(@buffer));
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CreateToolTips(Form1.Handle);
  AddToolTip(Memo1.Handle, @ti, 1, 'Tooltip text', 'Title');
end;

{
IconType can be:

0 - No icon
1 - Information
2 - Warning
3 - Error
}
分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 86

Treeview控件基于节点编号的访问

作者:小氓男 日期:2010-06-11

有时我们需要保存和重建treeview控件，本文提供一种方法，通过以树结构节点的编号访问树结构，该控件主要提供的方法如下：  
   function GetGlobeNumCode(inNode:TTreeNode):String;
   功能：返回当前节点的编号，编号规则见源码内说明。
   function LocatOrGenerateNode(inNumCode:String):TTreeNode;
   功能：以编号返回节点，假如节点的父节点和它的前继兄弟节点不存在，该方法会创建它们，名称为'Temp'，当然假如已经存在，就不执行创建工作。

查看更多...

分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 64

使代码简洁的五条忠告

作者:小氓男 日期:2010-06-11

写代码是一种艺术。使用Delphi，任何人都可以轻而易举地开发出某种软件、完成某些任务。而完美的代码则只有真正的高手才能写出。除了正确的缩进、大小写、命名规则之外，请时刻牢记爱因斯坦的名言--简单就是美。下面将谈及的五个代码问题，可能是初学者、甚至一些老鸟都会犯的错误。

　　忠告一
　　布尔型变量的赋值操作应该是直接的。例如，在一个if/then/else语句中，if子句将布尔型变量赋值为True，而else子句将其赋为False。下面这段代码的写法是不好的：
 


if If_Love_Delphi then
　Result:=True
else
　Result:=False;



　　而这样写就比较好：

 


　　Result:= If_Love_Delphi;


　　忠告二
　　避免使用嵌套的if/then/if语句，而用and来代替。下面这段代码太罗嗦：
 


if If_Love_Delphi then
　if If_Love_Linux then
TryKylix(Now);



　　应该这样写：
 


if If_Love_Delphi and If_Love_Linux then
　TryKylix(Now);

查看更多...

分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 72

delphi操作文本文件简介【二】

作者:小氓男 日期:2010-06-08

1.4 Delphi的文件管理标准过程　

      根据功能我们把标准过程划分为十一类进行介绍。 　

1.4.1 文件的打开与关闭　

查看更多...

分类:DELPHI代码 | 固定链接 | 评论: 0 | 引用: 0 | 查看次数: 106