看看啊，好多的自定义函数……

Question

我先贡献 4 个：//删除当前目录下的一类文件：
{1, 支持通配符，如 *.txt, *.* 等
 2, 不能删除文件夹
 3, 如果要删除某文件夹下的文件， 不许更改
     当前路径到改文件夹下，如：
      //var CurrDir: string;
       CurrDir :=GetCurrentDir;
       chdir('a_dir');
       DelSomeFiles('*.*');
       chdir(CurrDir);
}
Procedure DelSomeFiles(fn: string);
var
  SearchRec: TSearchRec;
begin
  FindFirst(fn, faAnyFile, SearchRec);
  repeat
    if FileExists(SearchRec.Name) then
    begin
      FileSetAttr(SearchRec.Name,0); //修改文件属性为普通属性值
      DeleteFile(SearchRec.Name); //删除文件
    end;
  until (FindNext(SearchRec)<>0);
  FindClose(SearchRec);
end;//函数：Deltree：  xxx
{ 参数 path 是需删除的目录路径;
  目录成功删除返回 True，否则返回 False
}
function Deltree(path:string):Boolean;
var
  SearchRec: TSearchRec;
  oldDir: string;
begin
  //判断目录是否存在
  if DirectoryExists(path) then
  begin
  //进入该目录，删除其中的子目录和文件
    oldDir :=GetCurrentDir;
    ChDir(path);
  //查找目录中所有任何文件
    FindFirst('.', faAnyFile, SearchRec);
    repeat
      //修改文件属性为普通属性值
      FileSetAttr(SearchRec.Name,0);
      //如果是目录并且不是.和..则递归调用DelTree
      if(SearchRec.Attr and faDirectory > 0) then
      begin
        if(SearchRec.Name[1]<>'.') then
          if(not Deltree(SearchRec.Name)) then
            break;
      end
      //如果是文件直接删除
      else
      if(not DeleteFile(SearchRec.Name))then
        break;
    //继续查找，直到最后
    until (FindNext(SearchRec)<>0);
    //回到父目录，删除该目录
    ChDir('..');
    Result := ReMoveDir(path);
    SetCurrentDir(oldDir);
  end
  else
    Result :=False;
end;//判断某 app 窗口是否已经打开（已经运行）-------------------
function isBeingRun(appName: Pchar): boolean;
var
  HWndCalculator: HWnd;
  begin
   // find the exist app window
   HWndCalculator := FindWindow(nil, appName);
   if HWndCalculator <> 0 then  // Has being run
     result := true
   else
     result := false;
end;//关闭已经打开的 app 窗口 ------------------------
procedure CloseApp(appName: Pchar);
var
  HWndCalculator: HWnd;
  begin
   // find the exist app window
   HWndCalculator := FindWindow(nil, appName);
   if HWndCalculator <> 0 then  // close the exist app
     SendMessage(HWndCalculator, WM_CLOSE, 0, 0);
end;

Answer 1

嘿嘿。const BaseTable:string='ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';
 
function FindInTable(CSource:char):integer;
begin
  result:=Pos(string(CSource),BaseTable)-1;
end;////
function DecodeBase64(Source:string):string;  //base64 编码
var
  SrcLen,Times,i:integer;
  x1,x2,x3,x4,xt:byte;
begin
  result:='';
  SrcLen:=Length(Source);
  Times:=SrcLen div 4;
  for i:=0 to Times-1 do
  begin
    x1:=FindInTable(Source[1+i*4]);
    x2:=FindInTable(Source[2+i*4]);
    x3:=FindInTable(Source[3+i*4]);
    x4:=FindInTable(Source[4+i*4]);
    x1:=x1 shl 2;
    xt:=x2 shr 4;
    x1:=x1 or xt;
    x2:=x2 shl 4;
    result:=result+chr(x1);
    if x3= 64 then break;
    xt:=x3 shr 2;
    x2:=x2 or xt;
    x3:=x3 shl 6;
    result:=result+chr(x2);
    if x4=64 then break;
    x3:=x3 or x4;
    result:=result+chr(x3);
  end;
end;/////
function EncodeBase64(Source:string):string;   //base64 解码
var
  Times,LenSrc,i:integer;
  x1,x2,x3,x4:char;
  xt:byte;
