关于Delphi2007 Remote Data Module 模块无法注册的问题的解决

第一次用 Delphi 2007　编写远程数据模块，发现程序运行没有自动注册。后来找了一些资料，解决了。

在 TRemoteDataModule 单元中添加以下代码即可。

initialization

TComponentFactory.Create(ComServer, TXOtecDbRemoteServer,

      Class_XOtecDbRemoteServer, ciMultiInstance, tmApartment);

    ComServer.UpdateRegistry(True); //添加这一句，可实现注册 

轉貼:http://www.voidcn.com/article/p-oualhgog-sm.html

SQL Server - 取英文月份名稱

set language  'us_english'

select  convert(char, getdate(), 107)

列出所有 Table 的資料結構.

/* 列出所有 Table 的資料結構.sql */
select C.name as TableName,
case A.status
   when '16' then 'PK'
   else ''
end as [Key], A.name as FieldName, '' as [Desc], D.name as type, A.length,
case A.isnullable
   when '1' then 'V'
   else ''
end as isnullable, isnull(B.text, '') as [Default],
case C.type
  when 'U' then 'Table'
  when 'V' then 'View'
  else ''
end as TableOrView
from syscolumns as A, syscomments as B, systypes as D, sysobjects as C
 where A.cdefault = B.id and A.xtype = D.xtype and D.status <> '1'  -- 排除sysname 和 nvarchar 同 xtype = 231
 and A.id = C.id
 and (C.type = 'U' or C.type = 'V')
order by C.name, A.colid

轉貼至 http://tw.myblog.yahoo.com/jw!nowr4YGVQE4pAgs1INa7JnTZmg--/article?mid=509

將多筆資料的特定欄位依分隔符號組成字串

select STUFF(
  (select  ',' +field1
   from table1
   where ..................
   FOR XML PATH('')
  ), 1, 1, '') aa

參考至 http://www.dotblogs.com.tw/terrychuang/archive/2011/04/16/22867.aspx

TSQL 解析JSON-fn_ParseJSON (轉貼)

Create FUNCTION [dbo].[fn_ParseJSON]( @json nvarchar(max) ) 
RETURNS @hierarchy table 
( 
  element_id int IDENTITY(1, 1) NOT NULL, /* internal surrogate primary key gives the order of parsing and the list order */ 
  parent_id int NOT NULL, /* [0 -- Root] if the element has a parent then it is in this column. The document is the ultimate parent, so you can get the structure from recursing from the document */ 
  object_id int NOT NULL, /* [0 -- Not an object] each list or object has an object id. This ties all elements to a parent. Lists are treated as objects here */ 
  name nvarchar(2000), /* the name of the object */ 
  stringvalue nvarchar(4000) NOT NULL, /*the string representation of the value of the element. */ 
  valuetype nvarchar(100) NOT NULL, /* the declared type of the value represented as a string in stringvalue*/ 
  bigintvalue bigint 
) 
 
AS 
 
BEGIN 
    --20140703 Peter Copy
    --select * from dbo.fn_ParseJSON('{"a":"1", "b":"2"}')

    DECLARE 
        @firstobject int, --the index of the first open bracket found in the JSON string 
        @opendelimiter int, --the index of the next open bracket found in the JSON string 
        @nextopendelimiter int,--the index of subsequent open bracket found in the JSON string 
        @nextclosedelimiter int,--the index of subsequent close bracket found in the JSON string 
        @type nvarchar(10),--whether it denotes an object or an array 
        @nextclosedelimiterChar CHAR(1),--either a '}' or a ']' 
        @contents nvarchar(MAX), --the unparsed contents of the bracketed expression 
        @start int, --index of the start of the token that you are parsing 
        @end int,--index of the end of the token that you are parsing 
        @param int,--the parameter at the end of the next Object/Array token 
        @endofname int,--the index of the start of the parameter at end of Object/Array token 
        @token nvarchar(4000),--either a string or object 
        @value nvarchar(MAX), -- the value as a string 
        @name nvarchar(200), --the name as a string 
        @parent_id int,--the next parent ID to allocate 
        @lenjson int,--the current length of the JSON String 
        @characters NCHAR(62),--used to convert hex to decimal 
        @result BIGINT,--the value of the hex symbol being parsed 
        @index SMALLINT,--used for parsing the hex value 
        @escape int; --the index of the next escape character 
     
    /* in this temporary table we keep all strings, even the names of the elements, since they are 'escaped' 
     * in a different way, and may contain, unescaped, brackets denoting objects or lists. These are replaced in 
     * the JSON string by tokens representing the string 
     */ 
    DECLARE @strings table 
    ( 
        string_id int IDENTITY(1, 1), 
        stringvalue nvarchar(MAX) 
    ) 
     
    /* initialise the characters to convert hex to ascii */ 
    SET @characters = '0123456789abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ'; 
    SET @parent_id = 0; 
     
    /* firstly we process all strings. This is done because [{} and ] aren't escaped in strings, which complicates an iterative parse. */ 
    WHILE 1 = 1 /* forever until there is nothing more to do */ 
    BEGIN 
        SET @start = PATINDEX('%[^a-zA-Z]["]%', @json collate SQL_Latin1_General_CP850_Bin); /* next delimited string */ 
         
        IF @start = 0 BREAK; /*no more so drop through the WHILE loop */ 
         
        IF SUBSTRING(@json, @start+1, 1) = '"' 
        BEGIN  /* Delimited name */ 
            SET @start = @start+1; 
            SET @end = PATINDEX('%[^\]["]%', RIGHT(@json, LEN(@json+'|')-@start) collate SQL_Latin1_General_CP850_Bin); 
        END 
         
        IF @end = 0 /*no end delimiter to last string*/ 
            BREAK; /* no more */ 
         
        SELECT @token = SUBSTRING(@json, @start+1, @end-1) 
         
        /* now put in the escaped control characters */ 
        SELECT @token = REPLACE(@token, from_string, to_string) 
        FROM 
        ( 
            SELECT '\"' AS from_string, '"' AS to_string 
            UNION ALL 
            SELECT '\\', '\' 
            UNION ALL 
            SELECT '\/', '/' 
            UNION ALL 
            SELECT '\b', CHAR(08) 
            UNION ALL 
            SELECT '\f', CHAR(12) 
            UNION ALL 
            SELECT '\n', CHAR(10) 
            UNION ALL 
            SELECT '\r', CHAR(13) 
            UNION ALL 
            SELECT '\t', CHAR(09) 
        ) substitutions; 
         
        SET @result = 0; 
        SET @escape = 1; 
         
        /*Begin to take out any hex escape codes*/ 
        WHILE @escape > 0 
        BEGIN 
         
            /* find the next hex escape sequence */ 
            SET @index = 0; 
            SET @escape = PATINDEX('%\x[0-9a-f][0-9a-f][0-9a-f][0-9a-f]%', @token collate SQL_Latin1_General_CP850_Bin); 
             
            IF @escape > 0 /* if there is one */ 
            BEGIN 
                 
                WHILE @index < 4 /* there are always four digits to a \x sequence  */ 
                BEGIN 
                    /* determine its value */ 
                    SET @result = @result + POWER(16, @index) * (CHARINDEX(SUBSTRING(@token, @escape + 2 + 3 - @index, 1), @characters) - 1); 
                    SET @index = @index + 1; 
                END 
                 
                /* and replace the hex sequence by its unicode value */ 
                SET @token = STUFF(@token, @escape, 6, NCHAR(@result)); 
            END 
             
        END 
         
        /* now store the string away */ 
        INSERT INTO @strings (stringvalue) SELECT @token; 
         
        /* and replace the string with a token */ 
        SET @json = STUFF(@json, @start, @end + 1, '@string' + CONVERT(nvarchar(5), @@identity)); 
         
    END 
     
    /* all strings are now removed. Now we find the first leaf. */ 
    WHILE 1 = 1  /* forever until there is nothing more to do */ 
    BEGIN 
     
        SET @parent_id = @parent_id + 1; 
         
        /* find the first object or list by looking for the open bracket */ 
        SET @firstobject = PATINDEX('%[{[[]%', @json collate SQL_Latin1_General_CP850_Bin);  /*object or array*/ 
         
        IF @firstobject = 0 BREAK; 
         
        IF (SUBSTRING(@json, @firstobject, 1) = '{') 
            SELECT @nextclosedelimiterChar = '}', @type = 'object'; 
        ELSE 
            SELECT @nextclosedelimiterChar = ']', @type = 'array'; 
         
         
        SET @opendelimiter = @firstobject; 
         
        WHILE 1 = 1 --find the innermost object or list... 
        BEGIN 
            SET @lenjson = LEN(@json+'|') - 1; 
             
            /* find the matching close-delimiter proceeding after the open-delimiter */ 
            SET @nextclosedelimiter = CHARINDEX(@nextclosedelimiterChar, @json, @opendelimiter + 1); 
             
            /* is there an intervening open-delimiter of either type */ 
            SET @nextopendelimiter = PATINDEX('%[{[[]%',RIGHT(@json, @lenjson-@opendelimiter) collate SQL_Latin1_General_CP850_Bin); /*object*/ 
             
            IF @nextopendelimiter = 0 BREAK; 
             
            SET @nextopendelimiter = @nextopendelimiter + @opendelimiter; 
             
            IF @nextclosedelimiter < @nextopendelimiter BREAK; 
             
            IF SUBSTRING(@json, @nextopendelimiter, 1) = '{' 
                SELECT @nextclosedelimiterChar = '}', @type = 'object'; 
            ELSE 
                SELECT @nextclosedelimiterChar = ']', @type = 'array'; 
             
            SET @opendelimiter = @nextopendelimiter; 
        END 
         
        /* and parse out the list or name/value pairs */ 
        SET @contents = SUBSTRING(@json, @opendelimiter+1, @nextclosedelimiter-@opendelimiter - 1); 
         
        SET @json = STUFF(@json, @opendelimiter, @nextclosedelimiter - @opendelimiter + 1, '@' + @type + CONVERT(nvarchar(5), @parent_id)); 
         
        WHILE (PATINDEX('%[A-Za-z0-9@+.e]%', @contents collate SQL_Latin1_General_CP850_Bin)) <  > 0 
        BEGIN /* WHILE PATINDEX */ 
         
            IF @type = 'object' /*it will be a 0-n list containing a string followed by a string, number,boolean, or null*/ 
            BEGIN 
                 
                SET @end = CHARINDEX(':', ' '+@contents); /*if there is anything, it will be a string-based name.*/ 
                SET @start = PATINDEX('%[^A-Za-z@][@]%', ' ' + @contents collate SQL_Latin1_General_CP850_Bin); /*AAAAAAAA*/ 
                 
                SET @token = SUBSTRING(' '+@contents, @start + 1, @end - @start - 1); 
                SET @endofname = PATINDEX('%[0-9]%', @token collate SQL_Latin1_General_CP850_Bin); 
                SET @param = RIGHT(@token, LEN(@token)-@endofname + 1); 
                 
                SET @token = LEFT(@token, @endofname - 1); 
                SET @contents = RIGHT(' ' + @contents, LEN(' ' + @contents + '|') - @end - 1); 
                 
                SELECT @name = stringvalue FROM @strings WHERE string_id = @param; /*fetch the name*/ 
                 
            END 
            ELSE 
            BEGIN 
                SET @name = null; 
            END 
             
            SET @end = CHARINDEX(',', @contents);  /*a string-token, object-token, list-token, number,boolean, or null*/ 
             
            IF @end = 0 
                SET @end = PATINDEX('%[A-Za-z0-9@+.e][^A-Za-z0-9@+.e]%', @contents+' ' collate SQL_Latin1_General_CP850_Bin) + 1; 
             
            SET @start = PATINDEX('%[^A-Za-z0-9@+.e][A-Za-z0-9@+.e]%', ' ' + @contents collate SQL_Latin1_General_CP850_Bin); 
             
            /*select @start,@end, LEN(@contents+'|'), @contents */ 
             
            SET @value = RTRIM(SUBSTRING(@contents, @start, @end-@start)); 
            SET @contents = RIGHT(@contents + ' ', LEN(@contents+'|') - @end); 
             
            IF SUBSTRING(@value, 1, 7) = '@object' 
                INSERT INTO @hierarchy (name, parent_id, stringvalue, object_id, valuetype) 
                SELECT @name, @parent_id, SUBSTRING(@value, 8, 5), SUBSTRING(@value, 8, 5), 'object'; 
             
            ELSE 
                IF SUBSTRING(@value, 1, 6) = '@array' 
                    INSERT INTO @hierarchy (name, parent_id, stringvalue, object_id, valuetype) 
                    SELECT @name, @parent_id, SUBSTRING(@value, 7, 5), SUBSTRING(@value, 7, 5), 'array'; 
                ELSE 
                    IF SUBSTRING(@value, 1, 7) = '@string' 
                        INSERT INTO @hierarchy (name, parent_id, stringvalue, valuetype, object_id) 
                        SELECT @name, @parent_id, stringvalue, 'string', 0 
                        FROM @strings 
                        WHERE string_id = SUBSTRING(@value, 8, 5); 
                    ELSE 
                        IF @value IN ('true', 'false') 
                            INSERT INTO @hierarchy (name, parent_id, stringvalue, valuetype, object_id) 
                            SELECT @name, @parent_id, @value, 'boolean', 0; 
                        ELSE 
                            IF @value = 'null' 
                                INSERT INTO @hierarchy (name, parent_id, stringvalue, valuetype, object_id) 
                                SELECT @name, @parent_id, @value, 'null', 0; 
                            ELSE 
                                IF PATINDEX('%[^0-9]%', @value collate SQL_Latin1_General_CP850_Bin) > 0 
                                    INSERT INTO @hierarchy (name, parent_id, stringvalue, valuetype, object_id) 
                                    SELECT @name, @parent_id, @value, 'real', 0; 
                                ELSE 
                                    INSERT INTO @hierarchy (name, parent_id, stringvalue, valuetype, object_id, bigintvalue) 
                                    SELECT @name, @parent_id, @value, 'bigint', 0, dbo.TryConvertBigInt(@value); 
                                 
        END /* WHILE PATINDEX */ 
     
    END /* WHILE 1=1 forever until there is nothing more to do */ 
     
    INSERT INTO @hierarchy (name, parent_id, stringvalue, object_id, valuetype) 
    SELECT '', 0, '', @parent_id - 1, @type; 
     
    RETURN; 
 
END 

TSQL 小數轉分數-fn_DftOf

Create [dbo].[fn_DftOf](@JSON nvarchar(2000))
RETURNS varchar(100)
as 
begin
  -----------------
  --小數轉分數-----
  -----------------
  declare
    @type varchar(50)='',
    @value varchar(50)='',
    @num1 varchar(50)='',
    @num2 varchar(50)=''
 
  declare
    @sStr    varchar(50),
    @iValue  decimal(12,6),
    @sResult varchar(50),
    @sFh     varchar(20)='', --負數符號
    @sZs     varchar(20),    --整數 
    @sXs     varchar(20),    --小數 
    @iPos    int,            --小數點位置 
    @iFm     int,            --分母 
    @iFz     int,            --分子 
    @iZdgys  int             --最大公約數
   
  declare
    @iYs int, --餘數
    @iNum1 int,
    @iNum2 int 
   
  select @type=stringvalue from dbo.fn_parsejson(@JSON) where name='type' 
  select @value=stringvalue from dbo.fn_parsejson(@JSON) where name='value'
  select @num1=stringvalue from dbo.fn_parsejson(@JSON) where name='num1'
  select @num2=stringvalue from dbo.fn_parsejson(@JSON) where name='num2'
 
  ------------------------------------------------------------------------------------------------------------------------
  ------------------------------------------------------------------------------------------------------------------------
  --小數轉分數
  ------------------------------------------------------------------------------------------------------------------------
  ------------------------------------------------------------------------------------------------------------------------
  if @type=''
  begin
    --select dbo.fn_DftOf('{"value":"0.5"}')
    --select dbo.fn_DftOf('{"value":"-3.5"}')
    --select dbo.fn_DftOf('{"value":"90.000000"}')
    --select dbo.fn_DftOf('{"value":"90"}')
    --select dbo.fn_DftOf('{"value":"26.156250"}')
   
    set @iValue = Convert(Decimal(12,6), @value)
    if @iValue<0
      set @sFh = '-'
    set @sZs = Convert(varchar(50), Abs(Cast(@iValue as int))) --整數 
    set @iValue = @iValue - cast(@iValue  as int)         --Ex: -1.2345 -> -0.2345
    set @iValue = Abs(@iValue)                            --Ex: -0.2345 -> 0.2345
    set @sXs = Convert(varchar(50), @iValue)
    set @sXs = convert(varchar(50), convert(int, right(@sXs, len(@sXs)-2))) --小數
 
    if @sXs = '0'
    begin
      return @sZs --純整數
    end
    else
    begin

      set @iFz = convert(int, @sXs)   --分子
      set @iFm = power(10, len(@sXs)) --分母 
      set @iZdgys = (select dbo.fn_DftOf('{"type":"getZDGYS", "num1":"'+convert(varchar(10), @iFm)+'", "num2":"'+convert(varchar(10), @iFz)+'"}')) --求最大公約數 
      set @sResult = convert(varchar(50),(@iFz/@iZdgys))+'/'+convert(varchar(50),(@iFm/@iZdgys))


      if @sZs='0'
        set @sZs = ''
      else
        set @sZs = @sZs +'-' --整數與分數的連接符號

      if @sFh='-'
        set @sResult = '-(' + @sZs + @sResult + ')' --Ex: -(3-1/2)
      else
        set @sResult = @sZs + @sResult              --Ex:   3-1/2
    end
   
    return @sResult
  end
  ------------------------------------------------------------------------------------------------------------------------
  ------------------------------------------------------------------------------------------------------------------------
  --取最大公約數
  ------------------------------------------------------------------------------------------------------------------------
  ------------------------------------------------------------------------------------------------------------------------
  else if @type='getZDGYS'
  begin
    --select dbo.fn_DftOf('{"type":"getZDGYS", "num1":"10", "num2":"5"}') --求最大公約數 
    --select dbo.fn_DftOf('{"type":"getZDGYS", "num1":"100", "num2":"75"}') --求最大公約數 

    --輾轉相除法
    set @iNum1=convert(int, @num1)
    set @iNum2=convert(int, @num2)
    set @iYs=@iNum1 - @iNum2 * convert(int, @iNum1/@iNum2)  --MOD

    while @iYs <> 0
    begin
      set @iNum1 = @iNum2
      set @iNum2 = @iYs 
      set @iYs   = @iNum1 - @iNum2 * convert(int, @iNum1/@iNum2) --MOD
    end

    set @sResult = convert(varchar(50), @iNum2)

    return @sResult
  end
 
  return '' 
end
 



改編至 http://blog.csdn.net/yzsind/article/details/2604798

SQL 常用數值函式

-------------------------------------------------------------------------------------------------------
--數字
-------------------------------------------------------------------------------------------------------
--取整數 select 
select cast(12.345  as int)
--取小數
select   12.345 - cast(12.345  as int)
-------------------------------------------------------------------------------------------------------
--字串
-------------------------------------------------------------------------------------------------------
--字串前面補零   
select REPLICATE('0',10-LEN(Field)) + RTRIM(CAST(Field AS CHAR)) FROM Table
-------------------------------------------------------------------------------------------------------
--日期
-------------------------------------------------------------------------------------------------------
--年初
select DATEADD(yy, datediff(yy, 0,  getdate()), 0) as 年初
--年底
select DATEADD(yy, datediff(yy, 0,  getdate())+1, -1) as 年底
--月初
select DATEADD(mm, DATEDIFF(mm, '', getdate()), '') as 月初
--月底
select DATEADD(day, -1, DATEADD(mm, DATEDIFF(mm, '', getdate())+1, '')) as 月底
--上月初
select DATEADD(mm, -1, DATEADD(mm, DATEDIFF(mm, '', getdate()), '')) as 上月初
--上月底
select DATEADD(day, -1, DATEADD(mm, DATEDIFF(mm, '', getdate()), '')) as 上月底
--前二個月初
select DATEADD(mm, DATEDIFF(mm, '', getdate())-2, '') as 前二個月初   
--前二個月底           
select DATEADD(day, -1, DATEADD(mm, DATEDIFF(mm, '', getdate())-1, '')) as 前二個月底 
--下個月初
select DATEADD(mm, DATEDIFF(mm, '', getdate())+1, '') as 下個月初 
--下個月底           
select DATEADD(day, -1, DATEADD(mm, DATEDIFF(mm, '', getdate())+2, '')) as 下個月底
--本週起始日_週日起算
select Getdate()-DATEPART(dw, GETDATE()-7)+1 as 本週起始日_週日起算
--本週末_週六
select Getdate()-DATEPART(dw, GETDATE()-7)+7 as 本週末_週六
--本週起始日_週一起算
select Getdate()-DATEPART(dw, GETDATE())+2 as 本週起始日_週一起算
--本週末_週日
select Getdate()-DATEPART(dw, GETDATE())+8 as 本週末_週日
--上週起始日_週日起算
select Getdate()-7-DATEPART(dw, GETDATE()-7)+1 as 上週起始日_週日起算
--上週末(週六)
select Getdate()-7-DATEPART(dw, GETDATE()-7)+7 as 上週末_週六
--上週起始日_週一起算
select Getdate()-7-DATEPART(dw, GETDATE()-7)+2 as 上週起始日_週一起算
--上週末_週日
select Getdate()-7-DATEPART(dw, GETDATE()-7)+8 as 上週末_週日

MSSQL RowID By Group

Select ROW_NUMBER() OVER(PARTITION BY [Field1] ORDER BY [Field1] DESC) AS RowID, *
from [Table]

SQL 找不到要更新的資料列。最後讀取的值已被變更

Ex:

  SQL Server

    Close;
    SQL.Text := 'SET NOCOUNT OFF';
    ExecSQL;

    UpdateBatch();

    Close;
    SQL.Text := 'SET NOCOUNT ON';
    ExecSQL;

SQL 常用日期函式

本週星期一
SELECT DATEADD(wk, DATEDIFF(wk,0,getdate()), 0)

第一個星期一
select DATEADD(wk, DATEDIFF(wk,0,dateadd(dd,6-datepart(day,getdate()),getdate())), 0)

月初
SELECT DATEADD(mm, DATEDIFF(mm,0,getdate()), 0)

月底
SELECT DATEADD(ms,-3,DATEADD(mm, DATEDIFF(m,0,getdate())+1, 0))   

上個月底
SELECT DATEADD(ms,-3,DATEADD(mm, DATEDIFF(mm,0,getdate()), 0))

年初
SELECT DATEADD(yy, DATEDIFF(yy,0,getdate()), 0)

年底
SELECT DATEADD(ms,-3,DATEADD(yy, DATEDIFF(yy,0,getdate())+1, 0))

去年底
SELECT DATEADD(ms,-3,DATEADD(yy, DATEDIFF(yy,0,getdate()), 0))

由滑鼠位置取得Form上物件的名稱

procedure TForm1.ApplicationEvents1Message(var Msg: tagMSG;
  var Handled: Boolean);
var pd:TPoint;
  WinCon : TWinControl;
  WND : HWND;
  cmpComponent:TComponent;
begin
  if Msg.message=WM_MOUSEMOVE then
  begin
    GetCursorPos(pd);
    WND := Handle;
    repeat
      WinCon := FindControl(WND);
      WND := ChildWindowFromPoint(WinCon.Handle,WinCon.ScreenToClient(pd));
      if (WND = 0) or (not WinCon.Showing) or (not WinCon.CanFocus) then //增加判斷 showing focus
        exit;
    until (WND = WinCon.Handle) or (WinCon.ControlCount <= 0);
    cmpComponent := FindComponent(wincon.Name);
    if Assigned(cmpComponent) then
    begin
      Label1.Caption := cmpComponent.Name;
    end;
  end;
end;

參考:  http://delphi.ktop.com.tw/board.php?cid=168&fid=913&tid=101905

將應用程式建立在Form上

Ex:將小算盤移到Form上

procedure TForm1.Button1Click(Sender: TObject);
var hWndNewParent : THandle;
begin
  hWndNewParent := Findwindow(nil, '小算盤');
  Windows.SetParent(hWndNewParent, Form1.Handle);
end;

tscap32 Delphi Video Capture Component

網路視訊 for Delphi 元件

http://tscap32.sourceforge.net/screenshots.html

判斷檔案是否被開啟

function TForm1.fn_FileInUse(sFileName:String):Boolean;
var HFileRes: HFILE;
begin
  Result := False;
  if not FileExists(sFileName) then
    exit;
  HFileRes := CreateFile(pchar(sFileName), GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  Result := (HFileRes = INVALID_HANDLE_VALUE);
  if not Result then
    CloseHandle(HFileRes);
end;

設定檔案屬性

SetFileAttributes(PChar(sTarget_FileName),  FILE_ATTRIBUTE_ARCHIVE);

QuickReport報表-列表位置

  QuickRep1.CurrentX;
  QuickRep1.CurrentY;

影像處理[灰階化]及[邊緣化]

unit kantendetektion;

interface
uses graphics;

type
  PRGBTriple = ^TRGBTriple;
  TRGBTriple = packed Record
    rgbtBlue: Byte;
    rgbtGreen: Byte;
    rgbtRed: Byte;
  End;
  PRGBLine = ^TRGBLine;
  TRGBLine = Array[0..0] of TRGBTriple;

procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);

implementation

procedure pValInRange( var Val: Integer; const cFrom, cTo: Integer );
begin
  if Val > cTo then
    Val := cTo
  else
  if Val < cFrom then
    Val := cFrom;
end;

function fValInRange( Val: Integer; const cFrom, cTo: Integer ): Integer;
begin
  if Val > cTo then
    Result := cTo
  else
  if Val < cFrom then
    Result := cFrom
  else
    Result := Val;
end;

//nebenfunktion
procedure Gray(var Picture: TBitmap);
var
  sl: PRGBLine;
  x: Integer;
  procedure _Gray(var rgbt: TRGBTriple );
  begin
    with rgbt do
    begin
        {weiß}
      rgbtBlue  := (rgbtBlue+rgbtGreen+rgbtRed) div 3;
      rgbtGreen := rgbtBlue;
      rgbtRed   := rgbtBlue;
    end;
  end;
begin
  sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
  for x := 0 to Picture.Width*Picture.Height-1 do
    _Gray( sl^[x] );
end;

//hautpfunktion
procedure Sobel(var Picture: TBitmap; const EdgeWhite: Boolean = True);
type
  T4 = -2..2;
const
  xMatrix: Array[0..2, 0..2] of T4 =
    ( (-1, 0, 1),
      (-2, 0, 2),
      (-1, 0, 1 ) );
  yMatrix: Array[0..2, 0..2] of T4 =
    ( (1, 2, 1),
      ( 0, 0, 0),
      (-1, -2,-1) );
var
  sl: PRGBLine;
  x, y: Integer;
  i, j: Integer;
  sumX, sumY: Integer;
  Data: Array of Array of Byte;