begin
  result:='';
  LenSrc:=length(Source);
  if LenSrc mod 3 =0 then Times:=LenSrc div 3
  else Times:=LenSrc div 3 + 1;
  for i:=0 to times-1 do
  begin
    if LenSrc >= (3+i*3) then
    begin
      x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];
      xt:=(ord(Source[1+i*3]) shl 4) and 48;
      xt:=xt or (ord(Source[2+i*3]) shr 4);
      x2:=BaseTable[xt+1];
      xt:=(Ord(Source[2+i*3]) shl 2) and 60;
      xt:=xt or (ord(Source[3+i*3]) shr 6);
      x3:=BaseTable[xt+1];
      xt:=(ord(Source[3+i*3]) and 63);
      x4:=BaseTable[xt+1];
    end
    else if LenSrc>=(2+i*3) then
    begin
      x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];
      xt:=(ord(Source[1+i*3]) shl 4) and 48;
      xt:=xt or (ord(Source[2+i*3]) shr 4);
      x2:=BaseTable[xt+1];
      xt:=(ord(Source[2+i*3]) shl 2) and 60;
      x3:=BaseTable[xt+1];
      x4:='=';
    end else
    begin
      x1:=BaseTable[(ord(Source[1+i*3]) shr 2)+1];
      xt:=(ord(Source[1+i*3]) shl 4) and 48;
      x2:=BaseTable[xt+1];
      x3:='=';
      x4:='=';
    end;
    result:=result+x1+x2+x3+x4;
  end;
end;

Answer 2