begin
  Gray(Picture);
  sl := PRGBLine( Picture.Scanline[Picture.Height-1] );
  SetLength(Data, Picture.Width, Picture.Height);
  for y := 0 to Picture.Height-1 do
    for x := 0 to Picture.Width-1 do
      Data[x,y] := sl^[y*Picture.Width+x].rgbtBlue;
  for y := 0 to Picture.Height-1 do
    for x := 0 to Picture.Width-1 do
    begin
      sumX := 0;
      sumY := 0;
      for i := -1 to 1 do
        for j := -1 to 1 do
        begin
          inc( sumX, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*xMatrix[i+1,j+1] );
          inc( sumY, Data[fValInRange(x+i, 0, Picture.Width-1),fValInRange(y+j, 0, Picture.Height-1)]*yMatrix[i+1,j+1] );
        end;
      sumX := Abs(sumX)+Abs(sumY);
      pValInRange( sumX, 0, $FF );
      with sl^[y*picture.Width+x] do
      begin
        if EdgeWhite then
          rgbtBlue := sumX
        else
          rgbtBlue := $FF-sumX;
        rgbtGreen := rgbtBlue;
        rgbtRed := rgbtBlue;
      end;
    end;            
end;
end.

轉貼至 http://www.delphipraxis.net/post995075.html

如何自動註冊Midas.DLL

D7 版本, 只要 USES MIDASLIB 即可, 就不用註冊 MIDAS.DLL 了

轉貼:http://delphi.ktop.com.tw/board.php?cid=30&fid=68&tid=26133

如何以Code叫出AdoConnection.ConnectionString的編修畫面來

uses ADOConEd;


{$R *.DFM}

procedure TForm1.Button1Click(Sender: TObject);
begin
    EditConnectionString(ADOConnection1);
end;

轉貼: http://delphi.ktop.com.tw/board.php?cid=30&fid=66&tid=58392

如何清空鍵盤的緩衝區(Buffer)

如何清空鍵盤的緩衝區(Buffer)?
可用於進入某個輸入的TFrom前清空Keyboard Buffer,以免誤輸入錯誤的資料!

procedure EmptyKeyQueue;
var msg: TMsg;
begin
  while PeekMessage(msg, 0, WM_KEYFIRST, WM_KEYLAST, PM_REMOVE or PM_NOYIELD) do;
end;

轉貼至:http://delphi.ktop.com.tw/board.php?cid=16&fid=49&tid=18231

搜尋目錄內的檔案名稱

var sSourcePath:String;
  iSearchRec: TSearchRec;
  iStatus: Integer;
begin
  sSourcePath := 'C:';
  iStatus := FindFirst(sSourcePath+'\*.*', faAnyFile, iSearchRec);
  try
    while iStatus = 0 do
    begin
      if ((iSearchRec.Attr and faDirectory) <> faDirectory) and //非目錄
        ((iSearchRec.Attr and faHidden)<>faHidden) and //非隱藏檔
        ((iSearchRec.Attr and faSysFile)<>faSysFile) and //非系統檔
        (iSearchRec.Name <> '.') and
        (iSearchRec.Name <> '..') then
      begin
        ...
        ...
      end;
      iStatus := FindNext(iSearchRec);
    end;
  Finally
    FindClose(iSearchRec);
  end;
end

設定報表內的表格框(QRShape) 與 動態高度的Band 同高度

QRShape.Size.Height := ChildBand.Size.Height + ChildBand.Expanded;

ChildBand.Size.Height 與 ChildBand.Expanded取得的是圖像點數
圖像點數*0.37795(QuickRpt裡pixfactor記錄的系數)=屬性中的高度(Height)

取得、變更預設印表機

uses
  Printers, Messages;

//取得預設印表機資訊
function GetDefaultPrinter: string;
var
  ResStr: array[0..255] of Char;
begin
  GetProfileString('Windows', 'device', '', ResStr, 255);
  Result := StrPas(ResStr);
end;

//設定預設印表機, 使用GetDefaultPrinter取得的印表機完整資訊來變更
//參數字串已含有Port的資訊
procedure SetDefaultPrinter1(NewDefPrinter: string);
var
  ResStr: array[0..255] of Char;
begin
  StrPCopy(ResStr, NewdefPrinter);
  WriteProfileString('windows', 'device', ResStr);
  StrCopy(ResStr, 'windows');
  SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@ResStr));
end;

//設定預設印表機, 取Printer.Printers裡的印表機名稱來變更
//參數字串只有印表機名稱
procedure SetDefaultPrinter2(PrinterName: string);
var
  I: Integer;
  Device: PChar;
  Driver: PChar;
  Port: PChar;
  HdeviceMode: THandle;
  aPrinter: TPrinter;
begin
  Printer.PrinterIndex := -1;
  GetMem(Device, 255);
  GetMem(Driver, 255);
  GetMem(Port, 255);
  aPrinter := TPrinter.Create;
  try
    for I := 0 to Printer.Printers.Count - 1 do
    begin
      if Printer.Printers[I] = PrinterName then
      begin
        aprinter.PrinterIndex := I;
        aPrinter.getprinter(device, driver, port, HdeviceMode);
        StrCat(Device, ',');
        StrCat(Device, Driver);
        StrCat(Device, Port);
        WriteProfileString('windows', 'device', Device);
        StrCopy(Device, 'windows');
        SendMessage(HWND_BROADCAST, WM_WININICHANGE, 0, Longint(@Device));
      end;
    end;
  finally
    aPrinter.Free;
  end;
  FreeMem(Device, 255);
  FreeMem(Driver, 255);
  FreeMem(Port, 255);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  label1.Caption := GetDefaultPrinter;
end;

//Fill the combobox with all available printers
procedure TForm1.FormCreate(Sender: TObject);
begin
  Combobox1.Items.Clear;
  Combobox1.Items.AddStrings(Printer.Printers);
end;

//Set the selected printer in the combobox as default printer
procedure TForm1.Button2Click(Sender: TObject);
begin
  SetDefaultPrinter2(Combobox1.Text);
end;

轉貼至http://www.swissdelphicenter.ch/en/showcode.php?id=660

設定Caps Lock ON或OFF

==================================================
procedure SetCapsLockKey( vcode: Integer; down: Boolean );
begin
    if Odd(GetAsyncKeyState( vcode )) <> down then
    begin
    keybd_event( vcode, MapVirtualkey( vcode, 0 ),
        KEYEVENTF_EXTENDEDKEY, 0);
    keybd_event( vcode, MapVirtualkey( vcode, 0 ),
        KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP, 0);
    end;
end;
===================================================
在BUTTOM1之Click事件中加入以下：

SetcapsLockKey( VK_CAPITAL, True );

如此按下按鈕就可設定CAPS LOCK啟動或是關閉

轉貼至  http://delphi.ktop.com.tw/board.php?cid=16&fid=43&tid=355

Hook簡介

http://www.bravos.com.tw/big5/tutor/Profession/Hook/
Hook簡介
       

MSDN的定義:

A hook is a point in the system message-handling mechanism where an application can install a subroutine to monitor the message traffic in the system and process certain types of messages before they reach the target window procedure.


       

Hook應用簡介:

Hook是用來與作業系統掛勾進而攔截並處理某些訊息之用。

例如說，我們想讓系統不管在什麼地方只要按個Ctl-N便執行NotePad，或許您會使用Form的KeyPreview，設定為True，但在其他Process中按Ctl-N呢？那就沒有用，這是就得設一個KeyboardProc來攔截所有Key in的鍵；

   

再如：線上翻譯軟體(如：易點通) 應用Hook功能中WH_MOUSE的來欄截Mouse的訊息。進而解析滑鼠所在位置的string token以便由資料庫中萃取對應的翻譯字句。

再如：UltraEditor中錄製巨集功能即使用Hook功能中的WH_JOURNALRECORD，執行巨集功能，即使用Hook功能中的WH_JOURNALPLAYBACK；

再如：ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。其內部即應用Hook功能中的WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。

   

Hook可以是整個系統為範圍(Remote Hook)，即其他Process的動作您也可以攔截，也可以是LocalHook，它的攔截範圍只有Process本身。Remote Hook的Hook Function要在.Dll之中，Local Hook則可包含在專案模組中。

Remote Hook的應用實例，線上翻譯軟體(如：易點通)、鍵盤輸入法(如：自然輸入法)，熱鍵攔截(如：TurboLaunch)。

由上數列舉可知Hook的應用幾乎是無所不在的，您能禁得起這般強悍的功能而不去學習它嗎?


   

轉載網路上一篇關於hook有趣的描述:

hook鉤子也，windows是訊息導向的，當有事情發生時windows會發出通知告訴你，像"失火了","房子倒了"之類的，於是你對這些訊息做出 反應，windows程式大概就是這種架構。而hook的用處就是可以在windows送訊息給你的時候把訊息攔截下來。

你可以想像你的程式是皇帝，而windows是宰相，而hook是太監；如果話是從宰相口中親耳聽到的八成假不了，如果話是太監口中聽到的，說不定就變質 了，hook的功用就是在這裡，所以你可以寫一個文字編輯器，然後掛上一個hook，並且用這個hook把鍵盤訊息攔截下來，然後把它丟掉，於是你的文字 編輯器就沒有作用了，所以說宦官能搞亂朝政。

當然大部分人不會做這總傻事，大部分寫hook都是為了攔截整個系統的訊息或是假裝訊息給別人，這個時候你就必須把hook寫在dll裡了，然後用你的程 式啟動dll裡的hook，由於dll會載入到所有的人的行程裡，所以你就可以利用她偷竊別人的東西或是假傳聖旨，例如你可以抓別人的視窗handle然 後用你的程式對她丟訊息，比較值得注意的是，在dll裡你必須將要用來共享的資料設成shared，這樣才能去抓別的程式的資料，因為dll雖然存在於每 個人的行程裡，但是資料都是獨立的，也就是每個人都有一分，如果你把用來共享的資料設成shared，那這筆記憶體區塊就只有一份，於是就可以拿來偷東西 了


   

Hook程式必備的API
   

l
SetWindowsHookEx

   
The SetWindowsHookEx function installs an application-defined hook procedure into a hook chain. You would install a hook procedure to monitor the system for certain types of events. These events are associated either with a specific thread or with all threads in the system.

   
HHOOK SetWindowsHookEx(

   
int idHook,
hook型態,常用型態例如：WH_CALLWNDPROC

   
HOOKPROC lpfn,
自訂的hook procedure 之回呼函式,其prototype會依idHook(hook型態)而異

   
HINSTANCE hMod,
應用程式或DLL之instance

如果是Remote Hook，則可以使用GetModuleHandle(".dll名稱")來傳入。

如果是Local Hook，該值可以是NULL

   
DWORD dwThreadId);
指定要攔截訊息之thread ID,若為0則攔截系統中所有thread之訊息

   
回傳值:
如果SetWindowsHookEx()成功，它會傳回一個值，代表目前的Hook的Handle，這個值要記錄下來以提供UnHookWindowHookEx() (可用於 unhook時之參數)

   
   
   








　

l
UnhookWindowsHookEx

   
釋放移除先前經由SetWindowsHookEx()所註冊的hook handle resource.

   
BOOL UnhookWindowsHookEx(HHOOK hHook);

   
hHook,
便是SetWindowsHookEx()的傳回值








l
CallNextHookEx

   
The CallNextHookEx function passes the hook information to the next hook procedure in the current hook chain. A hook procedure can call this function either before or after processing the hook information.

   
LRESULT CallNextHookEx(

   
HHOOK hHook,
handle to current hook

   
int nCode,
hook code passed to hook procedure

   
WPARAM wParam,
value passed to hook procedure

   
LPARAM lParam);
value passed to hook procedure

   
CallNextHookEx 使用時機:

   
例如A程式可以有一個System Hook(Remote Hook)，如KeyBoard Hook，而B程式也來設一個Remote的KeyBoard Hook，那麼到底KeyBoard的訊息誰所攔截？答案是，最後的那一個所攔截，也就是說A先做keyboard Hook，而後B才做，那訊息被B攔截，那A呢？就看B的Hook Function如何做。如果B想讓A的Hook Function也得這個訊息，那B就得呼叫CallNextHookEx()將這訊息Pass給A，於是產生Hook的一個連線。如果B中不想Pass 這訊息給A，那就不要呼叫CallNextHookEx()。




        Hook-C++範例
   

本範例利用Hook技巧以攔截Microsoft Visual C++ Dialog Box，因為此為Remote Hook故需以DLL包裝

// HookVc.DLL

// 本模組開放兩個介面函式供外部程式呼叫

// * HookVcWndProc()    ==> 啟動攔截 VC 的視窗訊息

// * UnHookVcWndProc() ==> 終止攔截 VC 的視窗訊息

HINSTANCE g_hInst = NULL;

static HWND s_hWndVc = NULL;    // VC 的 Window Handle

static HHOOK s_hHook = NULL;    // Hook Handle ID

int WINAPI DllEntryPoint(HINSTANCE hinst, unsigned long reason, void*)

{

    g_hInst = hinst;

    return 1;

}

BOOL HookVcWndProc()

{

    // 找出VC主視窗 Window Handle

    EnumWindows((WNDENUMPROC)EnumWindowsProc, NULL);

    DWORD dwVcThreadId;

    if (s_hWndVc && g_hInst) {

        // 找出產生VC主視窗的ThreadID

        dwVcThreadId = GetWindowThreadProcessId(s_hWndVc, NULL);

        if (dwVcThreadId)

        // 於系統Send Message給VC處理後攔截

s_hHook=SetWindowsHookEx(WH_CALLWNDPROCRET,      

        (HOOKPROC)CallWndRetProcHook, // 自訂的hook procedure之回呼函式

        g_hInst,        // this Dll's instance

        dwVcThreadId);        // thread you want to hook, here it's VC

        if (s_hHook) return TRUE; // 啟動攔截 VC 的視窗訊息成功

    }

    return FALSE;        // 啟動攔截 VC 的視窗訊息失敗

} // HookVcWndProc

void UnHookVcWndProc()

{

    if (s_hHook) {

        UnhookWindowsHookEx(s_hHook); s_hHook = NULL ;

    }

} // UnHookVcWndProc

// 自訂的hook procedure之回呼函式

// nCode: 若 nCode<0 ==>不處理

// lParam: Pointer to CWPRETSTRUCT, 訊息詳細資料

LRESULT CALLBACK CallWndRetProcHook(int nCode, WPARAM wParam, LPARAM lParam)

{

    // Buffer for storing the window title.

    TCHAR szBuff[ MAX_PATH ] ;

    // 傳遞訊息給可能存在的下一個 Hook procedure

    LRESULT lRet=CallNextHookEx(s_hHook, nCode, wParam, lParam);

    // 若 nCode<0 ==>不繼續處理 (請參照 MSDN 'HOOKPROC', 'CallWndRetProc'文件說明)

    if ( nCode < 0 ) return lRet;

    // 取得訊息詳細資料 CWPRETSTRUCT *

    PCWPRETSTRUCT pMsg = (PCWPRETSTRUCT)lParam;

    // 以下利用 pMsg->hwnd, pMsg->message, pMsg->wParam, pMsg->lParam繼續處理

    // ...

    return lRet;

} // CallWndRetProcHook


Hook-Delphi範例
   

使用過ICQ嗎？ICQ會在User不輸入滑鼠或鍵盤idle一陣子時將User由Online的狀態變成Away的狀態。本範例利用Hook型態 WH_MOUSE, WH_KEYBOARD 以攔截所有Mouse及Keyboard動作。當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event

l
TBvIdleCheck元件功能描述:

   
A user idle chekcing Component, apply the mouse/keyboard hook callback to check user idle time on application level.

當使用者於預定時限當中不輸入滑鼠或鍵盤時，本元件會觸發一個OnIdle notify event

l
Properties

   
Active:
true èstart check, false èstop check

   
Interval:
Idle checking pooling time frequency (in second)

   
IdleTime:
Define the IdleTime criteria (in second)

l
Notify Event:

   
OnIdle:
notify event happened when user mouse and keyboard idle time out

   
   

程式碼片段:

// Mouse Hook 回呼函數內容

function MouseHookCallBack(Code: integer; Msg: WPARAM; MouseHook: LPARAM): LRESULT; stdcall;

begin

    if Code >= 0 then s_tIoEvent := Now; // 紀錄 Mouse IO 時發生之時間

    Result := CallNextHookEx(s_WhMouse, Code, Msg, MouseHook);

end;

// Keyboard Hook 回呼函數內容

function KeyboardHookCallBack(Code: integer; Msg: WPARAM; KeyboardHook: LPARAM): LRESULT; stdcall;

begin

    if Code >= 0 then s_tIoEvent := Now; // 紀錄 Keyboard IO 時發生之時間

    Result := CallNextHookEx(s_WhKeyboard, Code, Msg, KeyboardHook);

end;

// Construtor

constructor TBvIdleCheck.Create(AOwner: TComponent);

begin //[

    inherited Create(AOwner);

    ....

    Inc(s_nInstances);

    if s_nInstances > 1 then exit;

    // 註冊 Mouse Hook 回呼函數

    s_WhMouse := SetWindowsHookEx(WH_MOUSE, MouseHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);

    // 註冊 Keyboard Hook 回呼函數

    s_WhKeyboard := SetWindowsHookEx(WH_KEYBOARD, KeyboardHookCallBack, GetModuleHandleFromInstance, GetCurrentThreadID);

end; // ] TBvIdleCheck.Create

// Destructor

destructor TBvIdleCheck.Destroy;

begin // [

    Dec(s_nInstances);

    Stop;

    if s_nInstances = 0 then begin

        // 釋放 hook handle

        UnhookWindowsHookEx(s_WhKeyboard); UnhookWindowsHookEx(s_WhMouse);

    end;

    inherited Destroy;

end; // ] TBvIdleCheck.Destroy

// 元件內部檢查 user 是否 idle,

// if yes ==> 觸發 Notify Event

procedure TBvIdleCheck._TimeHit(Sender: TObject);

var

    tNow: TDateTime;

    nSecElapsed: integer;

begin // [

    tNow=Now;

    nSecElapsed=TimeDiffSec(tNow, s_tIoEvent);

    if nSecElapsed
if Assigned(FOnIdle) then FOnIdle(Sender);

    s_tIoEvent:=tNow;

end; // ] TBvIdleCheck._TimeHit


Hook-VB範例
   

本範例展示在VB中利用Hook技巧以攔截應用程式中User按下Print Screen按鍵，因為此為Local Hook故可直接含於project中

'        ======================================================================

'        HookKb.BAS

'        KeyBoard Hook 的範例

'        ======================================================================

Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" _

        (ByVal idHook As Long, _

        ByVal lpfn As Long, _

        ByVal hmod As Long, _

        ByVal dwThreadId As Long) As Long

Declare Function UnhookWindowsHookEx Lib "user32" Alias "UnhookWindowsHookEx" _

        (ByVal hHook As Long) As Long

Declare Function CallNextHookEx Lib "user32" Alias "CallNextHookEx" _

        (ByVal hHook As Long, _

        ByVal ncode As Long, _

        ByVal wParam As Long, _

        lParam As Any) As Long

   

Public g_hHook as Long

   

Public Function HookAppKb() As Boolean

    HookAppKb = true

    If g_hHook <> 0 Then

        Exit Function

    End If

    ' 攔截所有keystroke訊息

    g_hHook = SetWindowsHookEx(WH_KEYBOARD, AddressOf MyKBHFunc, App.hInstance, App.ThreadId)

End Function

   

Public Sub UnHookAppKb()

    If g_hHook <> 0 Then

        UnhookWindowsHookEx g_hHook

        g_hHook = 0

    End If

End Sub

' MyKBHFunc: KeyStroke Hook Function的三個參數

' Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

' iCode HC_ACTION或HC_NOREMOVE

' wParam 表按鍵Virtual Key

' lParam 與WM_KEYDOWN同

' 傳回值 若訊息要被處理傳0反之傳1