建立快捷方式:
procedure TMainForm.CreateWinGroup(Sender: TObject);var  Name: string;
  Name1: string;  Macro: string;  Macro1: string;
  Cmd, Cmd1: array[0..255] of Char;begin
 {destDir is the dos directory to hold the YourFile.Ext'}
    Name := 'GroupName';
    Name1 := destDir + 'YourFile.Ext, FileName_in_Group  ';
    Macro := Format('[CreateGroup(%s)]', [Name]) + #13#10;
    Macro1 :=Format('[Additem(%s)]',[Name1]) +#13#10;    StrPCopy (Cmd, Macro);
    StrPCopy (cmd1, Macro1);    DDEClient.OpenLink;
    if not DDEClient.ExecuteMacro(Cmd, False) then
      MessageDlg('Unable to create group '+Name,mtInformation, [mbOK], 0)
    else      begin      DDEClient.ExecuteMacro(Cmd1, False);      end;
    DDEClient.CloseLink;end;

Answer 3

画个框:
Procedure ShowLine (labe:Tlabel;Focus:boolean=true);
var Hand,IColr:Integer;
    LineS:array[0..3] of integer;
begin
  Lines[0]:=labe.left-5; //左上角x
  Lines[1]:=labe.top-5;  //左上角y
  Lines[2]:=labe.left+labe.width+5;//右下角x
  Lines[3]:=labe.top+labe.height+5; //右下角y
  Hand:=GetDc(labe.Parent.Handle);
  MoveToEx(hand,Lines[0],Lines[1],nil);
  LineTo(hand,Lines[2],Lines[1]);
  LineTo(hand,Lines[2],Lines[3]);
  TextOut(hand,lines[2],lines[3],'ok',2);
  IColr:=16777215;
  SetTextColor(hand,IColr);
  UpdateColors(hand);
  TextOut(hand,lines[0],lines[1],'ok',2);
  LineTo(hand,Lines[0],Lines[3]);
  LineTo(hand,Lines[0],Lines[1]);
end;

Answer 4

//将指定数字转换成汉字的函数,UpperWord(源数字,是否货币汉字,是否自动加位数);
function UpperWord(IDigital:integer;money:Boolean=false;AddBit:Boolean=false):string;
var SDigital,sWord,SReturn:string;
    ITmp:integer;
begin
  if Money then SWord:='零壹贰叁肆伍陆柒捌玖' else SWord:='零一二三四五六七八九';
  SDigital:=inttostr(IDigital);
  SReturn:='';
  ITmp:=Length(SDigital);
  while ITmp>0 do
  begin
    SReturn:=SReturn+copy(SWord,strtoint(copy(SDigital,1,1))*2+1,2);
    if AddBit then
    begin
      if copy(SDigital,1,1)='0' then
        if copy(SReturn,length(SReturn)-3,4)='零零' then SReturn:=copy(SReturn,1,length(SReturn)-2);
        case ITmp of
        2,6,10:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'十';
        3,7,11:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'百';
        4,8,12:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'千';
        5:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'万' else (if copy(SReturn,length(SReturn)-3,2)='亿' then SReturn:=copy(SReturn,1,length(SReturn)-2) else SReturn:=copy(SReturn,1,length(SReturn)-2)+'万');
        9:if copy(SDigital,1,1)<>'0' then SReturn:=SReturn+'亿' else SReturn:=copy(SReturn,1,length(SReturn)-2)+'亿';
        end;
    end;
    SDigital:=copy(SDigital,2,255);
    ITmp:=Length(SDigital);
  end;
  if AddBit then
    while copy(SReturn,length(SReturn)-1,2)='零' do
      SReturn:=copy(SReturn,1,length(SReturn)-2);
  UpperWord:=SReturn;
end;

Answer 5

wang0110() TMD怎么生出个你来？我来说
//字符串左加指定数量空格
FUNCTION PADL(CONST SS:STRING;LEN:INTEGER):STRING;
VAR
  I,N,L:INTEGER;
  S,S1,S2:STRING;
BEGIN
  L:=LENGTH(TRIM(SS));
  N:=POS('-',SS);
  IF N>0 THEN
    BEGIN
      S:='';
      S1:=COPY(TRIM(SS),1,N-1);
      S2:=COPY(TRIM(SS),N+1,L-N);
      FOR I:=1 TO LEN-(L-1) DO
        S:='0'+S;
      RESULT:=S1+S+S2;
    END
  ELSE
    BEGIN
      S:=TRIM(SS);
      IF LENGTH(TRIM(SS))<LEN THEN
        BEGIN
          FOR I:=1 TO LEN-L DO
            S:='0'+S;
        END;
      RESULT:=S;
    END;
END;//字符串右加指定数量空格
FUNCTION PADR(CONST SS:STRING;LEN:INTEGER):STRING;
VAR
  I,N,L:INTEGER;
  S,S1,S2:STRING;
BEGIN
  L:=LENGTH(TRIM(SS));
  N:=POS('-',SS);
  IF N>0 THEN
    BEGIN
      S:='';
      S1:=COPY(TRIM(SS),1,N-1);
      S2:=COPY(TRIM(SS),N+1,L-N);
      FOR I:=1 TO LEN-(L-1) DO
        S:=S+'0';
      RESULT:=S1+S+S2;
    END
  ELSE
    BEGIN
      S:=TRIM(SS);
      IF LENGTH(TRIM(SS))<LEN THEN
        BEGIN
          FOR I:=1 TO LEN-L DO
            S:=S+'0';
        END;
      RESULT:=S;
    END;
END;FUNCTION FINDDATA(CONST ZD1,TBN,ZD2,ZDZ:STRING):STRING;
{从TBN表中返回条件为字段ZD2等于ZD2的字段ZD1的值。}
VAR
  SS:STRING;
BEGIN
  WITH PUBDATAM.QUERY1 DO
    BEGIN
      CLOSE;
      SS:='SELECT '+ZD1+' FROM '+TBN+' WHERE '+ZD2+'='''+ZDZ+'''';
      SQL.CLEAR;
      SQL.ADD(SS);
      OPEN;
      IF FIELDVALUES[ZD1]<>NULL THEN
        RESULT:=FIELDVALUES[ZD1]
      ELSE
        RESULT:='';
      CLOSE;
    END;
END;

Answer 6

http://kingron.myetang.com/function.htm

Answer 7

////////信息框定义：
function _MsgBox(Prompt:Pchar; WinCaption:Pchar; BtnType:integer): integer;
begin
  result :=Application.MessageBox(Prompt, Wincaption, BtnType);
end;Const  //BtnType
 //Application.MessageBox 按钮类型：
   vbOKOnly = 0;           //只显示 OK 按钮。
   VbOKCancel = 1;         //显示 OK 及 Cancel 按钮。
   VbAbortRetryIgnore = 2; //显示 Abort、Retry 及 Ignore 按钮。
   VbYesNoCancel = 3;      //显示 Yes、No 及 Cancel 按钮。
   VbYesNo = 4;            //显示 Yes 及 No 按钮。
   VbRetryCancel = 5;      //显示 Retry 及 Cancel 按钮。
   VbCritical = 16;        //显示 Critical Message 图标。
   VbQuestion = 32;        //显示 Warning Query 图标。
   VbExclamation = 48;     //显示 Warning Message 图标。
   VbInformation = 64;     //显示 Information Message 图标。
   VbDefaultButton1 = 0;   //第一个按钮是缺省值。
   VbDefaultButton2 = 256; //第二个按钮 是缺省值。
   VbDefaultButton3 = 512; //第三个按钮是缺省值。
   VbDefaultButton4 = 768; //第四个按钮是缺省值。
   VbApplicationModal = 0; //应用程序强制返回；应用程序一直被挂起，直到
                           //用户对消息框作出响应才继续工作。
   VbSystemModal = 4096;   //系统强制返回；全部应用程序都被挂起，直到用户对消息
                           //框作出响应才继续工作。
 //Application.MessageBox 返回值：
   vbOK = 1;      //OK
   vbCancel = 2;  //Cancel
   vbAbort = 3;   //Abort
   vbRetry = 4;   //Retry
   vbIgnore = 5;  //Ignore
   vbYes = 6;     //Yes
   vbNo = 7;      //No

Answer 8

//选出 DBGrid 的几条记录，然后写到另一个 DBGrid 中：
//输入值：DBGrid, DataSet
//输出值：String 信息
//正确结果：DataSet 得到选择的记录
Function TForm1.GetSelectedRecords2DataSet(DBGrid:TDBGrid; DtSt:TADODataSet):String;
var
  i, j: Integer;
  BookList:TBookList;
  bm: TBookMark;
begin
  BookList :=DBGrid1.SelectedRows;
  if DBGrid.DataSource.DataSet.Active =False then
  begin
    result :='1';  // 源记录集没有激活
    exit;
  end;
  if DtSt.Active =False then
  begin
    result :='2';  // 目标记录集没有激活
    exit;
  end;
  if BookList.Count =0 then
  begin
    result :='0';  // 没有选择表格中的任何记录!
    exit;
  end;
  with DBGrid.DataSource.DataSet do
  begin
    DisableControls;
    bm :=GetBookMark;
    try
     for i :=0 to BookList.Count-1 do
     begin
       DtSt.Append;
       for j :=1 to FieldCount-1 do
       begin
         Book := BookList[i];
         DtSt.Fields[j].Value :=Fields[j].Value;
       end;
     end;
    finally
      GotoBookMark(bm);
      FreeBookMark(bm);
      EnableControls;
      result :='OK';
    end;
  end;
end;

Answer 9

up for 农民->qiqi的老公

Answer 10

     一次创建多级文件夹      uses FileCtrl;
      procedure MkDirMulti(sPath: string);
      begin
        if('\'=sPath[Length(sPath)]) then
        begin
          sPath :=Copy(sPath, 1, Length(sPath)-1);
        end;
        if (Length(sPath)<3) or DirectoryExists(sPath) then
        begin
          Exit;
        end;
        MkDirMulti(SysUtils.ExtractFilePath(sPath ));
        try
          System.MkDir(sPath);
        except
          {handle errors}
        end;
      end;

Answer 11

procedure Tfrm_main.WebBrowser1DocumentComplete(Sender: TObject;
        const pDisp: IDispatch; var URL: OleVariant);
      begin
        WebBrowser1.OleObject.Document.body.Scroll := 'no';
      end;

Answer 12

贡献几个
function IsW2K: Boolean;  // 判断操作系统是否win98
begin
  result := (win32platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >=5);
end;function IsW98: Boolean;  // 判断操作系统是否win2000
begin
  result := (win32platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >=5);
end;{画透明位图}
procedure TransBlt(destdc: HDC; dx, dy, dw, dh: Integer;
                           srcdc: HDC; sx, sy, sw, sh: Integer; c: Cardinal);
var
  monodc: HDC;
  monobmp: HBITMAP;
  old: THandle;
begin
  if isw2k or isw98 then
    transparentblt(destdc, dx, dy, dw, dh, srcdc, sx, sy, sw, sh, c)
  else begin
    monodc := createcompatibledc(0);
    monobmp := createbitmap(sw, sh, 1, 1, nil);
    old := selectobject(monodc, monobmp);
    setbkcolor(srcdc, c);
    bitblt(monodc, 0, 0, sw, sh, srcdc, sx, sy, SRCCOPY);
    transparentstretchblt(destdc, dx, dy, dw, dh, srcdc, sx, sy, sw, sh, monodc, 0, 0);
    selectobject(monodc, old);
    deleteobject(monobmp);
    deletedc(monodc); 
  end;
end;

Answer 13

{由单色图片产生region
function CreateRgnFromMask(
    Msk: HBITMAP;                 // 源图片，windows HBITMAP
    x, y: Integer                 // 结果region的坐标
    ): HRGN;                      // 结果regionfunction CreateRgnFromBmpBits(Bits: Pointer; Left, Top, Width, height, gap: Integer): HRGN;
var
  Rct: TRect;
  i, l: Integer;
  RgnH: PRgnDataHeader;
  MaxLen: Integer;
  p, p1: PByte;
  b, e: Byte;
  LineP, LastP: PRect;  procedure ResizeRects;
  var
    p: PRect;
  begin
    p := LineP;
    while Integer(p) < Integer(LastP) do
    begin
      Inc(p^.Bottom);
      Inc(p);
    end;
    Inc(RgnH^.rcBound.Bottom);
  end;  procedure NewRectInStruct(x, y: Integer);
  var
    i, j: Integer;
  begin
    if Integer(LastP) >= Integer(RgnH) + MaxLen then
    begin
      i := Integer(LastP) - Integer(RgnH);
      j := Integer(LineP) - Integer(RgnH);
      Inc(maxLen, 4096);
      ReAllocMem(RgnH, MaxLen);
      LastP := Pointer(Integer(RgnH) + i);
      LineP := Pointer(Integer(RgnH) + j);
    end;
    Inc(RgnH^.nCount);
    with LastP^ do
    begin
      Left := x;
      Top := y;
      Right := x + 1;
      Bottom := y + 1;
      if Left < RgnH^.rcBound.Left then
        RgnH^.rcBound.Left := Left;
      if Top < RgnH^.rcBound.Top then
        RgnH^.rcBound.Top := Top;
      if Right > RgnH^.rcBound.Right then
        RgnH^.rcBound.Right := Right;
      if Bottom > RgnH^.rcBound.Bottom then
        RgnH^.rcBound.Bottom := Bottom;
    end;
  end;  function IsScanLineEmpty(v: PByte): Boolean;
  var
    i: Integer;
  begin
    if l < 0 then
      Result := (v^ or b) = $ff
    else begin
      Result := v^ or b = $ff;
      if not Result then Exit;
      Inc(v);
      for i := 0 to l - 1 do
      begin
        Result := Result and (v^ = $ff);
        if not Result then Exit;
        Inc(v);
      end;
      Result := v^ or e = $ff;
    end;
  end;  function SameScanLine(v, v1: PByte): Boolean;
  begin
    Result := (v^ or b) = (v1^ or b);
    if not Result then Exit;
    if l < 0 then Exit;
    Inc(v);
    Inc(v1);
    if l > 0 then
      Result := CompareMem(v, v1, l);
    if not Result then Exit;
    Inc(v, l);
    Inc(v1, l);
    Result := v^ or e = v1^ or e;
  end;  procedure ScanLineToRects(n: Integer; v: PByte);
  var
    i, j, x: Integer;
    f: Boolean;
  begin
    LineP := LastP;
    f := False;
    x := Rct.Left and $fffffff8;
    for i := 0 to 7 do
      if $80 shr i and (v^ or b) = 0 then
        if f then Inc(LastP^.Right)
        else begin
          NewRectInStruct(x + i, n);
          f := True;
        end
      else if f then
      begin
        f := False;
        Inc(LastP);
      end;
    if l >= 0 then
    begin
      Inc(v);
      Inc(x, 8);
      for i := 0 to l-1 do
      begin
        if v^ and $ff = $ff then
          if f then begin
            f := False;
            Inc(LastP);
          end
          else
        else if v^ and $ff = 0 then
          if f then
            Inc(LastP^.Right, 8)
          else begin
            f := True;
            NewRectInStruct(x, n);
            Inc(LastP^.Right, 7);
          end
        else
          for j := 0 to 7 do
            if ($80 shr j) and v^ = 0 then
              if f then
                Inc(LastP^.Right)
              else begin
                f := True;
                NewRectInStruct(x + j, n);
              end
            else if f then
            begin
              f := False;
              Inc(LastP);
            end;
        Inc(v);
        Inc(x, 8);
      end;
      for i := 0 to 7 do
        if $80 shr i and (v^ or e) = 0 then
          if f then Inc(LastP^.Right)
          else begin
            NewRectInStruct(x + i, n);
            f := True;
          end
        else if f then
        begin
          f := False;
          Inc(LastP);
        end;
    end;
    if f then Inc(LastP);
    if Integer(LastP) > Integer(LineP) then
      with PRect(Integer(LastP)-16)^ do
        if Right > RgnH^.rcBound.Right then
          RgnH^.rcBound.Right := Right;
  end;begin
  Rct := Rect(0,0,Width, abs(Height));
  if IsRectEmpty(Rct) then
  begin
    Result := CreateRectRgn(-2, -2, -1, -1);
    Exit;
  end;
  MaxLen := SizeOf(_RGNDATAHEADER);
  GetMem(RgnH, MaxLen);
  LastP := Pointer(Integer(RgnH) + MaxLen);
  RgnH^.dwSize := MaxLen;
  RgnH^.iType := RDH_RECTANGLES;
  RgnH^.nCount := 0;
  with RgnH^.rcBound do
  begin
    Left := Rct.Right + 1;
    Top := Rct.Bottom + 1;
    Right := Rct.Left - 1;
    Bottom := Rct.Top - 1;
  end;
  l := (Rct.Right - Rct.Left) shr 3;
  if Rct.Left mod 8 <> 0 then Inc(l);
  if Rct.Right mod 8 <> 0 then Inc(l);
  Dec(l, 2);
  if height > 0 then
  begin
    p := pointer(integer(bits)+(height-1)*gap);
    gap := -gap;
  end
  else
    p := bits;
  p1 := p;
  b := $ff shl (8 - Rct.Left mod 8);
  e := $ff shr ((Rct.Right-1) mod 8 + 1);
  if l < 0 then
    b := b or e;
  ScanLineToRects(Rct.Top, p);
  p := Pointer(Integer(p) + gap);
  for i := Rct.Top + 1 to Rct.Bottom - 1 do
  begin
    if not IsScanLineEmpty(p) then
      if SameScanLine(p, p1) then
        ResizeRects
      else
        ScanLineToRects(i, p);
    p := Pointer(Integer(p) + gap);
    p1 := Pointer(Integer(p1) + gap);
  end;
  if IsRectEmpty(RgnH^.rcBound) then
    Result := CreateRectRgn(-2, -2, -1, -1)
  else begin
    RgnH^.nRgnSize := RgnH^.nCount * 16;
    Result := ExtCreateRegion(nil, RgnH^.nRgnSize + SizeOf(_RGNDATAHEADER),
                                   PRgnData(Integer(RgnH))^);
    offsetrgn(result, left, top);
  end;
  FreeMem(RgnH, MaxLen);
end;function CreateRgnFromMask(Msk: HBITMAP; x, y: Integer): HRGN;
var
  Info: PBitmapInfo;
  Bits: Pointer;
  InfoSize, ImgSize: DWORD;
  DS: TDIBSection;
  DC: HDC;
  Gap: Integer;
begin
  infosize := sizeof(TBitmapInfo)+256*sizeof(TRGBQuad);
  GetObject(Msk, sizeof(ds), @ds);
  info := allocmem(infosize);
  fillchar(info^, sizeof(TBitmapInfo), #0);
  with info^.bmiHeader do
  begin
    bisize := sizeof(TBitmapInfoHeader);
    biWidth := ds.dsBm.bmWidth;
    biheight := ds.dsBm.bmHeight;
    biplanes := 1;
    bibitcount := 1;
    gap := bytesperscanline(biwidth, 1, 32);
    imgsize := gap * abs(biheight);
    bits := allocmem(imgsize);
    dc := createcompatibledc(0);
    getdibits(dc, msk, 0, biheight, bits, info^, DIB_RGB_COLORS);
    deletedc(dc);
    result := creatergnfromBmpbits(bits, x, y, biwidth, biheight, Gap);
  end;
  freemem(info, infosize);
  freemem(bits, imgsize);
end;

Answer 14

{由彩色图片产生region}
function CreateRgnFromHBmp(
    DC: HDC;                   // 包含源图片的DC
    Width, Height: Integer;    // 原图片尺寸
    TransColor: TColor;        // 源图片透明色
    x, y: Integer              // 结果Region坐标
  ): HRGN;                     // 结果function CreateRgnFromBmp(
    Bmp: TBitmap;             // 源图片
    TransColor: TColor;       // 源图片透明色
    x, y: Integer             // 结果Region坐标
  ): HRGN;                    // 结果实现：
function CreateRgnFromHBmp(DC: HDC; width, height: Integer; TransColor: TColor; x, y: Integer): HRGN;
var
  monoDC : HDC;
  MonoImg: HBITMAP;
  sav: THandle;
begin
  monodc := createcompatibledc(0);
  monoimg := createbitmap(width, height, 1, 1, nil);
  sav := selectobject(monodc, monoimg);
  setbkcolor(dc, colortorgb(transcolor));
  bitblt(monodc, 0, 0, width, height, dc, 0, 0, SRCCOPY);
  selectobject(monodc, sav);
  deletedc(monodc);
  result := creatergnfrommask(monoimg, x, y);
  deleteobject(monoimg);
end;function CreateRgnFromBmp(Bmp: TBitmap; TransColor: TColor; x, y: Integer): HRGN;
var
  monoDC, ScreenDC: HDC;
  MonoImg: HBITMAP;
  sav: THandle;
begin
  screendc := getdc(0);
  monodc := createcompatibledc(screendc);
  monoimg := createbitmap(bmp.width, bmp.height, 1, 1, nil);
  sav := selectobject(monodc, monoimg);
  setbkcolor(bmp.canvas.handle, colortorgb(transcolor));
  bitblt(monodc, 0, 0, bmp.width, bmp.height, bmp.canvas.handle, 0, 0, SRCCOPY);
  selectobject(monodc, sav);
  deletedc(monodc);
  releasedc(0, screendc);
  result := creatergnfrommask(monoimg, x, y);
  deleteobject(monoimg);
end;

Answer 15

使窗体的 Alt+F4 快捷键(关闭窗体)失效:把 Form 的 KeyPreview 设为 True，然后响应 OnKeyDown 事件：
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;Shift: TShiftState);
begin
  if (Key=VK_F4) and (ssAlt in shift) then
    Key :=0;
end;

Answer 16

//功能：根据sql语句动态填充combobox的内容
//AcmbBox为combobox控件，AstrSQL为sql语句
procedure GeneralcmbBox(AcmbBox:TComboBox;AstrSQL:string);
begin
   AcmbBox.Clear;
   with TQuery.Create(application) do
   begin
     TRY
       DatabaseName:=aliasname;
       Close;
       SQL.Text:=AstrSQL;
       Open;
       if IsEmpty then Exit;
       while not Eof do
       begin
         AcmbBox.Items.Add(Fields[0].AsString);
         Next;
       end;
       Close;
     FINALLY
       Free;
     END;
   end;
end;

Answer 17

动态创建组件之参数传递示例函数
var
  i:integer;
  ed1,ed2:array of tedit;
begin
  setlength(ed1,6);
  setlength(ed2,6);
  for i:=0 to 5 do
   begin
     ed1[i]:=tedit.create(self);
     with ed1[i] do
       beign
          parent:=form1;
          text:='aa';
       end;
   end;
   for i:=0 to 5 do
   begin
     ed2[i]:=tedit.create(self);
     with ed2[i] do
       beign
          parent:=form1;
          text:=ed1[i];
       end;
   end;
end;