Public Function MyKBHFunc(ByVal iCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

    MyKBHfunc = 0 '表示要處理這個訊息

    If wParam = vbKeySnapshot Then '偵測-->若按到PrintScreen鍵

        MyKBHFunc = 1 '在這個Hook便吃掉這個訊息

        ' 處理 User 按到PrintScreen鍵之動作

        ' ....

        Exit Function

    End If

    Call CallNextHookEx(g_hHook, iCode, wParam, lParam) '傳給下一個Hook

End Function

   

下載本範例: http:/dn/tutor/Delphi.Advance/HookKb.zip


轉貼至 Delphi.KTop http://delphi.ktop.com.tw/board.php?cid=31&fid=77&tid=47170

TPopupMenu OnClose Event

Here's the source of the extended PopupList class you need to add to your projects in order to be able to respond when the popup menu is closed:

unit PopupListEx;  
interface  
  uses Controls;  
  const    
    CM_MENU_CLOSED = CM_BASE + 1001;    
    CM_ENTER_MENU_LOOP = CM_BASE + 1002;    
    CM_EXIT_MENU_LOOP = CM_BASE + 1003;  
implementation  
uses Messages, Forms, Menus;  
type  TPopupListEx = class(TPopupList)    
  protected      
    procedure WndProc(var Message: TMessage) ; override;    
  private      
    procedure PerformMessage(cm_msg : integer; msg : TMessage) ;    
end;  
{ TPopupListEx }
procedure TPopupListEx.PerformMessage(cm_msg: integer; msg : TMessage) ;
begin
     if Screen.Activeform <> nil then
       Screen.ActiveForm.Perform(cm_msg, msg.WParam, msg.LParam) ;
end;
procedure TPopupListEx.WndProc(var Message: TMessage) ;
begin
  case message.Msg of
    WM_ENTERMENULOOP: PerformMessage(CM_ENTER_MENU_LOOP, Message) ;
    WM_EXITMENULOOP : PerformMessage(CM_EXIT_MENU_LOOP, Message) ;
    WM_MENUSELECT :
      with TWMMenuSelect(Message) do      
      begin        
        if (Menu = 0) and (Menuflag = $FFFF) then
        begin
          PerformMessage(CM_MENU_CLOSED, Message) ;
        end;
      end;
  end;    
  inherited;
end;  

initialization;
Popuplist.Free; //free the "default", "old" list    
PopupList:= TPopupListEx.Create; //create the new one    
// The new PopupList will be freed by    
// finalization section of Menus unit.
end.

Here's how to use the PopupListEx unit:
Drop a TPopupMenu on a Delphi form
Add several menu items to the PopupMenu
Include the "PopupListEx" in the uses clause
Write a procedure to handle PopupListEx's messages: CM_MENU_CLOSED, CM_ENTER_MENU_LOOP and CM_EXIT_MENU_LOOP
An example implementation (download):

uses PopupListEx, ...  
TForm1 = class(TForm)  ...
private    
  procedure CM_MenuClosed(var msg: TMessage) ; message CM_MENU_CLOSED;    
  procedure CM_EnterMenuLoop(var msg: TMessage) ; message CM_ENTER_MENU_LOOP;    
  procedure CM_ExitMenuLoop(var msg: TMessage) ; message CM_EXIT_MENU_LOOP;  ...
implementation  
procedure TForm1.CM_EnterMenuLoop(var msg: TMessage) ;
begin
  Caption := 'PopMenu entered';
end;
procedure TForm1.CM_ExitMenuLoop(var msg: TMessage) ;
begin    
  Caption := 'PopMenu exited';
end;  
procedure TForm1.CM_MenuClosed(var msg: TMessage) ;
begin    
  Caption := 'PopMenu closed';
end;

轉貼至 http://delphi.about.com/od/adptips2006/qt/popuplistex.htm

[轉貼]如何正確捕捉滑鼠及其原理(附範例)

在Win95, WinNT 的環境下, Microsoft為了避免行程間互相干擾,
對於使用者輸入的部份(如鍵盤, 滑鼠), 是採用一種叫"Local
Input State Processing"的方式, 這種技術簡單來說, 就是每個
行程, 執行緒, 認為自已是唯一取得使用者輸入的, 彼此之間並
不互相干擾(其實真正取得使用者輸入的只有 Active的行程或執行緒).

而我們最常用來抓取螢幕座標的 SetCapture , 是以System-Wide 的
型式來實作的, 所以就算滑鼠不在你的程式視窗範圍內, 也可以抓到
座標, 但是當你把滑鼠按鍵放開, 系統會改變滑鼠捕捉權, 使其為
Thread-Local-Wide, 此時就算你沒有使用 ReleaseCapture 來釋放
滑鼠捕捉權, 也無法在視窗範圍外捕捉滑鼠.這是因為 Local Input
State Processing 的關係. 若要解決這個問題, 最好的方法就是暫
時把 Local Input State Processing 的功能關閉, 而方式就是掛上
一個 Journal Record Hook, 在Win95, NT 下因為Local Input State
Processing 和 Journal Record Hook 會互相干擾, 而Microsoft為了
向下相容性所以當Journal Record Hook 被掛起來時, 就會把 Local
Input State Processin 給關閉.

範例貼在下一篇, 此測試程式會把攔截到的滑鼠座標以 Label1 秀出.
   
測試方法, 首先按下"SetCapture"按鈕, 在程式視窗範圍內, 按下滑鼠
左鍵不放, 將滑鼠移出程式視窗, 此時可以發現, 即使在程式視窗範圍
外還是可以捕捉到滑鼠. 之後把滑鼠左鍵放開, 在移動滑鼠, 可以發現,
在放開滑鼠左鍵後,即使我們沒有呼叫ReleaseCapture, 也無法捕捉到滑
鼠.

接下來我們按下"SetCapture with Journal Record Hook"按鈕, 按下後
首先程式會先呼叫SetCapture, 之後在掛上 Journal Record Hook, 而此
Hook 沒做什麼事, 只是把值傳給下一個Hook(CallNextHookEx), 在我們
按下這按鈕後, 無論怎麼移動滑鼠, 無論有沒有按下滑鼠左鍵, 都可以收
到滑鼠座標.


範例:

unit Unit1;

interface

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

type
    TForm1 = class(TForm)
    Label1: TLabel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    Button4: TButton;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure Button4Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    private
    { Private declarations }

    Procedure HandleMouseMsg(var msg: TMessage); Message WM_MOUSEMOVE;

    public
    { Public declarations }
    end;

var
    Form1: TForm1;
    hJourHook: HHOOK;
   
implementation

{$R *.DFM}

Procedure TForm1.HandleMouseMsg(var msg: TMessage);
begin
    Label1.Caption := Format( 'x=%d, y=%d',
        [LOWORD(msg.Lparam), HIWORD(msg.Lparam)]);
    Application.ProcessMessages;
end;

Function JournalRecordProc( code: Integer;
        WParamInfo: WPARAM;
        LParamInfo: LPARAM): Integer; stdcall;
begin
    Result := CallNextHookEx(hJourHook, code, WParamInfo, LParamInfo);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
    SetCapture(Handle);
    SetWindowsHookEx(WH_JOURNALRECORD, @JournalRecordProc, HInstance, 0);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
    ReleaseCapture();
    UnhookWindowsHookEx(hJourHook);
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
    SetCapture(Handle);
end;

procedure TForm1.Button4Click(Sender: TObject);
begin
    ReleaseCapture();
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
    Button1.Caption := 'SetCapture with Journal Record Hook';
    Button2.Caption := 'ReleaseCapture with Journal Record Hook';
    Button3.Caption := 'SetCapture';
    Button4.Caption := 'ReleaseCapture';
end;

end.

轉貼至:http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=58460

等待外部執行檔結束作業後, 再繼續執行後續的程式碼

uses ShellAPI;

procedure TForm1.pr_WaitForProcess(sFile, sParameter:String);
var
    ExitCode: cardinal;
    ExecInfo: TShellExecuteInfo;
begin
  ZeroMemory(@ExecInfo,SizeOf(ExecInfo));
  with ExecInfo do
  begin
    cbSize := SizeOf(ExecInfo);
    fMask := SEE_MASK_NOCLOSEPROCESS;
    lpVerb := 'open';
    lpFile := PChar(sFile); //執行檔檔名
    lpParameters := PChar(sParameter); //參數
    Wnd := 0;
    nShow := SW_SHOWNORMAL;
  end;
  ShellExecuteEx(@ExecInfo);
  GetExitCodeProcess(ExecInfo.hProcess,ExitCode);
  while ExitCode=STILL_ACTIVE do
  begin
    GetExitCodeProcess(ExecInfo.hProcess, ExitCode);
    sleep(10);
    Application.ProcessMessages;
  end;
end;




fatmoon1 對直接取用ShellExecute回傳值使用於WaiteforSingleObject的見解

引言:
引言:

procedure TForm1.Button1Click(Sender: TObject);
var
    aHandle: Hwnd;
begin
    //WinExec('D:\WinRAR\Rar.exe a -r E:\ShareFile.rar E:\ShareFile', SW_SHOWNORMAL);
    aHandle := ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
    WaitForSingleObject(aHandle, INFINITE);
    ShowMessage('成功!')
end;


雖然已經有正確解答了,但我針對上述方法會失敗的原因來回應
上述方法會失敗的原因是因為
aHandle:=ShellExecute(Self.Handle, 'Open', 'rar.exe', ' a -r E:\ShareFile.rar E:\ShareFile', 'D:\WinRAR\', SW_SHOWNORMAL);
如此的話aHandle只是存入ShellExecute的回傳值(成功的話回傳值會大於32)
所以WaitForSingleObject(aHandle, INFINITE);此行根本沒等到正確的Handle值

而WaitForSingleObject(hHandle: THandle; dwMilliseconds: DWORD);
這個函式的作用是 等候 hHandle(執行程式的Handle值) dwMilliseconds(ms)
所以經過dwMilliseconds(ms)後仍會執行下一行
所以要改寫成

var Result: Boolean;
    ShellExInfo: TShellExecuteInfo;
begin
    FillChar(ShellExInfo, SizeOf(ShellExInfo), 0);
    with ShellExInfo do begin
    cbSize := SizeOf(ShellExInfo);
    fMask := see_Mask_NoCloseProcess;
    Wnd := Application.Handle;
    lpFile := 'D:\WinRAR\Rar.exe';
    lpDirectory := 'D:\WinRAR\';
    lpParameters := ' a -r E:\ShareFile.rar E:\ShareFile';
    nShow := SW_SHOWNORMAL;
    end;
//上述程式碼與william兄是一樣的,不一樣的在下方
    Result := ShellExecuteEx(@ShellExInfo);
    if Result then
    while WaitForSingleObject(ShellExInfo.HProcess, 100) = WAIT_TIMEOUT do
    begin
        Application.ProcessMessages;
        if Application.Terminated then Break;
    end;
end;


=========================
fat eat moon,fat eat moon

轉貼至 http://delphi.ktop.com.tw/board.php?cid=30&fid=72&tid=38858

取得Service 檔案名稱

function TService1.fn_GetServiceFilenName:String;
var  strBuf: array[1..512] of Char;
  sFileName:String;
begin
  ZeroMemory(@strBuf, 512);
  GetModuleFileName(GetModuleHandle(nil), @strBuf, 512);
  sFileName := Trim(strBuf);
  Result := sFileName
  Result := ExtractFileDir(sFileName); //回傳路徑
end;

[範例]DLL編寫與呼叫

DLL project

library Dll_procedure;

uses
  SysUtils, Classes,
  Windows, ExtCtrls;

{$R *.res}


function fn_StrToInt(sValue:String):Integer; stdcall;
begin
  Result := StrToInt(sValue);
end;

exports fn_StrToInt;

begin
end.

----------------------------------------------------
Text Project - Call Dll

unit Unit1;

interface

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

type
  TForm1 = class(TForm)
    BitBtn1: TBitBtn;
    procedure BitBtn1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

function fn_StrToInt(sValue:String):Integer; stdcall; External 'Dll_procedure.dll';

var
  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.BitBtn1Click(Sender: TObject);
var sStr:String;
  i:Integer;
begin
  sStr := '123';
  i := fn_StrToInt(sStr);
  sStr := IntToStr(i);
  showmessage(sStr);
end;


end.

ShellExecute如何開啟徢徑(*.lnk)

ShellExecute(Handle, Operation, File, Parameters,  Directory, ShowCmd);

一般使用方式
  Ex:ShellExecute(Handle, 'Open', PChar('c:\test.exe'), '',  '', SW_SHOW);

開啟徢徑(*.lnk)時, 將檔案的完整檔名 "\"字元改成 "/"字元即可
  Ex:ShellExecute(Handle, 'Open', PChar('c:/test.exe'), '',  '', SW_SHOW);

取得Service 所在的路徑

var
  szPath: array [0..1024] of Char;

begin
  // 取得程式所在根目錄
  ZeroMemory(@szPath,sizeof(szPath));
  GetModuleFileName(0,szPath,sizeof(szPath));
  //result szPath='c:\path\test.exe'
  ---
end;

取視窗的圖示(ICON)

var hWnd:THandle;
  icon:TIcon;
begin
  hWnd := application.Handle;
  icon := TIcon.Create;
  icon.Handle := SendMessage(hWnd, WM_GETICON, ICON_BIG, 0);
  Self.Canvas.Draw(0,0,icon);
end;

[轉貼]Delphi基本圖像處理代碼

Delphi基本图像处理代码

//浮雕
procedure Emboss(SrcBmp,DestBmp:TBitmap;AzimuthChange:integer);overload;
var
  i, j, Gray, Azimuthvalue, R, G, B: integer;
  SrcRGB, SrcRGB1, SrcRGB2, DestRGB: pRGBTriple;
begin
  for i := 0 to SrcBmp.Height - 1 do
  begin
    SrcRGB := SrcBmp.ScanLine[i];
    DestRGB := DestBmp.ScanLine[i];

    if (AzimuthChange >= -180) and (AzimuthChange < -135) then
    begin
      if i > 0 then
        SrcRGB1 := SrcBmp.ScanLine[i-1]
      else
        SrcRGB1 := SrcRGB;
      Inc(SrcRGB1);
      SrcRGB2 := SrcRGB;
      Inc(SrcRGB2);
    end
    else if (AzimuthChange >= -135) and (AzimuthChange < -90) then
    begin
      if i > 0 then
        SrcRGB1 := SrcBmp.ScanLine[i-1]
      else
        SrcRGB1 := SrcRGB;
      SrcRGB2 := SrcRGB1;
      Inc(SrcRGB2);
    end
    else if (AzimuthChange >= -90) and (AzimuthChange < -45) then
    begin
      if i > 0 then
        SrcRGB1 := SrcBmp.ScanLine[i-1]
      else
        SrcRGB1 := SrcRGB;
      SrcRGB2 := SrcRGB1;
    end
    else if (AzimuthChange >= -45) and (AzimuthChange < 0) then
    begin
      SrcRGB1 := SrcRGB;
      if i > 0 then
        SrcRGB2 := SrcBmp.ScanLine[i-1]
      else
        SrcRGB2 := SrcRGB;
    end
    else if (AzimuthChange >= 0) and (AzimuthChange < 45) then
    begin
      SrcRGB2 := SrcRGB;
      if (i < SrcBmp.Height - 1) then
        SrcRGB1 := SrcBmp.ScanLine[i+1]
      else
        SrcRGB1 := SrcRGB;
    end
    else if (AzimuthChange >= 45) and (AzimuthChange < 90) then
    begin
      if (i < SrcBmp.Height - 1) then
        SrcRGB1 := SrcBmp.ScanLine[i+1]
      else
        SrcRGB1 := SrcRGB;
      SrcRGB2 := SrcRGB1;
    end
    else if (AzimuthChange >= 90) and (AzimuthChange < 135) then
    begin
      if (i < SrcBmp.Height - 1) then
        SrcRGB1 := SrcBmp.ScanLine[i+1]
      else
        SrcRGB1 := SrcRGB;
      SrcRGB2 := SrcRGB1;
      Inc(SrcRGB1);
    end
    else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then
    begin
      if (i < SrcBmp.Height - 1) then
        SrcRGB2 := SrcBmp.ScanLine[i+1]
      else
        SrcRGB2 := SrcRGB;
      Inc(SrcRGB2);
      SrcRGB1 := SrcRGB;
      Inc(SrcRGB1);
    end;

    for j := 0 to SrcBmp.Width - 1 do
    begin
      if (AzimuthChange >= -180) and (AzimuthChange < -135) then
      begin
        Azimuthvalue := AzimuthChange + 180;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= -135) and (AzimuthChange < -90) then
      begin
        Azimuthvalue := AzimuthChange + 135;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= -90) and (AzimuthChange < -45) then
      begin
        if j=1 then Inc(SrcRGB1,-1);
        Azimuthvalue := AzimuthChange + 90;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= -45) and (AzimuthChange < 0) then
      begin
        if j=1 then
        begin
          Inc(SrcRGB1,-1);
          Inc(SrcRGB2,-1);
        end;
        Azimuthvalue := AzimuthChange + 45;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= 0) and (AzimuthChange < 45) then
      begin
        if j=1 then
        begin
          Inc(SrcRGB1,-1);
          Inc(SrcRGB2,-1);
        end;
        Azimuthvalue := AzimuthChange;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= 45) and (AzimuthChange < 90) then
      begin
        if j=1 then Inc(SrcRGB2,-1);
        Azimuthvalue := AzimuthChange - 45;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= 90) and (AzimuthChange < 135) then
      begin
        Azimuthvalue := AzimuthChange - 90;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end
      else if (AzimuthChange >= 135) and (AzimuthChange <= 180) then
      begin
        Azimuthvalue := AzimuthChange - 135;
        R:=SrcRGB.rgbtRed-((SrcRGB1.rgbtRed)*Azimuthvalue div 45)-((SrcRGB2.rgbtRed)*(45-Azimuthvalue) div 45)+78;
        G:=SrcRGB.rgbtGreen-((SrcRGB1.rgbtGreen)*Azimuthvalue div 45)-((SrcRGB2.rgbtGreen)*(45-Azimuthvalue) div 45)+78;
        B:=SrcRGB.rgbtBlue-((SrcRGB1.rgbtBlue)*Azimuthvalue div 45)-((SrcRGB2.rgbtBlue)*(45-Azimuthvalue) div 45)+78;
      end;
      R:=Min(R,255);
      R:=Max(R,0);
      G:=Min(G,255);
      G:=Max(G,0);
      B:=Min(B,255);
      B:=Max(B,0);
      Gray := (R shr 2) + (R shr 4) + (G shr 1) + (G shr 4) + (B shr 3);
      DestRGB.rgbtRed:=Gray;
      DestRGB.rgbtGreen:=Gray;
      DestRGB.rgbtBlue:=Gray;
      if (j=-180) and (AzimuthChange<-135)) or ((AzimuthChange>=90) and (AzimuthChange<=180))) then
      begin
        Inc(SrcRGB1);
      end;
      if (j=135) and (AzimuthChange<180)) or ((AzimuthChange>=-180) and (AzimuthChange<=-90))) then
      begin
        Inc(SrcRGB2);
      end;
      Inc(SrcRGB);
      Inc(DestRGB);
    end;
  end;
end;

procedure Emboss(Bmp:TBitmap;AzimuthChange:integer;ElevationChange:integer;WeightChange:integer);overload;
var
  DestBmp:TBitmap;
begin
　　DestBmp:=TBitmap.Create;
　　DestBmp.Assign(Bmp);
　　Emboss(Bmp,DestBmp,AzimuthChange,ElevationChange,WeightChange);
　　Bmp.Assign(DestBmp);
end;

//反色
procedure Negative(Bmp:TBitmap);
var
  i, j: Integer;
  PRGB: pRGBTriple;
begin
  Bmp.PixelFormat:=pf24Bit;
  for i := 0 to Bmp.Height - 1 do
  begin
    PRGB := Bmp.ScanLine[i];
    for j := 0 to Bmp.Width - 1 do
    begin
      PRGB^.rgbtRed :=not PRGB^.rgbtRed ;
      PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;
      PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;
      Inc(PRGB);
    end;
  end;
end;

//曝光
procedure Exposure(Bmp:TBitmap);
var
  i, j: integer;
  PRGB: pRGBTriple;
begin
  Bmp.PixelFormat:=pf24Bit;
  for i := 0 to Bmp.Height - 1 do
  begin
    PRGB := Bmp.ScanLine[i];
    for j := 0 to Bmp.Width - 1 do
    begin
      if PRGB^.rgbtRed<128 then
        PRGB^.rgbtRed :=not PRGB^.rgbtRed ;
      if PRGB^.rgbtGreen<128 then
        PRGB^.rgbtGreen :=not PRGB^.rgbtGreen;
      if PRGB^.rgbtBlue<128 then
        PRGB^.rgbtBlue :=not PRGB^.rgbtBlue;
      Inc(PRGB);
    end;
  end;
end;

//模糊
procedure Blur(SrcBmp:TBitmap);
var
  i, j:Integer;
  SrcRGB:pRGBTriple;
  SrcNextRGB:pRGBTriple;
  SrcPreRGB:pRGBTriple;
  Value:Integer;

  procedure IncRGB;
  begin
    Inc(SrcPreRGB);
    Inc(SrcRGB);
    Inc(SrcNextRGB);
  end;

  procedure DecRGB;
  begin
    Inc(SrcPreRGB,-1);
    Inc(SrcRGB,-1);
    Inc(SrcNextRGB,-1);
  end;

begin
  SrcBmp.PixelFormat:=pf24Bit;
  for i := 0 to SrcBmp.Height - 1 do
  begin
    if i > 0 then
      SrcPreRGB:=SrcBmp.ScanLine[i-1]
    else
      SrcPreRGB := SrcBmp.ScanLine[i];
    SrcRGB := SrcBmp.ScanLine[i];
    if i < SrcBmp.Height - 1 then
      SrcNextRGB:=SrcBmp.ScanLine[i+1]
    else
      SrcNextRGB:=SrcBmp.ScanLine[i];
    for j := 0 to SrcBmp.Width - 1 do
    begin
      if j > 0 then DecRGB;
      Value:=SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;
      if j > 0 then IncRGB;
      Value:=Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed;
      if j < SrcBmp.Width - 1 then IncRGB;
      Value:=(Value+SrcPreRGB.rgbtRed+SrcRGB.rgbtRed+SrcNextRGB.rgbtRed) div 9;
      DecRGB;
      SrcRGB.rgbtRed:=value;
      if j > 0 then DecRGB;
      Value:=SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;
      if j > 0 then IncRGB;
      Value:=Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen;
      if j < SrcBmp.Width - 1 then IncRGB;
      Value:=(Value+SrcPreRGB.rgbtGreen+SrcRGB.rgbtGreen+SrcNextRGB.rgbtGreen) div 9;
      DecRGB;
      SrcRGB.rgbtGreen:=value;
      if j > 0 then DecRGB;
      Value:=SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;
      if j > 0 then IncRGB;
      Value:=Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue;
      if j < SrcBmp.Width - 1 then IncRGB;
      Value:=(Value+SrcPreRGB.rgbtBlue+SrcRGB.rgbtBlue+SrcNextRGB.rgbtBlue) div 9;
      DecRGB;
      SrcRGB.rgbtBlue:=value;
      IncRGB;
    end;
  end;
end;

//锐化
procedure Sharpen(SrcBmp:TBitmap);
var
  i, j: integer;
  SrcRGB: pRGBTriple;
  SrcPreRGB: pRGBTriple;
  Value: integer;
begin
  SrcBmp.PixelFormat:=pf24Bit;
  for i := 0 to SrcBmp.Height - 1 do
  begin
    SrcRGB := SrcBmp.ScanLine[i];
    if i > 0 then
      SrcPreRGB:=SrcBmp.ScanLine[i-1]
    else
      SrcPreRGB:=SrcBmp.ScanLine[i];
    for j := 0 to SrcBmp.Width - 1 do
    begin
      if j = 1 then Dec(SrcPreRGB);
      Value:=SrcRGB.rgbtRed+(SrcRGB.rgbtRed-SrcPreRGB.rgbtRed) div 2;
      Value:=Max(0,Value);
      Value:=Min(255,Value);
      SrcRGB.rgbtRed:=value;
      Value:=SrcRGB.rgbtGreen+(SrcRGB.rgbtGreen-SrcPreRGB.rgbtGreen) div 2;
      Value:=Max(0,Value);
      Value:=Min(255,Value);
      SrcRGB.rgbtGreen:=value;
      Value:=SrcRGB.rgbtBlue+(SrcRGB.rgbtBlue-SrcPreRGB.rgbtBlue) div 2;
      Value:=Max(0,Value);
      Value:=Min(255,Value);
      SrcRGB.rgbtBlue:=value;
      Inc(SrcRGB);
      Inc(SrcPreRGB);
    end;
  end;
end;
 [图像的旋转和翻转]

以下代码用ScanLine配合指针移动实现，用于24位色！

//旋转90度
procedure Rotate90(const Bitmap:TBitmap);
var
  i,j:Integer;
  rowIn,rowOut:pRGBTriple;
  Bmp:TBitmap;
  Width,Height:Integer;
begin
  Bmp:=TBitmap.Create;
  Bmp.Width := Bitmap.Height;
  Bmp.Height := Bitmap.Width;
  Bmp.PixelFormat := pf24bit;
  Width:=Bitmap.Width-1;
  Height:=Bitmap.Height-1;
  for  j := 0 to Height do
  begin
    rowIn  := Bitmap.ScanLine[j];
    for i := 0 to Width do
    begin
      rowOut := Bmp.ScanLine[i];
      Inc(rowOut,Height - j);
      rowOut^ := rowIn^;
      Inc(rowIn);
    end;
  end;
  Bitmap.Assign(Bmp);
end;

//旋转180度
procedure Rotate180(const Bitmap:TBitmap);
var
  i,j:Integer;
  rowIn,rowOut:pRGBTriple;
  Bmp:TBitmap;
  Width,Height:Integer;
begin
  Bmp:=TBitmap.Create;
  Bmp.Width := Bitmap.Width;
  Bmp.Height := Bitmap.Height;
  Bmp.PixelFormat := pf24bit;
  Width:=Bitmap.Width-1;
  Height:=Bitmap.Height-1;
  for  j := 0 to Height do
  begin
    rowIn  := Bitmap.ScanLine[j];
    for i := 0 to Width do
    begin
      rowOut := Bmp.ScanLine[Height - j];
      Inc(rowOut,Width - i);
      rowOut^ := rowIn^;
      Inc(rowIn);
    end;
  end;
  Bitmap.Assign(Bmp);
end;

//旋转270度
procedure Rotate270(const Bitmap:TBitmap);
var
  i,j:Integer;
  rowIn,rowOut:pRGBTriple;
  Bmp:TBitmap;
  Width,Height:Integer;
begin
  Bmp:=TBitmap.Create;
  Bmp.Width := Bitmap.Height;
  Bmp.Height := Bitmap.Width;
  Bmp.PixelFormat := pf24bit;
  Width:=Bitmap.Width-1;
  Height:=Bitmap.Height-1;
  for  j := 0 to Height do
  begin
    rowIn  := Bitmap.ScanLine[j];
    for i := 0 to Width do
    begin
      rowOut := Bmp.ScanLine[Width - i];
      Inc(rowOut,j);
      rowOut^ := rowIn^;
      Inc(rowIn);
    end;
  end;
  Bitmap.Assign(Bmp);
end;

//任意角度
function RotateBitmap(Bitmap:TBitmap;Angle:Integer;BackColor:TColor):TBitmap;
var
  i,j,iOriginal,jOriginal,CosPoint,SinPoint : integer;
  RowOriginal,RowRotated : pRGBTriple;
  SinTheta,CosTheta : Extended;
  AngleAdd : integer;
begin
  Result:=TBitmap.Create;
  Result.PixelFormat := pf24bit;
  Result.Canvas.Brush.Color:=BackColor;
  Angle:=Angle Mod 360;
  if Angle<0 then Angle:=360-Abs(Angle);
  if Angle=0 then
    Result.Assign(Bitmap)
  else if Angle=90 then
  begin
    Result.Assign(Bitmap);
    Rotate90(Result);//如果是旋转90度，直接调用上面的代码
  end
  else if (Angle>90) and (Angle<180) then
  begin
    AngleAdd:=90;
    Angle:=Angle-AngleAdd;
  end
  else if Angle=180 then
  begin
    Result.Assign(Bitmap);
    Rotate180(Result);//如果是旋转180度，直接调用上面的过程
  end
  else if (Angle>180) and (Angle<270) then
  begin
    AngleAdd:=180;
    Angle:=Angle-AngleAdd;
  end
  else if Angle=270 then
  begin
    Result.Assign(Bitmap);
    Rotate270(Result);//如果是旋转270度，直接调用上面的过程
  end
  else if (Angle>270) and (Angle<360) then
  begin
    AngleAdd:=270;
    Angle:=Angle-AngleAdd;
  end
  else
    AngleAdd:=0;
  if (Angle>0) and (Angle<90) then
  begin
  SinCos((Angle + AngleAdd) * Pi / 180, SinTheta, CosTheta);
  if (SinTheta * CosTheta) < 0 then
  begin
    Result.Width := Round(Abs(Bitmap.Width * CosTheta - Bitmap.Height * SinTheta));
    Result.Height := Round(Abs(Bitmap.Width * SinTheta - Bitmap.Height * CosTheta));
  end
  else
  begin
    Result.Width := Round(Abs(Bitmap.Width * CosTheta + Bitmap.Height * SinTheta));
    Result.Height := Round(Abs(Bitmap.Width * SinTheta + Bitmap.Height * CosTheta));
  end;
  CosTheta:=Abs(CosTheta);
  SinTheta:=Abs(SinTheta);
  if (AngleAdd=0) or (AngleAdd=180) then
  begin
    CosPoint:=Round(Bitmap.Height*CosTheta);
    SinPoint:=Round(Bitmap.Height*SinTheta);
  end
  else
  begin
    SinPoint:=Round(Bitmap.Width*CosTheta);
    CosPoint:=Round(Bitmap.Width*SinTheta);
  end;
  for j := 0 to Result.Height-1 do
  begin
    RowRotated := Result.Scanline[j];
    for i := 0 to Result.Width-1 do
    begin
      Case AngleAdd of
        0:
        begin
          jOriginal := Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta)-1;
          iOriginal := Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta)-1;
        end;
        90:
        begin
          iOriginal := Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta)-1;
          jOriginal := Bitmap.Height-Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta);
        end;
        180:
        begin
          jOriginal := Bitmap.Height-Round((j+1)*CosTheta-(i+1-SinPoint)*SinTheta);
          iOriginal := Bitmap.Width-Round((i+1)*CosTheta-(CosPoint-j-1)*SinTheta);
        end;
        270:
        begin
          iOriginal := Bitmap.Width-Round((j+1)*SinTheta-(i+1-SinPoint)*CosTheta);
          jOriginal := Round((i+1)*SinTheta-(CosPoint-j-1)*CosTheta)-1;
        end;
      end;
      if (iOriginal >= 0) and (iOriginal <= Bitmap.Width-1)and
         (jOriginal >= 0) and (jOriginal <= Bitmap.Height-1)
      then
      begin
        RowOriginal := Bitmap.Scanline[jOriginal];
        Inc(RowOriginal,iOriginal);
        RowRotated^ := RowOriginal^;
        Inc(RowRotated);
      end
      else
      begin
        Inc(RowRotated);
      end;
    end;
  end;
  end;
end;

//水平翻转
procedure FlipHorz(const Bitmap:TBitmap);
var
  i,j:Integer;
  rowIn,rowOut:pRGBTriple;
  Bmp:TBitmap;
  Width,Height:Integer;
begin
  Bmp:=TBitmap.Create;
  Bmp.Width := Bitmap.Width;
  Bmp.Height := Bitmap.Height;
  Bmp.PixelFormat := pf24bit;
  Width:=Bitmap.Width-1;
  Height:=Bitmap.Height-1;
  for  j := 0 to Height do
  begin
    rowIn  := Bitmap.ScanLine[j];
    for i := 0 to Width do
    begin
      rowOut := Bmp.ScanLine[j];
      Inc(rowOut,Width - i);
      rowOut^ := rowIn^;
      Inc(rowIn);
    end;
  end;
  Bitmap.Assign(Bmp);
end;

//垂直翻转
procedure FlipVert(const Bitmap:TBitmap);
var
  i,j:Integer;
  rowIn,rowOut:pRGBTriple;
  Bmp:TBitmap;
  Width,Height:Integer;
begin
  Bmp:=TBitmap.Create;
  Bmp.Width := Bitmap.Height;
  Bmp.Height := Bitmap.Width;
  Bmp.PixelFormat := pf24bit;
  Width:=Bitmap.Width-1;
  Height:=Bitmap.Height-1;
  for  j := 0 to Height do
  begin
    rowIn  := Bitmap.ScanLine[j];
    for i := 0 to Width do
    begin
      rowOut := Bmp.ScanLine[Height - j];
      Inc(rowOut,i);
      rowOut^ := rowIn^;
      Inc(rowIn);
    end;
  end;
  Bitmap.Assign(Bmp);
end;

[亮度、对比度、饱和度的调整]

以下代码用ScanLine配合指针移动实现！

function Min(a, b: integer): integer;
begin
  if a < b then
    result := a
  else
    result := b;
end;

function Max(a, b: integer): integer;
begin
  if a > b then
    result := a
  else
    result := b;
end;

//亮度调整
procedure BrightnessChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
  i, j: integer;
  SrcRGB, DestRGB: pRGBTriple;
begin
  for i := 0 to SrcBmp.Height - 1 do
  begin
    SrcRGB := SrcBmp.ScanLine[i];
    DestRGB := DestBmp.ScanLine[i];
    for j := 0 to SrcBmp.Width - 1 do
    begin
      if ValueChange > 0 then
      begin
        DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange);
        DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange);
        DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange);
      end else begin
        DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + ValueChange);
        DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + ValueChange);
        DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + ValueChange);
      end;
      Inc(SrcRGB);
      Inc(DestRGB);
    end;
  end;
end;

//对比度调整
procedure ContrastChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
  i, j: integer;
  SrcRGB, DestRGB: pRGBTriple;
begin
  for i := 0 to SrcBmp.Height - 1 do
  begin
    SrcRGB := SrcBmp.ScanLine[i];
    DestRGB := DestBmp.ScanLine[i];
    for j := 0 to SrcBmp.Width - 1 do
    begin
      if ValueChange>=0 then
      begin
      if SrcRGB.rgbtRed >= 128 then
        DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + ValueChange)
      else
        DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed - ValueChange);
      if SrcRGB.rgbtGreen >= 128 then
        DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + ValueChange)
      else
        DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen - ValueChange);
      if SrcRGB.rgbtBlue >= 128 then
        DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + ValueChange)
      else
        DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue - ValueChange);
      end
      else
      begin
      if SrcRGB.rgbtRed >= 128 then
        DestRGB.rgbtRed := Max(128, SrcRGB.rgbtRed + ValueChange)
      else
        DestRGB.rgbtRed := Min(128, SrcRGB.rgbtRed - ValueChange);
      if SrcRGB.rgbtGreen >= 128 then
        DestRGB.rgbtGreen := Max(128, SrcRGB.rgbtGreen + ValueChange)
      else
        DestRGB.rgbtGreen := Min(128, SrcRGB.rgbtGreen - ValueChange);
      if SrcRGB.rgbtBlue >= 128 then
        DestRGB.rgbtBlue := Max(128, SrcRGB.rgbtBlue + ValueChange)
      else
        DestRGB.rgbtBlue := Min(128, SrcRGB.rgbtBlue - ValueChange);
      end;
      Inc(SrcRGB);
      Inc(DestRGB);
    end;
  end;
end;

//饱和度调整
procedure SaturationChange(const SrcBmp,DestBmp:TBitmap;ValueChange:integer);
var
  Grays: array[0..767] of Integer;
  Alpha: array[0..255] of Word;
  Gray, x, y: Integer;
  SrcRGB,DestRGB: pRGBTriple;
  i: Byte;
begin
ValueChange:=ValueChange+255;
for i := 0 to 255 do
  Alpha[i] := (i * ValueChange) Shr 8;
x := 0;
for i := 0 to 255 do
begin
  Gray := i - Alpha[i];
  Grays[x] := Gray;
  Inc(x);
  Grays[x] := Gray;
  Inc(x);
  Grays[x] := Gray;
  Inc(x);
end;
for y := 0 to SrcBmp.Height - 1 do
begin
  SrcRGB := SrcBmp.ScanLine[Y];
  DestRGB := DestBmp.ScanLine[Y];
  for x := 0 to SrcBmp.Width - 1 do
  begin
    Gray := Grays[SrcRGB.rgbtRed + SrcRGB.rgbtGreen + SrcRGB.rgbtBlue];
    if Gray + Alpha[SrcRGB.rgbtRed]>0 then
      DestRGB.rgbtRed := Min(255,Gray + Alpha[SrcRGB.rgbtRed])
    else
      DestRGB.rgbtRed := 0;
    if Gray + Alpha[SrcRGB.rgbtGreen]>0 then
      DestRGB.rgbtGreen := Min(255,Gray + Alpha[SrcRGB.rgbtGreen])
    else
      DestRGB.rgbtGreen := 0;
    if Gray + Alpha[SrcRGB.rgbtBlue]>0 then
      DestRGB.rgbtBlue := Min(255,Gray + Alpha[SrcRGB.rgbtBlue])
    else
      DestRGB.rgbtBlue := 0;
    Inc(SrcRGB);
    Inc(DestRGB);
  end;
end;
end;

//RGB调整
procedure RGBChange(SrcBmp,DestBmp:TBitmap;RedChange,GreenChange,BlueChange:integer);
var
  SrcRGB, DestRGB: pRGBTriple;
  i,j:integer;
begin
  for i := 0 to SrcBmp.Height- 1 do
  begin
    SrcRGB := SrcBmp.ScanLine[i];
    DestRGB :=DestBmp.ScanLine[i];
    for j := 0 to SrcBmp.Width - 1 do
    begin
      if RedChange> 0 then
        DestRGB.rgbtRed := Min(255, SrcRGB.rgbtRed + RedChange)
      else
        DestRGB.rgbtRed := Max(0, SrcRGB.rgbtRed + RedChange);

      if GreenChange> 0 then
        DestRGB.rgbtGreen := Min(255, SrcRGB.rgbtGreen + GreenChange)
      else
        DestRGB.rgbtGreen := Max(0, SrcRGB.rgbtGreen + GreenChange);

      if BlueChange> 0 then
        DestRGB.rgbtBlue := Min(255, SrcRGB.rgbtBlue + BlueChange)
      else
        DestRGB.rgbtBlue := Max(0, SrcRGB.rgbtBlue + BlueChange);
      Inc(SrcRGB);
      Inc(DestRGB);
    end;
  end;
end;

[颜色调整]

//RGB<=>BGR
procedure RGB2BGR(const Bitmap:TBitmap);
var
  X: Integer;
  Y: Integer;
  PRGB: pRGBTriple;
  Color: Byte;
begin
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    for X := 0 to (Bitmap.Width - 1) do
    begin
      Color := PRGB^.rgbtRed;
      PRGB^.rgbtRed := PRGB^.rgbtBlue;
      PRGB^.rgbtBlue := Color;
      Inc(PRGB);
    end;
    end
  end;
end;

//灰度化(加权)
procedure Grayscale(const Bitmap:TBitmap);
var
  X: Integer;
  Y: Integer;
  PRGB: pRGBTriple;
  Gray: Byte;
begin
  for Y := 0 to (Bitmap.Height - 1) do
  begin
    PRGB := Bitmap.ScanLine[Y];
    for X := 0 to (Bitmap.Width - 1) do
    begin
      Gray := (77 * Red + 151 * Green + 28 * Blue) shr 8;
      PRGB^.rgbtRed:=Gray;
      PRGB^.rgbtGreen:=Gray;
      PRGB^.rgbtBlue:=Gray;
      Inc(PRGB);
    end;
  end;
end;

理论篇：
关键词：
绘图区－即窗口显示图像的区域，亦可为全屏幕（在全屏幕下绘图的效果比一般窗口下好）
中心点－即要绘图区显示的中心点在原始图像的坐标（声明：这个概念特别重要）
　 　先说说图像的放大，要放大一张图片，我们一般的做法是直接放大图像，但本文介绍的方法仅放大我们能够看到的部分，放大分两种情况，一种是放大后比绘图区 还要小，这种情况没什么好说，当然是显示全部的图像；第二种是放大后的图像比绘图区大，这才是我们今天要讨论的重点话题，这种情况下我们先要确定图像放大 后的大小，然后根据“中心点”计算在原始图像的位置和大小，最后把截取的图像放大到绘图区。
　　再说说图像的漫游，当显示的图像超过绘图区时，我 们需要对图像进行漫游，以便看到全部的图像。原理是：当鼠标在绘图区进行单击时，这时开始漫游，先记录鼠标的单击位置，然后检测鼠标的移动，根据鼠标和上 次的位移计算出“中心点”（需要将屏幕坐标转换为原始图像坐标），根据在上面放大的原理到原始图像中取出要显示的部分，放大显示到绘图区。
算法实现篇：
1.图像放大
变量定义：
PZoom:放大率(整数:100时为100%，根据需要可以将 100 该为 10000 或者更大些，但不推荐使用浮点数)
a,b:中心点
w,h:要截取原始图像的宽和高
x,y:要截取的位置(左上角)
sw,sh:原始图像的宽和高
p1,p2:放大比例
aw,ah:放大后图像的大小
pw,ph:绘图区大小
vx,vy:在绘图区显示的位置（左上角）
vw,vh:在绘图区显示的大小
ptx,pty:临时变量
已知的变量：PZoom,(a,b),(sw,sh),(p1,p2),(aw,ah),(pw,ph)
要计算的变量：(x,y),(w,h),(vx,vy),(vw,vh)
开始计算：
aw=Round(PZoom*sw/100);
ah=Round(PZoom*sh/100);
p1=aw/pw
p2=ah/ph
// 注：Round 用于取整，如其他语言的Int(),Fix()等
if p1>1 then w=Round(sw/p1) else w=sw
if p2>1 then h=Round(sh/p2) else h=sh
// 注：shr 为右移运算符，可以使用“>>1”、“div 2”、“/2”或“Round(w/2)”代替
x=a-w shr 1
y=b-h shr 1
// 注：div 为整除运算符
ptx=(w*PZoom) div 100
pty=(h*PZoom) div 100
// 以下计算在绘图区显示的图像大小和位置
变量
    Pencent:double;  // 缩放比
    wx:double;       // 宽缩放比
    hx:double;       // 高缩放比
    // 获得缩放比
    wx:=pw/ptx
    hx:=ph/pty
    if wx>hx then Pencent:=hx
    else          Pencent:=wx;
    // 获得图片最后的大小
    vw:=Round(Pencent*ptx);
    vh:=Round(Pencent*pty);
    // 计算出图片的位置
    vx:=(pw-vw) div 2;
    vy:=(ph-vh) div 2;
// ------------------------------------
好了，两个重要的任务完成(x,y),(w,h),(vx,vy),(vw,vh)已经全部计算得出，下面的工作就是显示了，我们选择 Windows API 进行操作
// 以下显示图像 -----------------------
变量
sDC 为原始图片的设备句柄(DC)
tDC 为临时设备句柄
dDC 最终设备句柄
BitBlt(tDC,0,0,w,h,sDC,0,0,SRCCOPY);
SetStretchBltMode(dDC,STRETCH_DELETESCANS);
StretchBlt(dDC,0,0,vw,vh,tDC,0,0,w,h,SRCCOPY);
最后绘制到显示的区域即可：
例如：BitBlt(GetDC(0),vx,vy,vx+vw,xy+vh,dDC,0,0,SRCCOPY);
// ------------------------------------
2.图像漫游
先定义三个全局变量：
FBeginDragPoint   :TPoint;         // 记录鼠标开始拖动的位置
FBeginDragSBPoint :TPoint;         // 记录“中心点”位置
FBeginDrag        :boolean;        // 是否已经开始“拖动”
a,b               :integer;        // “中心点”位置
在鼠标左键点击时，记录鼠标的位置和“中心点”的位置，同时设置 FBeginDrag 为真
当鼠标右键弹起时，设置 FBeginDrag 为假
鼠标移动时，判断 FBeginDrag ，如果为假不进行处理，如果为真进行下面处理：
假设 X,Y 为鼠标当前的位置
a=FBeginDragPoint.X-((X-FBeginDragPoint.X)*100) div PZoom
b=FBeginDragPoint.Y-((Y-FBeginDragPoint.Y)*100) div PZoom
最后使用上面介绍的图像放大显示出图像
技巧篇：
1.如果图像较大，使用 delphi 的 位图对象会出现内存溢出错误，这时可以进行如下设置：
    bitImage:=TBitmap.Create;
    bitImage.PixelFormat:=pf24bit;
    bitImage.ReleaseHandle;
2.如果要让图像自动适应窗口的大小，参考以下代码：
var
    p1,p2       :double;
begin
    p1:=pw/sw;
    p2:=ph/sw;
    if p1>p2 then PZoom:=Round(p2*100)
    else          PZoom:=Round(p1*100);
    if PZoom=0 then PZoom:=100;
end;

Delphi灰度图像像素颜色亮度处理
　　在图像处理中，速度是很重要的。因此，我们得重新处理一下TBitmap,得到TVczhBitmap。这只是因为GetPixels和SetPixels的速度太慢，换一个方法而已。
　　unit untBitmapProc;
　　interface
　　uses Graphics, SysUtils;
　　type
　　TVczhBitmap=class(TBitmap)
　　private
　　Data:PByteArray;
　　Line:Integer;
　　procedure SetFormat;
　　function GetBytePointer(X,Y:Integer):PByte;
　　procedure SetBytes(X,Y:Integer;Value:Byte);
　　function GetBytes(X,Y:Integer):Byte;
　　protected
　　published
　　constructor Create;
　　public
　　property Bytes[X,Y:Integer]:Byte read GetBytes write SetBytes;
　　procedure LoadFromFile(FileName:String);
　　procedure ToGray;
　　end;
　　implementation
　　procedure TVczhBitmap.SetFormat;
　　begin
　　HandleType:=bmDIB;
　　PixelFormat:=pf24bit;
　　end;
　　function TVczhBitmap.GetBytePointer(X,Y:Integer):PByte;
　　begin
　　if Line<>Y then
　　begin
　　Line:=Y;
　　Data:=ScanLine[Y];
　　end;
　　Longint(result):=Longint(Data)+X;
　　end;
　　procedure TVczhBitmap.SetBytes(X,Y:Integer;Value:Byte);
　　begin
　　GetBytePointer(X,Y)^:=Value;
　　end;
　　function TVczhBitmap.GetBytes(X,Y:Integer):Byte;
　　begin
　　result:=GetBytePointer(X,Y)^;
　　end;
　　constructor TVczhBitmap.Create;
　　begin
　　inherited Create;
　　SetFormat;
　　Line:=-1;
　　end;
　　procedure TVczhBitmap.LoadFromFile(FileName:String);
　　begin
　　inherited LoadFromFile(FileName);
　　SetFormat;
　　Line:=-1;
　　end;
　　procedure TVczhBitmap.ToGray;
　　var X,Y,R:Integer;
　　B:Byte;
　　begin
　　for Y:=0 to Height-1 do
　　for X:=0 to Width-1 do
　　begin
　　R:=0;
　　for B:=0 to 2 do
　　R:=R+GetBytes(X*3+B,Y);
　　for B:=0 to 2 do
　　SetBytes(X*3+B,Y,R div 3);
　　end;
　　end;
　　end.
　　此后，我们需要建立几个窗体。第一个用来显示图片，第二个用来处理图片，其他的窗体都继承自第二个窗体，包含实际的处理方法。
　　先看第二个窗口：
　　unit untProc;
　　interface
　　uses
　　Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
　　Dialogs, ExtCtrls, untBitmapProc, StdCtrls, ComCtrls;
　　type
　　TfrmProcessor = class(TForm)
　　pbBar: TPaintBox;
　　gpProc: TGroupBox;
　　Button1: TButton;
　　procedure FormCreate(Sender: TObject);
　　procedure FormDestroy(Sender: TObject);
　　procedure FormShow(Sender: TObject);
　　procedure pbBarPaint(Sender: TObject);
　　procedure Button1Click(Sender: TObject);
　　private
　　{ Private declarations }
　　public
　　{ Public declarations }
　　BarData:array[0..255]of Byte;
　　Bar:TVczhBitmap;
　　procedure DrawBar;
　　end;
　　var
　　frmProcessor: TfrmProcessor;
　　implementation
　　{$R *.dfm}
　　uses untViewer;
　　procedure TfrmProcessor.DrawBar;
　　var I:Integer;
　　begin
　　Bar.Canvas.FillRect(Bar.Canvas.ClipRect);
　　Bar.Canvas.MoveTo(0,255-BarData[0]);
　　for I:=1 to 255 do
　　Bar.Canvas.LineTo(I,255-BarData[I]);
　　end;
　　procedure TfrmProcessor.FormCreate(Sender: TObject);
　　begin
　　Bar:=TVczhBitmap.Create;
　　Bar.Width:=256;
　　Bar.Height:=256;
　　Bar.Canvas.Brush.Color:=clWhite;
　　Bar.Canvas.Brush.Style:=bsSolid;
　　end;
　　procedure TfrmProcessor.FormDestroy(Sender: TObject);
　　begin
　　Bar.Free;
　　end;
　　procedure TfrmProcessor.FormShow(Sender: TObject);
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　BarData[I]:=I;
　　DrawBar;
　　end;
　　procedure TfrmProcessor.pbBarPaint(Sender: TObject);
　　begin
　　pbBar.Canvas.Draw(0,0,Bar);
　　end;
　　procedure TfrmProcessor.Button1Click(Sender: TObject);
　　var X,Y:Integer;
　　begin
　　for Y:=0 to Buffer.Height-1 do
　　for X:=0 to Buffer.Width*3-1 do
　　Played.Bytes[X,Y]:=BarData[Buffer.Bytes[X,Y]];
　　frmViewer.FormPaint(frmViewer);
　　end;
　　end.
　　之后，做一个窗口继承自它，则调整BarData[]后，按Apply即可看到结果。
　　现在开始将图像处理。具体效果见示例程序。
　　
　　一、颜色反转。
　　灰度图像的颜色都是从0~255，所以，为了使颜色反转，我们可以用255减去该颜色值以得到反转后的颜色。
　　var I:Integer;
　　begin
　　inherited;
　　for I:=0 to 255 do
　　BarData[I]:=255-I;//用255减去该颜色值
　　DrawBar;
　　pbBarPaint(pbBar);
　　end;
　　
　　二、缩小颜色范围以增强或减弱亮度
　　颜色本来是从0~255的。如果调节它的范围，例如从0~16，则会是图像明显变暗。我们可以把起始值设为a，把终止值设为b，则新的颜色值New=a+(b-1)*Old/255。这样做的话可以改变亮度，并且不会破坏原先颜色的顺序。代码如下
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　BarData[I]:=(255-sbMin.Position)+Round((sbMin.Position-sbMax.Position)/255*I);
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　这里的sbMin.Position和sbMaxPosition都是反转过的。所以使用时要用255去减
　　
　　三、增加某个范围内的颜色范围
　　如果图像本身的颜色范围很小的画，你可以通过这种方法来加大图像的对比度，有利于对图像的分析。具体做法：
　　选取一个值a做为起始值，选取一个值b做为终止值，然后按以下公式变形：
　　|　0 (X<=a)
　　f(X)= |　255/(b-a)*(X-a)
　　|　255(X>=b)
　　var I:Integer;
　　begin
　　for I:=0 to 255 do
　　begin
　　if I<=sbMin.Position then
　　BarData[I]:=0
　　else if I>=sbMax.Position then
　　BarData[I]:=255
　　else
　　BarData[I]:=Round(255/(sbMax.Position-sbMin.Position)*(I-sbMin.Position));
　　end;
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　
　　四、变为黑白图片
　　在使用第三个功能的时候，你会发现当b<=a时，图像上的颜色除了黑色就是白色。这样操作的好处是不能直接显示出来的。这只要到了比较高级的图像处理如边缘检测等，才有作用。本例可以拿第三种方法的公式再变形，因此不作详细阐述。
　　
　　五、指数级亮度调整
　　


　 　我们假设这个图的定义域是[0,1]，值域也是[0,1]。那么，定义函数f(x)=x^c，则f(x)的图像有一段如上图。我们再用鼠标操作时，可以 在上面取一点P(a,b)，然后使f(x)通过点P，则c=ln(b)/ln(a)。有了c之后，我们就可以对颜色进行操作了：
　　New=(Old/255)^c*255=exp(ln(old/255)*c)*255
　　var ea,eb,ec:Extended;
　　I:Integer;
　　begin
　　ea:=A/255;
　　eb:=B/255;
　　ec:=Ln(eb)/Ln(ea);
　　for I:=1 to 255 do
　　BarData[I]:=Round(Exp(Ln((I/255))*ec)*255);
　　DrawBar;
　　pbBarPaint(pbBar);
　　Button1Click(Button1);
　　end;
　　这样做可以调节图像的亮度。
Delphi图形显示特效的技巧
　概述
　　----目前在许多学习软件、游戏光盘中，经常会看到各种
　　图形显示技巧，凭着图形的移动、交错、雨滴状、百页窗、积木堆叠等显现方式，使画面变得更为生动活泼，更 能吸引观众。本文将探讨如何在delphi中实现各种图形显示技巧。
　　基本原理
　 　----在delphi中，实现一副图象的显示是非常简单的，只要在form中定义一个timage组件，设置其picture属性，然后选 择任何有效的.ico、.bmp、.emf或.wmf文件，进行load，所选文 件就显示在timage组件中了。但这只是直接将图形显示在窗体中，毫无技巧可言。为了使图形显示具有别具一格的效果，可以按下列步骤实现：
　　----定义一个timage组件，把要显示的图形先装入到timage组件中，也就是说，把图形内容从磁盘载入内存中， 做为图形缓存。
　　----创建一新的位图对象，其尺寸跟timage组件中的图形一样。
　　----利用画布(canvas)的copyrect功能(将一个画布的矩形区域拷贝到另一个画布的矩形区域)，使用技巧，动态形
　　成位图文件内容，然后在窗体中显示位图。
　　----实现方法
　　下面介绍各种图形显示技巧：
1.推拉效果
　　将要显示的图形由上、下、左、右方向拉进屏幕内显示，同时将屏幕上原来的旧图盖掉，此种效果可分为四
　　种，上拉、下拉、左拉、右拉，但原理都差不多，以上拉 效果为例。
原 理：首先将放在暂存图形的第一条水平线，搬移至要显示的位图的最后一条，接着再将暂存图形的前两条水平线，依序搬移至要显示位图的最后两条水平线，然后搬 移前三条、前四条叄?直到全部图形数据搬完为止。在搬移的过程中即可看到显示的位图由下而上浮起，而达到上拉的效果。
程序算法：
procedure tform1.button1click(sender: tobject);
var
newbmp: tbitmap;
i,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=0 to bmpheight do
begin
newbmp.canvas.copyrect(rect
(0,bmpheight-i,bmpwidth,bmpheight),
image1.canvas,
rect(0,0,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
2.垂直交错效果
原理：将要显示的图形拆成两部分，奇数条扫描线由上往下搬移，偶数条扫描线的部分则由下往上搬移，而且两者同时进行。从屏幕上便可看到分别由上下两端出现的较淡图形向屏幕中央移动，直到完全清楚为止。
程序算法：
procedure tform1.button4click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpheight do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,bmpheight-i+j-1,bmpwidth,bmpheight-i+j));
newbmp.canvas.copyrect(rect
(0,bmpheight-j,bmpwidth,bmpheight-j+1),
image1.canvas,
rect(0,i-j,bmpwidth,i-j+1));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
3.水平交错效果
原理：同垂直交错效果原理一样，只是将分成两组后的图形分别由左右两端移进屏幕。
程序算法：
procedure tform1.button5click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=0;
while i< =bmpwidth do
begin
j:=i;
while j >0 do
begin
newbmp.canvas.copyrect(rect(j-1,0,j,bmpheight),
image1.canvas,
rect(bmpwidth-i+j-1,0,bmpwidth-i+j,bmpheight));
newbmp.canvas.copyrect(rect
(bmpwidth-j,0,bmpwidth-j+1,bmpheight),
image1.canvas,
rect(i-j,0,i-j+1,bmpheight));
j:=j-2;
end;
form1.canvas.draw(120,100,newbmp);
i:=i+2;
end;
newbmp.free;
end;
4.雨滴效果
原理：将暂存图形的最后一条扫描线，依序搬移到可视位图的第一条到最后一条扫描线，让此条扫描线在屏幕上留下它的轨迹。接着再把暂存图形的倒数第二条扫描线，依序搬移到可视位图的第一条到倒数第二条扫描线。其余的扫描线依此类推。
程序算法：
procedure tform1.button3click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
for i:=bmpheight downto 1 do
for j:=1 to i do
begin
newbmp.canvas.copyrect(rect(0,j-1,bmpwidth,j),
image1.canvas,
rect(0,i-1,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
5.百叶窗效果
原理：将放在暂存图形的数据分成若干组，然后依次从第一组到最后一组搬移，第一次每组各搬移第一条扫描线到可视位图的相应位置，第二次搬移第二条扫描线，接着搬移第三条、第四条扫描线.
程序算法：
procedure tform1.button6click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
xgroup,xcount:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
xgroup:=16;
xcount:=bmpheight div xgroup;
for i:=0 to xcount do
for j:=0 to xgroup do
begin
newbmp.canvas.copyrect(rect
(0,xcount*j+i-1,bmpwidth,xcount*j+i),
image1.canvas,
rect(0,xcount*j+i-1,bmpwidth,xcount*j+i));
form1.canvas.draw(120,100,newbmp);
end;
newbmp.free;
end;
6.积木效果
原理：是雨滴效果的一种变化，不同之处在于，积木效果每次搬移的是一块图形，而不只是一根扫描线。
程序算法：
procedure tform1.button7click(sender: tobject);
var
newbmp:tbitmap;
i,j,bmpheight,bmpwidth:integer;
begin
newbmp:= tbitmap.create;
newbmp.width:=image1.width;
newbmp.height:=image1.height;
bmpheight:=image1.height;
bmpwidth:=image1.width;
i:=bmpheight;
while i>0 do
begin
for j:=10 to i do
begin
newbmp.canvas.copyrect(rect(0,j-10,bmpwidth,j),
image1.canvas,
rect(0,i-10,bmpwidth,i));
form1.canvas.draw(120,100,newbmp);
end;
i:=i-10;
end;
newbmp.free;
end;
结束语
上述图形显示效果均已上机通过。使用效果很好。
用Delphi实现图像放大镜
　　向窗体上添加两个TImage组件，其中一个TImage组件的Name属性设置为Image1，它充当原图片显示的载体。另一个TImage组件的Name属性设置为Image2，它可以显示放大后的图像。添加组件后的窗体如图1所示。

图1 添加组件后的窗体

　　本例的核心是StretchBlt函数，利用StretchBlt函数实现局部图像放大，响应代码如下：
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
　StretchBlt(Image2.Canvas.Handle,0,0,Image2.Width,Image2.Height,
　Image1.Canvas.Handle, X-20,Y-20,40,40,SRCCOPY);
　Image2.Refresh;
　Screen.Cursors[1]:=LoadCursorFromFile(’MAGNIFY.CUR’);
　Self.Cursor:=1;
end;

　 　程序首先会调用StretchBlt函数，以鼠标当前位置作为中心点，以边长为40选中Image1组件上的局部图像，并放大此局部图像到Image2 组件上。然后通过调用Image2组件的Refresh方法以刷新Image2组件的显示。最后设置鼠标指针为新的形状。

　　程序代码如下：
unit Unit1;
interface
uses

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

type
　TForm1 = class(TForm)
　Image1: TImage;
　Image2: TImage;
　procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
　procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
private
　{ Private declarations }
public
　{ Public declarations }
end;

var
　Form1: TForm1;
　implementation
　{$R *.dfm}
　procedure TForm1.Image1MouseMove(Sender:TObject;Shift:TShiftState;X,Y: Integer);
　begin
　　StretchBlt(Image2.Canvas.Handle,0,0,Image2.Width,Image2.Height,Image1.Canvas.Handle, X-20,Y-20,40,40,SRCCOPY);
　　Image2.Refresh;
　　Screen.Cursors[1]:=LoadCursorFromFile(’MAGNIFY.CUR’);
　　Self.Cursor:=1;
end;

procedure TForm1.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer);
begin
　Screen.Cursors[1]:=crDefault;
　Self.Cursor:=1;
end;
end.

　　保存文件，然后按F9键运行程序，程序运行结果如图2所示。

图2 程序运行结果

　　放大图像是一个优秀的看图软件必备的功能，本实例提供了一种非常简便易行的方法，不但代码数量少，而且执行效率高。

轉貼自 http://blog.csdn.net/xujh/article/details/1858254