http://devsquare.nate.com/openApi/empathyButton
에서 url만 넣으면 공감 경로를 받을 수 있습니다.
<img style="cursor: pointer;" onclick="window.open('http://csp.cyworld.com/bi/bi_recommend_pop.php?url=http://agent.ucczone.co.kr/', 'recom_icon_pop', 'width=400,height=364,scrollbars=no,resizable=no');" src="http://csp.cyworld.com/images/ico_clog.gif" alt="싸이월드 공감" title="싸이월드 공감" >
이런씩인데 실제 자신의 url만 자동으로 하면 따로 받지 않고도 가능하네요
2011년 3월 22일 화요일
2011년 3월 15일 화요일
Indy10 재설치 (버전10)
Indy를 재설치하려면 먼저 Indy사이트에 간다.
Indy 설치 환경 : Delphi 2006 환경에서의 설치
http://www.indyproject.org/ : Indy 사이트
■ 최신판 Indy Download
Indy 사이트에 첫페이지에서 아래 링크를 클릭하면
델파이 관련 컴포넌트를 받을 수 있는 곳으로 들어간다.
Indy.Sockets (VCL)
위 페이지의 맨밑에 보면 [Downloads]가 나오고
거기를 클릭하면 몇가지 버전이 나온다.
여기서는 버전 10을 클릭한다.
[Development Snapshot]을 선택한다.
밑의 사이트에 가면 최신판을 업데이트 한다고 한다.
indy.Fulgan.com/zip/
위 사이트에서 indy10.zip을 다운 받는다.
위사이트에서 받지않으면 SubVersion이라고 해서
버전 관리 툴(?)을 설치해서 최신판을 받을 수 있는데
버전 관리 툴을 설치하고 사용법을 익히는 등 좀 귀찮다.
혹시라도 버전 관리툴을 깔아서 사용하고 싶은 사람은
아래 사이트를 참조하면 된다.
Indy via SVN
여하튼 어떻게든 최신판을 다운받는다.
■ 기존 버전 Indy삭제
01) Component 메뉴에서 Intall Packages...를 선택한다.
02) 그러면 아래와 같은 Install Packages 창이 뜬다.
Design packages에서 "Indy 10 Protocol Design Time"을 선택하고
[Remove]버튼을 클릭한다.
그러면 아래의 Uninstall 확인 창이 뜬다.
[Yes]버튼을 클릭하고 Uninstall을 진행한다.
03) 같은 방법으로 Design packages에서 "Indy 10 Core Design Time"을 선택하고
[Remove]버튼을 클릭하여 Uninstall한다.
04) 익스플로러로 Delphi가 설치된 폴더를 찾아 폴더를 클릭한다.
C:\Program Files\Borland\BDS
05) 이 폴더에서 오른쪽 클릭을 하고 검색을 클릭한다.
검색 결과 창이 뜨면 전체 또는 일부 파일 이름에 아래의 파일들을 검색하여 지운다.
dclIndy*.bpl
Indy*.bpl
Id*.pas
Id*.dcu
지울때는 Shift키를 누르고 Delete키를 눌러서 지우면 잘못 지웠을 경우 곤란함으로
그냥 Delete키만 눌러 지운다.
이렇게 하면 Delphi에서 기존 버전의 Indy가 삭제된다.
■ 최신 버전 Indy 설치
01) 다운 받은 최선 Indy 소스를 적당한 장소에 둔다.
C:\Program Files\Borland\BDS\4.0\lib\indy10
02) 델파이에서 File 메뉴에서 Open Project를 선택한다.
Indy 소스가 위치한 곳에 가서 IndySystemX0.dpk를 연다.
(IndySystem dpk파일을 Lib폴더 밑의 System에 있다.)
03) dpk를 열면 Project Manager에 dpk 프로젝트가 아래와 같이 표시된다.
04) 추가한 IndySystemX0 프로젝트에서 오른쪽 클릭을 해서 Compile을 한다.
05) IndySystem을 Compile한 것과 같은 방법으로 아래의 dpk파일도
동일한 방법(02~04의 방법)으로 차례대로 Compile한다.
IndyCore110.dpk (Lib\Core)
IndyProtocols110.dpk (Lib\Protocols)
06) 위 세 dpk파일을 컴파을 마치면 Core폴더 밑의 dclIndyCore110.dpk를 연다.
그러면 아래와 같이 표시되고 이번에는 Install을 클릭한다.
그러면 아래와 같은 창이 떠서 Install된 것을 알려준다.
07) 이번에는 dclIndyProtocols110.dpk를 열어 위와 동일한 방법으로 Install을 한다.
그러면 아래와 같이 Install된 것을 알려준다.
08) Tools 메뉴에서 Options...를 선택한다.
09) Options창의 Environment Options > Delpji Options > Library - Wind32에서
Library path와 Debug DCU path를 설정 한다.
DCU파일들이 있는 아래의 폴더들을 설정된 것들을
Library path와 Debug DCU path에 입력하고 [OK] 버튼을 클릭한다.
;$(BDS)\Lib\indy10\Core
;$(BDS)\Lib\indy10\Protocols
;$(BDS)\Lib\indy10\System;
이렇게 하면 INDY의 설치가 완료된다.
Indy 설치 환경 : Delphi 2006 환경에서의 설치
http://www.indyproject.org/ : Indy 사이트
■ 최신판 Indy Download
Indy 사이트에 첫페이지에서 아래 링크를 클릭하면
델파이 관련 컴포넌트를 받을 수 있는 곳으로 들어간다.
Indy.Sockets (VCL)
위 페이지의 맨밑에 보면 [Downloads]가 나오고
거기를 클릭하면 몇가지 버전이 나온다.
여기서는 버전 10을 클릭한다.
[Development Snapshot]을 선택한다.
밑의 사이트에 가면 최신판을 업데이트 한다고 한다.
indy.Fulgan.com/zip/
위 사이트에서 indy10.zip을 다운 받는다.
위사이트에서 받지않으면 SubVersion이라고 해서
버전 관리 툴(?)을 설치해서 최신판을 받을 수 있는데
버전 관리 툴을 설치하고 사용법을 익히는 등 좀 귀찮다.
혹시라도 버전 관리툴을 깔아서 사용하고 싶은 사람은
아래 사이트를 참조하면 된다.
Indy via SVN
여하튼 어떻게든 최신판을 다운받는다.
■ 기존 버전 Indy삭제
01) Component 메뉴에서 Intall Packages...를 선택한다.
02) 그러면 아래와 같은 Install Packages 창이 뜬다.
Design packages에서 "Indy 10 Protocol Design Time"을 선택하고
[Remove]버튼을 클릭한다.
그러면 아래의 Uninstall 확인 창이 뜬다.
[Yes]버튼을 클릭하고 Uninstall을 진행한다.
03) 같은 방법으로 Design packages에서 "Indy 10 Core Design Time"을 선택하고
[Remove]버튼을 클릭하여 Uninstall한다.
04) 익스플로러로 Delphi가 설치된 폴더를 찾아 폴더를 클릭한다.
C:\Program Files\Borland\BDS
05) 이 폴더에서 오른쪽 클릭을 하고 검색을 클릭한다.
검색 결과 창이 뜨면 전체 또는 일부 파일 이름에 아래의 파일들을 검색하여 지운다.
dclIndy*.bpl
Indy*.bpl
Id*.pas
Id*.dcu
지울때는 Shift키를 누르고 Delete키를 눌러서 지우면 잘못 지웠을 경우 곤란함으로
그냥 Delete키만 눌러 지운다.
이렇게 하면 Delphi에서 기존 버전의 Indy가 삭제된다.
■ 최신 버전 Indy 설치
01) 다운 받은 최선 Indy 소스를 적당한 장소에 둔다.
C:\Program Files\Borland\BDS\4.0\lib\indy10
02) 델파이에서 File 메뉴에서 Open Project를 선택한다.
Indy 소스가 위치한 곳에 가서 IndySystemX0.dpk를 연다.
(IndySystem dpk파일을 Lib폴더 밑의 System에 있다.)
03) dpk를 열면 Project Manager에 dpk 프로젝트가 아래와 같이 표시된다.
04) 추가한 IndySystemX0 프로젝트에서 오른쪽 클릭을 해서 Compile을 한다.
05) IndySystem을 Compile한 것과 같은 방법으로 아래의 dpk파일도
동일한 방법(02~04의 방법)으로 차례대로 Compile한다.
IndyCore110.dpk (Lib\Core)
IndyProtocols110.dpk (Lib\Protocols)
06) 위 세 dpk파일을 컴파을 마치면 Core폴더 밑의 dclIndyCore110.dpk를 연다.
그러면 아래와 같이 표시되고 이번에는 Install을 클릭한다.
그러면 아래와 같은 창이 떠서 Install된 것을 알려준다.
07) 이번에는 dclIndyProtocols110.dpk를 열어 위와 동일한 방법으로 Install을 한다.
그러면 아래와 같이 Install된 것을 알려준다.
08) Tools 메뉴에서 Options...를 선택한다.
09) Options창의 Environment Options > Delpji Options > Library - Wind32에서
Library path와 Debug DCU path를 설정 한다.
DCU파일들이 있는 아래의 폴더들을 설정된 것들을
Library path와 Debug DCU path에 입력하고 [OK] 버튼을 클릭한다.
;$(BDS)\Lib\indy10\Core
;$(BDS)\Lib\indy10\Protocols
;$(BDS)\Lib\indy10\System;
이렇게 하면 INDY의 설치가 완료된다.
시간차 : 0002.010 (시간차를 실수로 표현하고 싶습니다. 분초.밀리초) 구하기
function TForm1.GetTimeDif(Time1 , Time2 : TTime) : Double;
var
TimeDif : TTime;
Hour, Sec, Min, mSec : Word;
begin
TimeDif := Time2 - Time1;
DecodeTime(TimeDif, Hour, Min,Sec, mSec);
Sec := Hour*3600+Min*60+Sec;
Result := Sec+(mSec/1000);
end;
procedure TForm1.Button3Click(Sender: TObject);
var
time1, Time2 : TTime;
res : Double;
begin
Time1 := EncodeTime(07,08,00,000);
Time2 := EncodeTime(07,08,02,010);
Res := GetTimeDif(Time1, Time2);
ShowMessage(FormatFloat('0000.0000',Res));
end;
var
TimeDif : TTime;
Hour, Sec, Min, mSec : Word;
begin
TimeDif := Time2 - Time1;
DecodeTime(TimeDif, Hour, Min,Sec, mSec);
Sec := Hour*3600+Min*60+Sec;
Result := Sec+(mSec/1000);
end;
procedure TForm1.Button3Click(Sender: TObject);
var
time1, Time2 : TTime;
res : Double;
begin
Time1 := EncodeTime(07,08,00,000);
Time2 := EncodeTime(07,08,02,010);
Res := GetTimeDif(Time1, Time2);
ShowMessage(FormatFloat('0000.0000',Res));
end;
hook를 이용한 textout 하기
"캡쳐"실현 //------------------------------------------------ ----------------- 1 SetWindowsHookEx ()를 마우스 후크를 MouseProc 설치; 2, 움직임은 화면에 마우스 시스템은 마우스 후크 MouseProc 전화 것이다; 3 MouseProc로, 마우스 (좌표를 얻을 엑스, y를), 설정 TextOut (), ExtTextOut () 및 기타 추적 절차에 invalidateRect ()와 요점은 (여기서 x, y를) "실패"로 시스템을 알려줍니다; 4 보내기 WM_PAINT 메시지 시스템, 포인트 (엑스, y를)는 Office 응용 프로그램이 지역의 "실패"를 다시 그리기 나타냅니다. 5 WM_PAINT 메시지에 의해 응용 프로그램에서 지점을 () 그리기에 대한 책임, 기회를 호출해야합니다 TextOut (), ExtTextOut () 및 기타 기능을합니다. 6, 함수 호출을 추적하는 과정으로 차단됩니다 : 추적 프로그램을 두 번째 통화를 도청 설정, 는 응용 프로그램 밖으로 포인트 (스택에서 x를 y를) "텍스트"포인터; "" "화면을 완성 포인터의 내용을 서면으로 7 응용 프로그램의 데이터 세그먼트의 수 단어를 파악하는 것이지 "; MouseProc 마우스 후크로 반환 절차를 추적 8 아웃; 9 MouseProc TextOut () ExtTextOut () 트랙의 리프팅; MouseProc 마우스 후크 프로 시저 10 밖으로, 시스템을 제어할 수 있습니다. 11 화면에 다음 "화면"라는 단어를 파악하고 2 단계로 돌아갑니다 시작하는 마우스를 이동합니다.
1。新建dll项目GetWordDll.dpr，代码如下
library GetWordDll;
uses
Windows,
SysUtils,
Classes,
UnitHookDll in ‘UnitHookDll.pas’,
UnitNt2000Hook in ‘UnitNt2000Hook.pas’,
UnitHookType in ‘UnitHookType.pas’;
exports
StartHook,
StopHook;
// MouseWndProc,
{以下导出列表都是必须的，
不能少，因为程序要取其地址}
{ NewBeginPaint,
NewCreateCompatibleDC,
NewTextOutA,
NewTextOutW,
NewExtTextOutA,
NewExtTextOutW,
NewDrawTextA,
NewDrawTextW; }
begin
end.
2。新建3个单元UnitHookDll.pas，UnitHookType.pas，UnitNt2000Hook.pas具体代码如下
unit UnitHookDll;
interface
uses Windows, SysUtils, Classes, math, messages, dialogs, UnitNt2000Hook,
UnitHookType;
const
COLOR1=255;
COLOR2=0;
COLOR3=255;
Trap=true; //True陷阱式，False表示改引入表式
procedure StartHook; stdcall; {开始取词}
procedure StopHook; stdcall; {停止取词}
implementation
var
MouseHook: THandle;
pShMem: PShareMem;
hMappingFile: THandle;
FirstProcess:boolean;{是否是第一个进程}
Hook: array[fBeginPaint..fDrawTextW] of THookClass;{API HOOK类}
i:integer;
{自定义的BeginPaint}
function NewBeginPaint(Wnd: HWND; var lpPaint: TPaintStruct): HDC; stdcall;
type
TBeginPaint=function (Wnd: HWND; var lpPaint: TPaintStruct): HDC; stdcall;
begin
Hook[fBeginPaint].Restore;
result:=TBeginPaint(Hook[fBeginPaint].OldFunction)(Wnd,lpPaint);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fBeginPaint].Change;
end;
{自定义的GetWindowDC}
function NewGetWindowDC(Wnd: HWND): HDC; stdcall;
type
TGetWindowDC=function (Wnd: HWND): HDC; stdcall;
begin
Hook[fGetWindowDC].Restore;
result:=TGetWindowDC(Hook[fGetWindowDC].OldFunction)(Wnd);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fGetWindowDC].Change;
end;
{自定义的GetDC}
function NewGetDC(Wnd: HWND): HDC; stdcall;
type
TGetDC=function (Wnd: HWND): HDC; stdcall;
begin
Hook[fGetDC].Restore;
result:=TGetDC(Hook[fGetDC].OldFunction)(Wnd);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fGetDC].Change;
end;
{自定义的CreateCompatibleDC}
function NewCreateCompatibleDC(DC: HDC): HDC; stdcall;
type
TCreateCompatibleDC=function (DC: HDC): HDC; stdcall;
begin
Hook[fCreateCompatibleDC].Restore;
result:=TCreateCompatibleDC(Hook[fCreateCompatibleDC].OldFunction)(DC);
if DC=pshmem^.DCMouse then{如果是当前鼠标的窗口HDC}
begin
pshmem^.DCCompatible:=result;{记录它的返回值}
end
else pshmem^.DCCompatible:=0;
Hook[fCreateCompatibleDC].Change;
end;
function NewTextOutA(theDC: HDC; nXStart, nYStart: integer; str: pchar; count: integer): bool;
stdcall;
type
TTextOutA=function (theDC: HDC; nXStart, nYStart: integer; str: pchar; count: integer): bool;stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fTextOutA].Restore;{暂停截取API，恢复被截的函数}
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPoint(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Str, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fTextOutA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TTextOutA(Hook[fTextOutA].OldFunction)(theDC, nXStart,
nYStart, str, count);
end;
Hook[fTextOutA].Change;{重新截取API}
end;
function NewTextOutW(theDC: HDC; nXStart, nYStart: integer; str: pWidechar; count: integer): bool; stdcall;
type
TTextOutW=function (theDC: HDC; nXStart, nYStart: integer; str: pWidechar; count: integer): bool; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fTextOutW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPointW(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Pchar(WideCharToString(Str)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fTextOutW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TTextOutW(Hook[fTextOutW].OldFunction)(theDC, nXStart, nYStart, str, Count);
end;
Hook[fTextOutW].Change;{重新截取API}
end;
function NewExtTextOutA(theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
type
TExtTextOutA=function (theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fExtTextOutA].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPoint(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Str, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fExtTextOutA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TExtTextOutA(Hook[fExtTextOutA].OldFunction)(theDC, nXStart, nYStart, toOptions, rect, Str,
Count, Dx);
end;
Hook[fExtTextOutA].Change;{重新截取API}
end;
function NewExtTextOutW(theDC: HDC; nXStart, nYStart: integer; toOptions:
Longint; rect: PRect;
Str: Pwidechar; Count: Longint; Dx: PInteger): BOOL; stdcall;
type
TExtTextOutW=function (theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: Pwidechar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fExtTextOutW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPointW(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Pchar(WideCharToString(Str)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fExtTextOutW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TExtTextOutW(Hook[fExtTextOutW].OldFunction)(theDC, nXStart, nYStart, toOptions,Rect, Str, Count, Dx);
end;
Hook[fExtTextOutW].Change;{重新截取API}
end;
function NewDrawTextA(theDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
type
TDrawTextA=function (theDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
poMouse,poOri,poDC: TPoint;
dwBytes: integer;
RectSave,rec:TRect;
faint:boolean;
begin
Hook[fDrawTextA].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := 0;{局部逻辑坐标初始化为(0,0)}
poDC.y := 0;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
RectSave := lpRect;{显示的矩形}
OffsetRect(RectSave, poOri.x+poDC.x, poOri.y+poDC.y);{显示的矩形加上偏移}
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{鼠标是否在文本的范围内}
if PtInRect(RectSave, poMouse) then
begin
if nCount=-1 then
begin
strcopy(@(pShMem^.Text[0]), lpString);
end
else begin
{最多取MaxStringLen个字节}
dwBytes := min(nCount, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text[0]), lpString, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
end;
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TDrawTextA(Hook[fDrawTextA].OldFunction)(theDC, lpString, nCount, lpRect, uFormat);
end;
Hook[fDrawTextA].Change;{重新截取API}
end;
function NewDrawTextW(theDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
type
TDrawTextW=function (theDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
poMouse,poOri,poDC: TPoint;
dwBytes: integer;
RectSave,rec:TRect;
faint:boolean;
begin
Hook[fDrawTextW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := 0;{局部逻辑坐标初始化为(0,0)}
poDC.y := 0;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
RectSave := lpRect;{显示的矩形}
OffsetRect(RectSave, poOri.x+poDC.x, poOri.y+poDC.y);{显示的矩形加上偏移}
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{鼠标是否在文本的范围内}
if PtInRect(RectSave, poMouse) then
begin
if nCount=-1 then
begin
strcopy(@(pShMem^.Text[0]), Pchar(WideCharToString(lpString)));
end
else begin
{最多取MaxStringLen个字节}
dwBytes := min(nCount*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text[0]), Pchar(WideCharToString(lpString)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
end;
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TDrawTextW(Hook[fDrawTextW].OldFunction)(theDC, lpString, nCount, lpRect, uFormat);
end;
Hook[fDrawTextW].Change;{重新截取API}
end;
{遍历所有菜单项}
procedure IterateThroughItems(WND:HWND;menu:Hmenu;p:TPoint;Level:integer);
var
i:integer;
info:TMenuItemInfo;
rec:TRect;
begin
for i:=0 to GetMenuItemCount(menu)-1 do {遍历所有子菜单项}
begin
fillchar(info,sizeof(info),0);
info.cbSize:=sizeof(info);
info.fMask:=MIIM_TYPE or MIIM_SUBMENU;
info.cch:=256;
getmem(info.dwTypeData,256);
{取菜单的文字}
GetMenuItemInfo(menu,i,true,info);
{取菜单的坐标}
GetMenuItemRect(wnd,menu,i,rec);
{如果鼠标在菜单的矩形区域内}
if (rec.Left<=p.X)and(p.X<=rec.Right)and(rec.Top<=p.Y)and(p.Y<=rec.Bottom)then
if (info.cch<>0) then
begin
{取出菜单文字}
strlcopy(pShMem^.Text,info.dwTypeData,min(info.cch,MaxStringLen));
pShMem^.bCanSpyNow := False;
{发送WM_MOUSEPT成功取词的消息给主程序}
PostMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextW, 2);
end;
// freemem(info.dwTypeData,256);
// info.dwTypeData:=nil;
if info.hSubMenu<>0 then {如果它有下级子菜单，则归递调用}
begin
IterateThroughItems(wnd,info.hSubMenu,p,Level+1);
end;
end;
end;
{定时器，每10毫秒被调用一次}
procedure fOnTimer(theWnd: HWND; msg, idTimer: Cardinal; dwTime: DWORD); stdcall;
var
InvalidRect: TRECT;
buffer:array[0..256]of char;
menu:Hmenu;
MousePoint:TPoint;
begin
pShMem^.nTimePassed := pShMem^.nTimePassed + 1;
if pShMem^.nTimePassed = 10 then {如果鼠标停留了0.1秒}
begin
MousePoint:=pshmem^.pMouse;
{获取当前鼠标所在的窗口（等效于Delphi的控件）句柄}
pshmem^.hHookWnd := WindowFromPoint(MousePoint);
{屏幕坐标转换为窗口（等效于Delphi的控件）客户区的坐标}
ScreenToClient(pshmem^.hHookWnd, MousePoint);
pShMem^.bCanSpyNow := true;{可以开始取词}
{如果客户区的坐标为负值，则说明鼠标位于菜单或标题的上空}
if(MousePoint.x<0)or(MousePoint.y<0) then
begin
{读取并设置标题，让其重绘}
Getwindowtext(pshmem^.hHookWnd,buffer,sizeof(buffer)-1);
Setwindowtext(pshmem^.hHookWnd,pchar(string(buffer)+’ ‘));
Setwindowtext(pshmem^.hHookWnd,buffer);
{客户区的坐标恢复为屏幕坐标}
ClientToScreen(pshmem^.hHookWnd, MousePoint);
{取出当前的菜单}
menu:=GetMenu(pshmem^.hHookWnd);
if menu<>0 then
{遍历所有菜单，判断是否位于鼠标的下方}
IterateThroughItems(pshmem^.hHookWnd,menu,MousePoint,1);
end
else begin{否则，说明鼠标位于客户区}
InvalidRect.left := MousePoint.x;
InvalidRect.top := MousePoint.y;
InvalidRect.Right := MousePoint.x + 1;
InvalidRect.Bottom := MousePoint.y + 1;
{重绘客户区}
InvalidateRect(pshmem^.hHookWnd, @InvalidRect, false);
end;
end
else if pShMem^.nTimePassed >= 11 then
begin
pShMem^.nTimePassed := 11;
end;
{清空pShmem}
end;
{鼠标钩子}
function MouseHookProc(nCode: integer; wPar: WParam; lPar: LParam): lResult;
stdcall;
var
pMouseInf: TMouseHookStruct;
begin
pShMem^.nTimePassed := 0;
if (nCode >= 0) and ((wPar = WM_MOUSEMOVE)or(wPar = WM_NCMOUSEMOVE)) then
begin
pMouseInf := (PMouseHookStruct(lPar))^;
if (pShMem^.pMouse.x <> pMouseInf.pt.x) or
(pShMem^.pMouse.y <> pMouseInf.pt.y) then
begin
if nCode = HC_NOREMOVE then
pShMem^.fStrMouseQueue := ‘Not removed from the queue’
else
pShMem^.fStrMouseQueue := ‘Removed from the queue’;
{鼠标的坐标}
pShMem^.pMouse := pMouseInf.pt;
{鼠标所在的窗口}
pShMem^.hHookWnd := pMouseInf.hwnd;
{1是自定义的数值，表明这是鼠标消息}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, 1, 1);
end;
end;
Result := CallNextHookEx(MouseHook, nCode, wPar, lPar);
end;
{开始取词}
procedure StartHook; stdcall;
begin
if MouseHook=0 then
begin
pShMem^.fTimerID := SetTimer(0, 0, 10, @fOnTimer);
{注入其它进程}
MouseHook := SetWindowsHookEx(WH_MOUSE, MouseHookProc, HInstance, 0);
end;
end;
{停止取词}
procedure StopHook; stdcall;
begin
if MouseHook<>0 then
begin
KillTimer(0, pShMem^.fTimerID);
UnhookWindowsHookEx(MouseHook);
MouseHook:=0;
end;
end;
initialization
hMappingFile := OpenFileMapping(FILE_MAP_WRITE,False,MappingFileName);
if hMappingFile=0 then
begin
hMappingFile := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShareMem),MappingFileName);
FirstProcess:=true; {这是第一个进程，即主程序}
end
else FirstProcess:=false;
if hMappingFile=0 then Exception.Create(‘不能建立共享内存!’);
pShMem := MapViewOfFile(hMappingFile,FILE_MAP_WRITE or FILE_MAP_READ,0,0,0);
if pShMem = nil then
begin
CloseHandle(hMappingFile);
Exception.Create(‘不能映射共享内存!’);
end;
if FirstProcess then
begin
pShMem^.bCanSpyNow:=false;
end;
Hook[fBeginPaint]:=THookClass.Create(Trap,@BeginPaint,@NewBeginPaint);{Trap=True陷阱式}
Hook[fGetWindowDC]:=THookClass.Create(Trap,@GetWindowDC,@NewGetWindowDC);
Hook[fGetDC]:=THookClass.Create(Trap,@GetDC,@NewGetDC);
Hook[fCreateCompatibleDC]:=THookClass.Create(Trap,@CreateCompatibleDC,@NewCreateCompatibleDC);
Hook[fTextOutA]:=THookClass.Create(Trap,@TextOutA,@NewTextOutA);
Hook[fTextOutW]:=THookClass.Create(Trap,@TextOutW,@NewTextOutW);
Hook[fExtTextOutA]:=THookClass.Create(Trap,@ExtTextOutA,@NewExtTextOutA);
Hook[fExtTextOutW]:=THookClass.Create(Trap,@ExtTextOutW,@NewExtTextOutW);
Hook[fDrawTextA]:=THookClass.Create(Trap,@DrawTextA,@NewDrawTextA);
Hook[fDrawTextW]:=THookClass.Create(Trap,@DrawTextW,@NewDrawTextW);
finalization
for i:=Low(hook) to High(hook) do
if Hook[i]<>nil then
Hook[i].Destroy;
UnMapViewOfFile(pShMem); {取消映射视图}
CloseHandle(hMappingFile); {关闭映射文件句柄}
end.
UnitHookDll.pas (2)
//-----------------------------------------------------------------------------------
主窗体单元UnitMain.pas
unit UnitMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,UnitHookType, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
procedure getMouseInfo(var theMess:TMessage); message WM_MOUSEPT;{处理WM_MOUSEPT}
private
hMapObj : THandle;
pShMem : PShareMem;
fWndClosed:boolean;{是否正在退出主程序}
{ Private declarations }
public
{ Public declarations }
end;
// {未公开的函数，实现隐浮窗口}
// procedure SwitchToThisWindow(wnd:Hwnd;Switch:BOOL);stdcall;external 'user32.dll';
procedure StartHook; stdcall; external 'GetWordDll.DLL';
procedure StopHook; stdcall; external 'GetWordDll.DLL';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if button1.caption='取词' then
begin
StartHook;
button1.caption:='停止';
end
else begin
StopHook;
button1.caption:='取词';
end;
end;
const
StrProcNames : array[fTextOutA..fDrawTextW] of String =
('来自TextOutA',
'来自TextOutW',
'来自ExtTextOutA',
'来自ExtTextOutW',
'来自DrawTextA',
'来自菜单(来自DrawTextW)'
);
procedure TForm1.getMouseInfo(var theMess : TMessage);
begin
if fWndClosed then
Exit;
//if theMess.Msg=WM_MOUSEPT then showmessage('fff');
if theMess.LParam = 1 then{显示鼠标位置}
edit1.Text := 'X:' + IntToStr(pShMem^.pMouse.x) + ' ' +
'Y:' + IntToStr(pShMem^.pMouse.y) + ' ' +
'HWND:0x' + IntToHex(pShMem^.hHookWnd, 8) + ' ' +
pShMem^.fStrMouseQueue
else if theMess.LParam = 2 then
begin
edit2.Text := pShMem^.Text;
if (theMess.WParam>=4)and(theMess.WParam<=9) then
edit3.Text :=StrProcNames[theMess.Wparam-4];
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
fWndClosed := True;{正在退出主程序}
if button1.caption<>'取词' then
Button1Click(sender);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetForegroundWindow(self.Handle);{实现隐浮窗口}
hMapObj := OpenFileMapping(FILE_MAP_WRITE,{获取完全访问映射文件}
False,{不可继承的}
LPCTSTR(MappingFileName));{映射文件名字}
if hMapObj = 0 then
begin
ShowMessage('不能定位内存映射文件块!');
Halt;
end;
pShMem := MapViewOfFile(hMapObj,FILE_MAP_WRITE,0,0,0);
if pShMem = nil then
begin
ShowMessage('映射文件错误'+ IntToStr(GetLastError));
CloseHandle(hMapObj);
Halt;
end;
FillChar(pShMem^, SizeOf(TShareMem), 0);
pShMem^.hProcWnd := Self.Handle;
fWndClosed:=false;
end;
end.
library GetWordDll;
uses
Windows,
SysUtils,
Classes,
UnitHookDll in ‘UnitHookDll.pas’,
UnitNt2000Hook in ‘UnitNt2000Hook.pas’,
UnitHookType in ‘UnitHookType.pas’;
exports
StartHook,
StopHook;
// MouseWndProc,
{以下导出列表都是必须的，
不能少，因为程序要取其地址}
{ NewBeginPaint,
NewCreateCompatibleDC,
NewTextOutA,
NewTextOutW,
NewExtTextOutA,
NewExtTextOutW,
NewDrawTextA,
NewDrawTextW; }
begin
end.
2。新建3个单元UnitHookDll.pas，UnitHookType.pas，UnitNt2000Hook.pas具体代码如下
unit UnitHookDll;
interface
uses Windows, SysUtils, Classes, math, messages, dialogs, UnitNt2000Hook,
UnitHookType;
const
COLOR1=255;
COLOR2=0;
COLOR3=255;
Trap=true; //True陷阱式，False表示改引入表式
procedure StartHook; stdcall; {开始取词}
procedure StopHook; stdcall; {停止取词}
implementation
var
MouseHook: THandle;
pShMem: PShareMem;
hMappingFile: THandle;
FirstProcess:boolean;{是否是第一个进程}
Hook: array[fBeginPaint..fDrawTextW] of THookClass;{API HOOK类}
i:integer;
{自定义的BeginPaint}
function NewBeginPaint(Wnd: HWND; var lpPaint: TPaintStruct): HDC; stdcall;
type
TBeginPaint=function (Wnd: HWND; var lpPaint: TPaintStruct): HDC; stdcall;
begin
Hook[fBeginPaint].Restore;
result:=TBeginPaint(Hook[fBeginPaint].OldFunction)(Wnd,lpPaint);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fBeginPaint].Change;
end;
{自定义的GetWindowDC}
function NewGetWindowDC(Wnd: HWND): HDC; stdcall;
type
TGetWindowDC=function (Wnd: HWND): HDC; stdcall;
begin
Hook[fGetWindowDC].Restore;
result:=TGetWindowDC(Hook[fGetWindowDC].OldFunction)(Wnd);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fGetWindowDC].Change;
end;
{自定义的GetDC}
function NewGetDC(Wnd: HWND): HDC; stdcall;
type
TGetDC=function (Wnd: HWND): HDC; stdcall;
begin
Hook[fGetDC].Restore;
result:=TGetDC(Hook[fGetDC].OldFunction)(Wnd);
if Wnd=pshmem^.hHookWnd then{如果是当前鼠标的窗口句柄}
begin
pshmem^.DCMouse:=result;{记录它的返回值}
end
else pshmem^.DCMouse:=0;
Hook[fGetDC].Change;
end;
{自定义的CreateCompatibleDC}
function NewCreateCompatibleDC(DC: HDC): HDC; stdcall;
type
TCreateCompatibleDC=function (DC: HDC): HDC; stdcall;
begin
Hook[fCreateCompatibleDC].Restore;
result:=TCreateCompatibleDC(Hook[fCreateCompatibleDC].OldFunction)(DC);
if DC=pshmem^.DCMouse then{如果是当前鼠标的窗口HDC}
begin
pshmem^.DCCompatible:=result;{记录它的返回值}
end
else pshmem^.DCCompatible:=0;
Hook[fCreateCompatibleDC].Change;
end;
function NewTextOutA(theDC: HDC; nXStart, nYStart: integer; str: pchar; count: integer): bool;
stdcall;
type
TTextOutA=function (theDC: HDC; nXStart, nYStart: integer; str: pchar; count: integer): bool;stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fTextOutA].Restore;{暂停截取API，恢复被截的函数}
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPoint(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Str, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fTextOutA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TTextOutA(Hook[fTextOutA].OldFunction)(theDC, nXStart,
nYStart, str, count);
end;
Hook[fTextOutA].Change;{重新截取API}
end;
function NewTextOutW(theDC: HDC; nXStart, nYStart: integer; str: pWidechar; count: integer): bool; stdcall;
type
TTextOutW=function (theDC: HDC; nXStart, nYStart: integer; str: pWidechar; count: integer): bool; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fTextOutW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPointW(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Pchar(WideCharToString(Str)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fTextOutW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TTextOutW(Hook[fTextOutW].OldFunction)(theDC, nXStart, nYStart, str, Count);
end;
Hook[fTextOutW].Change;{重新截取API}
end;
function NewExtTextOutA(theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
type
TExtTextOutA=function (theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: PAnsiChar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fExtTextOutA].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPoint(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Str, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fExtTextOutA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TExtTextOutA(Hook[fExtTextOutA].OldFunction)(theDC, nXStart, nYStart, toOptions, rect, Str,
Count, Dx);
end;
Hook[fExtTextOutA].Change;{重新截取API}
end;
function NewExtTextOutW(theDC: HDC; nXStart, nYStart: integer; toOptions:
Longint; rect: PRect;
Str: Pwidechar; Count: Longint; Dx: PInteger): BOOL; stdcall;
type
TExtTextOutW=function (theDC: HDC; nXStart, nYStart: integer; toOptions:Longint;
rect: PRect; Str: Pwidechar; Count: Longint; Dx: PInteger): BOOL; stdcall;
var
dwBytes: DWORD;
poOri, poDC, poText, poMouse: TPoint;
Size: TSize;
Rec:TRect;
faint:boolean;
begin
Hook[fExtTextOutW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := nXStart;{显示的相对坐标}
poDC.y := nYStart;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
{计算显示文字的屏幕坐标}
poText.x := poDC.x + poOri.x;
poText.y := poDC.y + poOri.y;
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{如果对齐属性是居中}
if (GetTextAlign(theDC) and TA_UPDATECP) <> 0 then
begin
GetCurrentPositionEx(theDC, @poOri);
poText.x := poText.x + poOri.x;
poText.y := poText.y + poOri.y;
end;
{显示文字的长和宽}
GetTextExtentPointW(theDC, Str, Count, Size);
{鼠标是否在文本的范围内}
if (poMouse.x >= poText.x) and (poMouse.x <= poText.x + Size.cx)
and (poMouse.y >= poText.y) and (poMouse.y <= poText.y + Size.cy)
then
begin
{最多取MaxStringLen个字节}
dwBytes := min(Count*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text), Pchar(WideCharToString(Str)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fExtTextOutW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TExtTextOutW(Hook[fExtTextOutW].OldFunction)(theDC, nXStart, nYStart, toOptions,Rect, Str, Count, Dx);
end;
Hook[fExtTextOutW].Change;{重新截取API}
end;
function NewDrawTextA(theDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
type
TDrawTextA=function (theDC: HDC; lpString: PAnsiChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
poMouse,poOri,poDC: TPoint;
dwBytes: integer;
RectSave,rec:TRect;
faint:boolean;
begin
Hook[fDrawTextA].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := 0;{局部逻辑坐标初始化为(0,0)}
poDC.y := 0;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
RectSave := lpRect;{显示的矩形}
OffsetRect(RectSave, poOri.x+poDC.x, poOri.y+poDC.y);{显示的矩形加上偏移}
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{鼠标是否在文本的范围内}
if PtInRect(RectSave, poMouse) then
begin
if nCount=-1 then
begin
strcopy(@(pShMem^.Text[0]), lpString);
end
else begin
{最多取MaxStringLen个字节}
dwBytes := min(nCount, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text[0]), lpString, dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
end;
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextA, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TDrawTextA(Hook[fDrawTextA].OldFunction)(theDC, lpString, nCount, lpRect, uFormat);
end;
Hook[fDrawTextA].Change;{重新截取API}
end;
function NewDrawTextW(theDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
type
TDrawTextW=function (theDC: HDC; lpString: PWideChar; nCount: Integer;
var lpRect: TRect; uFormat: UINT): Integer; stdcall;
var
poMouse,poOri,poDC: TPoint;
dwBytes: integer;
RectSave,rec:TRect;
faint:boolean;
begin
Hook[fDrawTextW].Restore;{暂停截取API，恢复被截的函数}
// SetTextColor(thedc,RGB(COLOR1,COLOR2,COLOR3));
try
if pShMem^.bCanSpyNow then{是否开始取词}
begin
GetDCOrgEx(theDC, poOri);{HDC的坐标}
poDC.x := 0;{局部逻辑坐标初始化为(0,0)}
poDC.y := 0;
if(poOri.X=0)and(poOri.Y=0)then{如果HDC的坐标为(0,0)}
begin
if (theDC=pShmem^.DCCompatible)then
faint:=false{精确匹配，就是指定的内存HDC}
else faint:=true;{模糊匹配，"可能"是内存HDC}
{取鼠标当前处的窗口（等效于Delphi的控件）坐标}
GetWindowRect(pShMem^.hHookWnd,Rec);
poOri.X:=Rec.Left;{把窗口坐标作为HDC的坐标}
poOri.Y:=Rec.Top;
end
else begin{如果是普通HDC}
{局部逻辑坐标转化为设备相关坐标}
LPToDP(theDC, poDC, 1);
faint:=false;{精确匹配，是普通HDC}
end;
RectSave := lpRect;{显示的矩形}
OffsetRect(RectSave, poOri.x+poDC.x, poOri.y+poDC.y);{显示的矩形加上偏移}
{获取当前鼠标的坐标}
GetCursorPos(poMouse);
{鼠标是否在文本的范围内}
if PtInRect(RectSave, poMouse) then
begin
if nCount=-1 then
begin
strcopy(@(pShMem^.Text[0]), Pchar(WideCharToString(lpString)));
end
else begin
{最多取MaxStringLen个字节}
dwBytes := min(nCount*2, MaxStringLen);
{拷贝字符串}
CopyMemory(@(pShMem^.Text[0]), Pchar(WideCharToString(lpString)), dwBytes);
{以空字符结束}
pShMem^.Text[dwBytes] := Chr(0);
end;
{发送WM_MOUSEPT成功取词的消息给主程序}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextW, 2);
{如果输出的不是Tab键，而且是精确匹配的}
if (string(pShMem^.Text)<>#3)and(not faint) then
pShMem^.bCanSpyNow := False;{取词结束}
end;
end;
finally
{调用被截的函数}
result := TDrawTextW(Hook[fDrawTextW].OldFunction)(theDC, lpString, nCount, lpRect, uFormat);
end;
Hook[fDrawTextW].Change;{重新截取API}
end;
{遍历所有菜单项}
procedure IterateThroughItems(WND:HWND;menu:Hmenu;p:TPoint;Level:integer);
var
i:integer;
info:TMenuItemInfo;
rec:TRect;
begin
for i:=0 to GetMenuItemCount(menu)-1 do {遍历所有子菜单项}
begin
fillchar(info,sizeof(info),0);
info.cbSize:=sizeof(info);
info.fMask:=MIIM_TYPE or MIIM_SUBMENU;
info.cch:=256;
getmem(info.dwTypeData,256);
{取菜单的文字}
GetMenuItemInfo(menu,i,true,info);
{取菜单的坐标}
GetMenuItemRect(wnd,menu,i,rec);
{如果鼠标在菜单的矩形区域内}
if (rec.Left<=p.X)and(p.X<=rec.Right)and(rec.Top<=p.Y)and(p.Y<=rec.Bottom)then
if (info.cch<>0) then
begin
{取出菜单文字}
strlcopy(pShMem^.Text,info.dwTypeData,min(info.cch,MaxStringLen));
pShMem^.bCanSpyNow := False;
{发送WM_MOUSEPT成功取词的消息给主程序}
PostMessage(pShMem^.hProcWnd, WM_MOUSEPT, fDrawTextW, 2);
end;
// freemem(info.dwTypeData,256);
// info.dwTypeData:=nil;
if info.hSubMenu<>0 then {如果它有下级子菜单，则归递调用}
begin
IterateThroughItems(wnd,info.hSubMenu,p,Level+1);
end;
end;
end;
{定时器，每10毫秒被调用一次}
procedure fOnTimer(theWnd: HWND; msg, idTimer: Cardinal; dwTime: DWORD); stdcall;
var
InvalidRect: TRECT;
buffer:array[0..256]of char;
menu:Hmenu;
MousePoint:TPoint;
begin
pShMem^.nTimePassed := pShMem^.nTimePassed + 1;
if pShMem^.nTimePassed = 10 then {如果鼠标停留了0.1秒}
begin
MousePoint:=pshmem^.pMouse;
{获取当前鼠标所在的窗口（等效于Delphi的控件）句柄}
pshmem^.hHookWnd := WindowFromPoint(MousePoint);
{屏幕坐标转换为窗口（等效于Delphi的控件）客户区的坐标}
ScreenToClient(pshmem^.hHookWnd, MousePoint);
pShMem^.bCanSpyNow := true;{可以开始取词}
{如果客户区的坐标为负值，则说明鼠标位于菜单或标题的上空}
if(MousePoint.x<0)or(MousePoint.y<0) then
begin
{读取并设置标题，让其重绘}
Getwindowtext(pshmem^.hHookWnd,buffer,sizeof(buffer)-1);
Setwindowtext(pshmem^.hHookWnd,pchar(string(buffer)+’ ‘));
Setwindowtext(pshmem^.hHookWnd,buffer);
{客户区的坐标恢复为屏幕坐标}
ClientToScreen(pshmem^.hHookWnd, MousePoint);
{取出当前的菜单}
menu:=GetMenu(pshmem^.hHookWnd);
if menu<>0 then
{遍历所有菜单，判断是否位于鼠标的下方}
IterateThroughItems(pshmem^.hHookWnd,menu,MousePoint,1);
end
else begin{否则，说明鼠标位于客户区}
InvalidRect.left := MousePoint.x;
InvalidRect.top := MousePoint.y;
InvalidRect.Right := MousePoint.x + 1;
InvalidRect.Bottom := MousePoint.y + 1;
{重绘客户区}
InvalidateRect(pshmem^.hHookWnd, @InvalidRect, false);
end;
end
else if pShMem^.nTimePassed >= 11 then
begin
pShMem^.nTimePassed := 11;
end;
{清空pShmem}
end;
{鼠标钩子}
function MouseHookProc(nCode: integer; wPar: WParam; lPar: LParam): lResult;
stdcall;
var
pMouseInf: TMouseHookStruct;
begin
pShMem^.nTimePassed := 0;
if (nCode >= 0) and ((wPar = WM_MOUSEMOVE)or(wPar = WM_NCMOUSEMOVE)) then
begin
pMouseInf := (PMouseHookStruct(lPar))^;
if (pShMem^.pMouse.x <> pMouseInf.pt.x) or
(pShMem^.pMouse.y <> pMouseInf.pt.y) then
begin
if nCode = HC_NOREMOVE then
pShMem^.fStrMouseQueue := ‘Not removed from the queue’
else
pShMem^.fStrMouseQueue := ‘Removed from the queue’;
{鼠标的坐标}
pShMem^.pMouse := pMouseInf.pt;
{鼠标所在的窗口}
pShMem^.hHookWnd := pMouseInf.hwnd;
{1是自定义的数值，表明这是鼠标消息}
postMessage(pShMem^.hProcWnd, WM_MOUSEPT, 1, 1);
end;
end;
Result := CallNextHookEx(MouseHook, nCode, wPar, lPar);
end;
{开始取词}
procedure StartHook; stdcall;
begin
if MouseHook=0 then
begin
pShMem^.fTimerID := SetTimer(0, 0, 10, @fOnTimer);
{注入其它进程}
MouseHook := SetWindowsHookEx(WH_MOUSE, MouseHookProc, HInstance, 0);
end;
end;
{停止取词}
procedure StopHook; stdcall;
begin
if MouseHook<>0 then
begin
KillTimer(0, pShMem^.fTimerID);
UnhookWindowsHookEx(MouseHook);
MouseHook:=0;
end;
end;
initialization
hMappingFile := OpenFileMapping(FILE_MAP_WRITE,False,MappingFileName);
if hMappingFile=0 then
begin
hMappingFile := CreateFileMapping($FFFFFFFF,nil,PAGE_READWRITE,0,SizeOf(TShareMem),MappingFileName);
FirstProcess:=true; {这是第一个进程，即主程序}
end
else FirstProcess:=false;
if hMappingFile=0 then Exception.Create(‘不能建立共享内存!’);
pShMem := MapViewOfFile(hMappingFile,FILE_MAP_WRITE or FILE_MAP_READ,0,0,0);
if pShMem = nil then
begin
CloseHandle(hMappingFile);
Exception.Create(‘不能映射共享内存!’);
end;
if FirstProcess then
begin
pShMem^.bCanSpyNow:=false;
end;
Hook[fBeginPaint]:=THookClass.Create(Trap,@BeginPaint,@NewBeginPaint);{Trap=True陷阱式}
Hook[fGetWindowDC]:=THookClass.Create(Trap,@GetWindowDC,@NewGetWindowDC);
Hook[fGetDC]:=THookClass.Create(Trap,@GetDC,@NewGetDC);
Hook[fCreateCompatibleDC]:=THookClass.Create(Trap,@CreateCompatibleDC,@NewCreateCompatibleDC);
Hook[fTextOutA]:=THookClass.Create(Trap,@TextOutA,@NewTextOutA);
Hook[fTextOutW]:=THookClass.Create(Trap,@TextOutW,@NewTextOutW);
Hook[fExtTextOutA]:=THookClass.Create(Trap,@ExtTextOutA,@NewExtTextOutA);
Hook[fExtTextOutW]:=THookClass.Create(Trap,@ExtTextOutW,@NewExtTextOutW);
Hook[fDrawTextA]:=THookClass.Create(Trap,@DrawTextA,@NewDrawTextA);
Hook[fDrawTextW]:=THookClass.Create(Trap,@DrawTextW,@NewDrawTextW);
finalization
for i:=Low(hook) to High(hook) do
if Hook[i]<>nil then
Hook[i].Destroy;
UnMapViewOfFile(pShMem); {取消映射视图}
CloseHandle(hMappingFile); {关闭映射文件句柄}
end.
UnitHookDll.pas (2)
//-----------------------------------------------------------------------------------
主窗体单元UnitMain.pas
unit UnitMain;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls,UnitHookType, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Edit1: TEdit;
Edit2: TEdit;
Edit3: TEdit;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
procedure FormCreate(Sender: TObject);
private
procedure getMouseInfo(var theMess:TMessage); message WM_MOUSEPT;{处理WM_MOUSEPT}
private
hMapObj : THandle;
pShMem : PShareMem;
fWndClosed:boolean;{是否正在退出主程序}
{ Private declarations }
public
{ Public declarations }
end;
// {未公开的函数，实现隐浮窗口}
// procedure SwitchToThisWindow(wnd:Hwnd;Switch:BOOL);stdcall;external 'user32.dll';
procedure StartHook; stdcall; external 'GetWordDll.DLL';
procedure StopHook; stdcall; external 'GetWordDll.DLL';
var
Form1: TForm1;
implementation
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
if button1.caption='取词' then
begin
StartHook;
button1.caption:='停止';
end
else begin
StopHook;
button1.caption:='取词';
end;
end;
const
StrProcNames : array[fTextOutA..fDrawTextW] of String =
('来自TextOutA',
'来自TextOutW',
'来自ExtTextOutA',
'来自ExtTextOutW',
'来自DrawTextA',
'来自菜单(来自DrawTextW)'
);
procedure TForm1.getMouseInfo(var theMess : TMessage);
begin
if fWndClosed then
Exit;
//if theMess.Msg=WM_MOUSEPT then showmessage('fff');
if theMess.LParam = 1 then{显示鼠标位置}
edit1.Text := 'X:' + IntToStr(pShMem^.pMouse.x) + ' ' +
'Y:' + IntToStr(pShMem^.pMouse.y) + ' ' +
'HWND:0x' + IntToHex(pShMem^.hHookWnd, 8) + ' ' +
pShMem^.fStrMouseQueue
else if theMess.LParam = 2 then
begin
edit2.Text := pShMem^.Text;
if (theMess.WParam>=4)and(theMess.WParam<=9) then
edit3.Text :=StrProcNames[theMess.Wparam-4];
end;
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
fWndClosed := True;{正在退出主程序}
if button1.caption<>'取词' then
Button1Click(sender);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetForegroundWindow(self.Handle);{实现隐浮窗口}
hMapObj := OpenFileMapping(FILE_MAP_WRITE,{获取完全访问映射文件}
False,{不可继承的}
LPCTSTR(MappingFileName));{映射文件名字}
if hMapObj = 0 then
begin
ShowMessage('不能定位内存映射文件块!');
Halt;
end;
pShMem := MapViewOfFile(hMapObj,FILE_MAP_WRITE,0,0,0);
if pShMem = nil then
begin
ShowMessage('映射文件错误'+ IntToStr(GetLastError));
CloseHandle(hMapObj);
Halt;
end;
FillChar(pShMem^, SizeOf(TShareMem), 0);
pShMem^.hProcWnd := Self.Handle;
fWndClosed:=false;
end;
end.
폼에 드래그 앤 드롭 구현
출처 : 김영대님 홈피 (http://www.howto.pe.kr)
unitMain;
interface
uses
Windows, Messages, SysUtils, Classes, ShellApi;
type
TfrmMain=class(TForm)
procedureFormActivate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;
end;
var
frmMain: TfrmMain;
implementation
procedure TfrmMain.FormActivate(Sender: TObject);
begin
// Drag&Drop Accept
DragAcceptFiles(Handle, True);
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
// Drag&Drop Accept 해제
DragAcceptFiles(Handle, False);
// 폼닫기
CanClose:=True;
end;
procedure TfrmMain.WMDropFiles(var Msg: TMessage);
var
i, cntDropItem, DropItemNameLength: Integer;
hDrop: THandle;
DropItemPath: array [0..MAX_PATH] of Char;
begin
try
// Drop Handle
hDrop:=Msg.wParam;
// Drop된 아이템 갯수
cntDropItem:=DragQueryFile(hDrop, $FFFFFFFF, nil,0);
for i:=0tocntDropItem-1 do begin
// Drop된 파일경로 길이
DropItemNameLength:=DragQueryFile(hDrop, i, nil, 0);
// Drop된 파일경로
DragQueryFile(hDrop, i, DropItemPath, DropItemNameLength+1);
// 출력...
OutputDebugString(PWideChar(DropItemPath));
end;
finally
DragFinish(hDrop);
end;
Msg.Result:=0;
inherited;
end;
unitMain;
interface
uses
Windows, Messages, SysUtils, Classes, ShellApi;
type
TfrmMain=class(TForm)
procedureFormActivate(Sender: TObject);
procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
private
procedure WMDropFiles(var Msg: TMessage); message WM_DROPFILES;
end;
var
frmMain: TfrmMain;
implementation
procedure TfrmMain.FormActivate(Sender: TObject);
begin
// Drag&Drop Accept
DragAcceptFiles(Handle, True);
end;
procedure TfrmMain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
// Drag&Drop Accept 해제
DragAcceptFiles(Handle, False);
// 폼닫기
CanClose:=True;
end;
procedure TfrmMain.WMDropFiles(var Msg: TMessage);
var
i, cntDropItem, DropItemNameLength: Integer;
hDrop: THandle;
DropItemPath: array [0..MAX_PATH] of Char;
begin
try
// Drop Handle
hDrop:=Msg.wParam;
// Drop된 아이템 갯수
cntDropItem:=DragQueryFile(hDrop, $FFFFFFFF, nil,0);
for i:=0tocntDropItem-1 do begin
// Drop된 파일경로 길이
DropItemNameLength:=DragQueryFile(hDrop, i, nil, 0);
// Drop된 파일경로
DragQueryFile(hDrop, i, DropItemPath, DropItemNameLength+1);
// 출력...
OutputDebugString(PWideChar(DropItemPath));
end;
finally
DragFinish(hDrop);
end;
Msg.Result:=0;
inherited;
end;
다른 프로그램의 텍스트 가져오기
WM_GETTEXT 사용하기.
GetWindowText 요런건 다른 프로세스의 것은 잘 안된다.
그래서 만든 함수.
function GetWindowText(aHWND: HWND): String;
var
len: Integer;
begin
len:=SendMessage(aHWND, WM_GETTEXTLENGTH, 0, 0);
SetLength(Result, len+1);
SendMessage(aHWND, WM_GETTEXT, len+1, lParam(PChar(Result)));
end;
예제) 아래처럼 하면 커서 밑에 있는 윈도우의 텍스트를 가져온다.
Form1.Memo1.Lines.Add(GetWindowText(WindowFromPoint(Mouse.CursorPos)));
!!!
그러나 에디트플러스의 에디터 창에 있는 걸 가져오면,
왠만하면 가져와지는데 일정 길이가 넘어가면 이상하게 잘린다.
중간에 #0 을 만나버리는 걸 확인했다.
WM_GETTEXT 를 사용하는 SendMessage 에서 wParam 값을 살살 바꿔가며 실험해보니 이게 또 달라진다.
GetWindowText 요런건 다른 프로세스의 것은 잘 안된다.
그래서 만든 함수.
function GetWindowText(aHWND: HWND): String;
var
len: Integer;
begin
len:=SendMessage(aHWND, WM_GETTEXTLENGTH, 0, 0);
SetLength(Result, len+1);
SendMessage(aHWND, WM_GETTEXT, len+1, lParam(PChar(Result)));
end;
예제) 아래처럼 하면 커서 밑에 있는 윈도우의 텍스트를 가져온다.
Form1.Memo1.Lines.Add(GetWindowText(WindowFromPoint(Mouse.CursorPos)));
!!!
그러나 에디트플러스의 에디터 창에 있는 걸 가져오면,
왠만하면 가져와지는데 일정 길이가 넘어가면 이상하게 잘린다.
중간에 #0 을 만나버리는 걸 확인했다.
WM_GETTEXT 를 사용하는 SendMessage 에서 wParam 값을 살살 바꿔가며 실험해보니 이게 또 달라진다.
폼에 마우스 이벤트 통과시키기
알송을 보면 폼 위에서 클릭을 해도 마우스 이벤트가 통과하여 그 뒤에 있는 창이 클릭된다.
이 기능을 하는 함수이다.
윈도우 핸들을 받아서 마우스 이벤트를 통과시킨다.
SetTransparent(핸들, True or False); 처럼 사용하면 됨. True 는 통과시키기, False 는 통과시키지 않기.
procedure SetTransparent(aHWND: HWND; Transparent: Boolean);
var
orgStyle: Integer;
Style: Integer;
begin
orgStyle:=GetWindowLong(aHWND, GWL_EXSTYLE);
// 이벤트 통과 시키기
if Transparent then Style:=orgStyle or WS_EX_LAYERED or WS_EX_TRANSPARENT
// 이벤트 통과 안되게 복구하기 else Style:=orgStyle and (not WS_EX_TRANSPARENT) and (not WS_EX_LAYERED);
SetWindowLong(aHWND, GWL_EXSTYLE, Style);
end;
키포인트는 WS_EX_TRANSPARENT 였다.
하지만 여기서 약간의 문제가 있으니 WS_EX_LAYERED 가 문제다.
원래부터 WS_EX_LAYERED 가 없었던 윈도우라면 저 함수로 아무 문제가 없으나,
델파이 TForm 의 property 에서 AlphaBlend 를 True 로 하고 반투명 창으로 쓴다면,
이벤트 통과 시키기를 하고 난 후 통과시키지 않게 복구하는데 and (not WS_EX_LAYERED) 가 적용되어 반투명 효과가 사라져버린다.
static 같은게 있었으면 어떻게 쓰겠는데 그냥 클래스로 하나 만들어 버렸다.
생성자에서 원래부터 WS_EX_LAYERED 가 있었는지 여부를 Boolean 변수로 받아서,
복구시킬 때 WS_EX_LAYERED 를 뺄지 말지 결정한다.
{ interface }
type
TTransparent=class
private
FAlphaBlend: Boolean;
public
constructor Create(AlphaBlend: Boolean); reintroduce;
procedure SetTransparent(aHWND: HWND; Transparent: Boolean);
end;
{ implementation }
constructor TTransparent.Create(AlphaBlend: Boolean);
begin
FAlphaBlend:=AlphaBlend;
end;
procedure TTransparent.SetTransparent(aHWND: HWND; Transparent: Boolean);
var
orgStyle: Integer;
Style: Integer;
begin
orgStyle:=GetWindowLong(aHWND, GWL_EXSTYLE);
if Transparent then
Style:=orgStyle or WS_EX_LAYERED or WS_EX_TRANSPARENT
else begin Style:=orgStyle and (not WS_EX_TRANSPARENT);
if not FAlphaBlend then Style:=Style and (orgStyle and (not WS_EX_LAYERED));
end;
SetWindowLong(aHWND, GWL_EXSTYLE, Style);
end;
... ...
var
TP: TTransparent;
원래부터 반투명창이었다면,
TP:=TTransparent.Create(True); 로 생성해서 아래처럼 사용하면 되고,
TP.SetTransparent(Form2.Handle, True); // 통과시키기
TP.SetTransparent(Form2.Handle, False); // 통과시키지 않기
반투명이 아니었다면,
생성할 때만 TP:=TTransparent.Create(False); 로 생성해서 똑같이 사용하면 된다.
이 기능을 하는 함수이다.
윈도우 핸들을 받아서 마우스 이벤트를 통과시킨다.
SetTransparent(핸들, True or False); 처럼 사용하면 됨. True 는 통과시키기, False 는 통과시키지 않기.
procedure SetTransparent(aHWND: HWND; Transparent: Boolean);
var
orgStyle: Integer;
Style: Integer;
begin
orgStyle:=GetWindowLong(aHWND, GWL_EXSTYLE);
// 이벤트 통과 시키기
if Transparent then Style:=orgStyle or WS_EX_LAYERED or WS_EX_TRANSPARENT
// 이벤트 통과 안되게 복구하기 else Style:=orgStyle and (not WS_EX_TRANSPARENT) and (not WS_EX_LAYERED);
SetWindowLong(aHWND, GWL_EXSTYLE, Style);
end;
키포인트는 WS_EX_TRANSPARENT 였다.
하지만 여기서 약간의 문제가 있으니 WS_EX_LAYERED 가 문제다.
원래부터 WS_EX_LAYERED 가 없었던 윈도우라면 저 함수로 아무 문제가 없으나,
델파이 TForm 의 property 에서 AlphaBlend 를 True 로 하고 반투명 창으로 쓴다면,
이벤트 통과 시키기를 하고 난 후 통과시키지 않게 복구하는데 and (not WS_EX_LAYERED) 가 적용되어 반투명 효과가 사라져버린다.
static 같은게 있었으면 어떻게 쓰겠는데 그냥 클래스로 하나 만들어 버렸다.
생성자에서 원래부터 WS_EX_LAYERED 가 있었는지 여부를 Boolean 변수로 받아서,
복구시킬 때 WS_EX_LAYERED 를 뺄지 말지 결정한다.
{ interface }
type
TTransparent=class
private
FAlphaBlend: Boolean;
public
constructor Create(AlphaBlend: Boolean); reintroduce;
procedure SetTransparent(aHWND: HWND; Transparent: Boolean);
end;
{ implementation }
constructor TTransparent.Create(AlphaBlend: Boolean);
begin
FAlphaBlend:=AlphaBlend;
end;
procedure TTransparent.SetTransparent(aHWND: HWND; Transparent: Boolean);
var
orgStyle: Integer;
Style: Integer;
begin
orgStyle:=GetWindowLong(aHWND, GWL_EXSTYLE);
if Transparent then
Style:=orgStyle or WS_EX_LAYERED or WS_EX_TRANSPARENT
else begin Style:=orgStyle and (not WS_EX_TRANSPARENT);
if not FAlphaBlend then Style:=Style and (orgStyle and (not WS_EX_LAYERED));
end;
SetWindowLong(aHWND, GWL_EXSTYLE, Style);
end;
... ...
var
TP: TTransparent;
원래부터 반투명창이었다면,
TP:=TTransparent.Create(True); 로 생성해서 아래처럼 사용하면 되고,
TP.SetTransparent(Form2.Handle, True); // 통과시키기
TP.SetTransparent(Form2.Handle, False); // 통과시키지 않기
반투명이 아니었다면,
생성할 때만 TP:=TTransparent.Create(False); 로 생성해서 똑같이 사용하면 된다.
윈도우 핸들로 실행파일 이름 알아내기
윈도우 핸들(HWND)로 실행파일 이름(프로세스명) 알아내기.
1. 윈도우 핸들로 프로세스ID를 얻는다.
2. 프로세스를 다 뒤지면서 얻어낸 프로세스ID와 일치하는 프로세스를 찾는다.
3. 찾아내면 해당 프로세스의 szExeName 이 실행파일 이름.
uses 에 TlHelp32 추가해야 함.
function GetExeNameFromHWND(aHWND: HWND): String;
var
dwProcID: DWORD;
hSnapshot: HWND;
Proc32: PROCESSENTRY32;
begin
Result:='';
// 1. 윈도우 핸들로 프로세스ID 가져오기 GetWindowThreadProcessID(aHWND, dwProcID);
// 2. 시스템의 프로세스 스냅샷 가져오기
hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot=INVALID_HANDLE_VALUEthen begin
OutputDebugString('[Error] - CreateToolhelp32Snapshot returns INVALID_HANDLE_VALUE');
Exit;
end;
// 3. 첫번째 엔트리부터 뒤지기 시작
Proc32.dwSize:=SizeOf(PROCESSENTRY32);
if Process32First(hSnapshot, Proc32)=FALSE then begin OutputDebugString('[Error] Process32First returns FALSE');
Exit;
end;
// 4. 프로세스ID가 일치하면 실행파일명 반환
repeat if dwProcID=Proc32.th32ProcessID then begin Result:=Trim(Proc32.szExeFile);
Exit;
end;
until not Process32Next(hSnapshot, Proc32);
end;
1. 윈도우 핸들로 프로세스ID를 얻는다.
2. 프로세스를 다 뒤지면서 얻어낸 프로세스ID와 일치하는 프로세스를 찾는다.
3. 찾아내면 해당 프로세스의 szExeName 이 실행파일 이름.
uses 에 TlHelp32 추가해야 함.
function GetExeNameFromHWND(aHWND: HWND): String;
var
dwProcID: DWORD;
hSnapshot: HWND;
Proc32: PROCESSENTRY32;
begin
Result:='';
// 1. 윈도우 핸들로 프로세스ID 가져오기 GetWindowThreadProcessID(aHWND, dwProcID);
// 2. 시스템의 프로세스 스냅샷 가져오기
hSnapshot:=CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
if hSnapshot=INVALID_HANDLE_VALUEthen begin
OutputDebugString('[Error] - CreateToolhelp32Snapshot returns INVALID_HANDLE_VALUE');
Exit;
end;
// 3. 첫번째 엔트리부터 뒤지기 시작
Proc32.dwSize:=SizeOf(PROCESSENTRY32);
if Process32First(hSnapshot, Proc32)=FALSE then begin OutputDebugString('[Error] Process32First returns FALSE');
Exit;
end;
// 4. 프로세스ID가 일치하면 실행파일명 반환
repeat if dwProcID=Proc32.th32ProcessID then begin Result:=Trim(Proc32.szExeFile);
Exit;
end;
until not Process32Next(hSnapshot, Proc32);
end;
웹브라우저에 HTML 코드 밀어넣기
TWebBrowser 에 HTML 코드를 로딩시키는 함수
procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: String);
var
sList: TStringList;
mStream: TMemoryStream;
begin
// 1. 웹브라우저에 빈페이지 로딩 WebBrowser.Navigate('about:blank');
while WebBrowser.ReadyStatedo Application.ProcessMessages;
// 2. 웹브라우저가 Assigned 되어 있을 경우
if Assigned(WebBrowser.Document)then begin
sList:=TStringList.Create;
mStream:=TMemoryStream.Create;
try
// 3. HTML 코드를 메모리스트림에 복사하여 웹브라우저로 읽어들임
sList.Text:=HTMLCode;
sList.SaveToStream(mStream);
mStream.Seek(0, 0);
(WebBrowser.Document asIPersistStreamInit).Load(TStreamAdapter.Create(mStream));
finally
FreeAndNil(mStream);
FreeAndNil(sList);
end;
end;
end;
procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: String);
var
sList: TStringList;
mStream: TMemoryStream;
begin
// 1. 웹브라우저에 빈페이지 로딩 WebBrowser.Navigate('about:blank');
while WebBrowser.ReadyStatedo Application.ProcessMessages;
// 2. 웹브라우저가 Assigned 되어 있을 경우
if Assigned(WebBrowser.Document)then begin
sList:=TStringList.Create;
mStream:=TMemoryStream.Create;
try
// 3. HTML 코드를 메모리스트림에 복사하여 웹브라우저로 읽어들임
sList.Text:=HTMLCode;
sList.SaveToStream(mStream);
mStream.Seek(0, 0);
(WebBrowser.Document asIPersistStreamInit).Load(TStreamAdapter.Create(mStream));
finally
FreeAndNil(mStream);
FreeAndNil(sList);
end;
end;
end;
IdHTTP를 이용해 소스 가져와지지 않을 때
IdHTTP 를 이용해 소스를 가져오다가 가져와지지 않는 경우가 있음.
이 중 UserAgent 로 검사를 해서 다른 페이지로 리다이렉트 해버리는 경우가 있음. (로또 홈페이지 - http://http://645lotto.net)
이럴 땐 UserAgent 를 잘 설정하면 됨.
로또 홈페이지의 경우 아래처럼 설정하면 잘 됨.
이 중 UserAgent 로 검사를 해서 다른 페이지로 리다이렉트 해버리는 경우가 있음. (로또 홈페이지 - http://http://645lotto.net)
이럴 땐 UserAgent 를 잘 설정하면 됨.
로또 홈페이지의 경우 아래처럼 설정하면 잘 됨.
procedureTForm1.Button1Click(Sender: TObject);
varIdHTTP1: TIdHTTP;
begin
IdHTTP1:=TIdHTTP.Create(nil);
try
IdHTTP1.Request.UserAgent:='Mozilla/4.0';
Memo1.Text:=IdHTTP1.Get(로또_홈페이지);
finally
FreeAndNil(IdHTTP1);
end;
end;
TMemo 에서 라인 선택하기
TMemo 에서 라인별로 마우스 드래그를 통해 선택한 것처럼 하는 함수.
procedureMemoLineSelect(Memo: TMemo; LineNum: Integer);
begin
if Memo.Lines.Count<=LineNum thenExit;
Memo.SetFocus;
Memo.SelStart:=Pos(Memo.Lines[LineNum], Memo.Text)-1;
Memo.SelLength:=Length(Memo.Lines[LineNum]);
end;
만약 Memo1 의 첫번째 라인을 선택하고자 한다면, 아래처럼 호출.
MemoLineSelect(Memo1, 0);
procedureMemoLineSelect(Memo: TMemo; LineNum: Integer);
begin
if Memo.Lines.Count<=LineNum thenExit;
Memo.SetFocus;
Memo.SelStart:=Pos(Memo.Lines[LineNum], Memo.Text)-1;
Memo.SelLength:=Length(Memo.Lines[LineNum]);
end;
만약 Memo1 의 첫번째 라인을 선택하고자 한다면, 아래처럼 호출.
MemoLineSelect(Memo1, 0);
레지스트리 바이너리값 읽기
바이트의 배열로 읽어들여서 하나씩 출력하는 예제.
procedureTForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
Size: Integer;
Buffer: array ofByte;
i: Integer;
begin
Reg:=TRegistry.Create;
try
ifReg.OpenKeyReadOnly('Software\TestKey') then begin
Size:=Reg.GetDataSize('RegBinary');
SetLength(Buffer, Size);
Reg.ReadBinaryData('RegBinary', Buffer[0], Size);
fori:=0toSize-1doMemo1.Lines.Add(Format('[%2d] = %x', [i, Buffer[i]]));
end;
finally
FreeAndNil(Reg);
end;
end;
만약 전부 문자열이라면 String 으로 읽어들이면 되는데 그 방법이 Byte 배열과 약간 다르다.
아래와 같이 하면 됨.
procedureTForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
Size: Integer;
Buffer: String;
begin
Reg:=TRegistry.Create;
try
ifReg.OpenKeyReadOnly('Software\TestKey') then begin
Size:=Reg.GetDataSize('RegBinary');
SetLength(Buffer, Size);
Reg.ReadBinaryData('RegBinary', Buffer[1], Size);
Memo1.Lines.Add(Buffer);
end;
finally
FreeAndNil(Reg);
end;
end;
procedureTForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
Size: Integer;
Buffer: array ofByte;
i: Integer;
begin
Reg:=TRegistry.Create;
try
ifReg.OpenKeyReadOnly('Software\TestKey') then begin
Size:=Reg.GetDataSize('RegBinary');
SetLength(Buffer, Size);
Reg.ReadBinaryData('RegBinary', Buffer[0], Size);
fori:=0toSize-1doMemo1.Lines.Add(Format('[%2d] = %x', [i, Buffer[i]]));
end;
finally
FreeAndNil(Reg);
end;
end;
만약 전부 문자열이라면 String 으로 읽어들이면 되는데 그 방법이 Byte 배열과 약간 다르다.
아래와 같이 하면 됨.
procedureTForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
Size: Integer;
Buffer: String;
begin
Reg:=TRegistry.Create;
try
ifReg.OpenKeyReadOnly('Software\TestKey') then begin
Size:=Reg.GetDataSize('RegBinary');
SetLength(Buffer, Size);
Reg.ReadBinaryData('RegBinary', Buffer[1], Size);
Memo1.Lines.Add(Buffer);
end;
finally
FreeAndNil(Reg);
end;
end;
IE 띄우기
일단 아래와 같이 하면 IE가 뜬다.
usesComObj;
procedureTForm1.Button1Click(Sender: TObject);
var IE: OleVariant;
begin
try
IE:=CreateOleObject('Internetexplorer.Application');
// 위치, 크기
IE.Left:=0;
IE.Top :=0;
IE.Width :=500;
IE.Height:=400;
// IE 윈도우 상태
IE.Toolbar :=False;
IE.Statusbar:=False;
IE.Menubar :=False;
// 띄우기
IE.Visible:=True;
SetForegroundWindow(IE.HWND);
IE.Navigate('http://www.naver.com');
finally
IE:=Unassigned;
end;
end;
IE를 띄우는데 먼저 띄운 IE가 있다면 그 IE를 최상위로 올리고,
만약 먼저 띄운 IE가 꺼지고 없다면 새로 띄우려면 아래처럼 하면 됨.
uses ComObj;
const NOT_EXISTS = 0;
EXISTS =1;
var
IE_HWND: HWND;
// 윈도우를 모조리 뒤져서 먼저 띄운 IE가 있는지 체크
functionEnumWindowsProc(hwnd: HWND; varlParam: DWORD): Boolean; stdcall;
begin
// 먼저 띄운 IE가 아니라면 없다고 하고 계속 뒤짐 if hwnd<>IE_HWND then begin lParam:=NOT_EXISTS;
Result:=True;
end
// 먼저 띄운 IE가 있다면 있다고 하고 뒤지기 중지
else begin lParam:=EXISTS;
Result:=False;
end;
end;
procedureTForm1.Button1Click(Sender: TObject);
var
IE : OleVariant;
IE_Exists: DWORD;
begin
// IE를 띄운적이 있으면 ifIE_HWND<>0then begin
// 그 IE가 아직 떠있는지 검사해서 EnumWindows(@EnumWindowsProc, DWORD(@IE_Exists));
// 떠있다면 최상위로 올려줌 ifIE_Exists=EXISTS then begin
SetForegroundWindow(IE_HWND);
Exit;
end;
end;
try
IE:=CreateOleObject('Internetexplorer.Application');
// 위치, 크기 IE.Left:=0;
IE.Top :=0;
IE.Width :=500;
IE.Height:=400;
// IE 윈도우 상태
IE.Toolbar :=False;
IE.Statusbar:=False;
IE.Menubar :=False;
// 띄우기
IE.Visible:=True;
SetForegroundWindow(IE.HWND);
// 띄우는 IE의 핸들을 저장
IE_HWND:=IE.HWND;
IE.Navigate('http://www.naver.com');
finally
IE:=Unassigned;
end;
end;
usesComObj;
procedureTForm1.Button1Click(Sender: TObject);
var IE: OleVariant;
begin
try
IE:=CreateOleObject('Internetexplorer.Application');
// 위치, 크기
IE.Left:=0;
IE.Top :=0;
IE.Width :=500;
IE.Height:=400;
// IE 윈도우 상태
IE.Toolbar :=False;
IE.Statusbar:=False;
IE.Menubar :=False;
// 띄우기
IE.Visible:=True;
SetForegroundWindow(IE.HWND);
IE.Navigate('http://www.naver.com');
finally
IE:=Unassigned;
end;
end;
IE를 띄우는데 먼저 띄운 IE가 있다면 그 IE를 최상위로 올리고,
만약 먼저 띄운 IE가 꺼지고 없다면 새로 띄우려면 아래처럼 하면 됨.
uses ComObj;
const NOT_EXISTS = 0;
EXISTS =1;
var
IE_HWND: HWND;
// 윈도우를 모조리 뒤져서 먼저 띄운 IE가 있는지 체크
functionEnumWindowsProc(hwnd: HWND; varlParam: DWORD): Boolean; stdcall;
begin
// 먼저 띄운 IE가 아니라면 없다고 하고 계속 뒤짐 if hwnd<>IE_HWND then begin lParam:=NOT_EXISTS;
Result:=True;
end
// 먼저 띄운 IE가 있다면 있다고 하고 뒤지기 중지
else begin lParam:=EXISTS;
Result:=False;
end;
end;
procedureTForm1.Button1Click(Sender: TObject);
var
IE : OleVariant;
IE_Exists: DWORD;
begin
// IE를 띄운적이 있으면 ifIE_HWND<>0then begin
// 그 IE가 아직 떠있는지 검사해서 EnumWindows(@EnumWindowsProc, DWORD(@IE_Exists));
// 떠있다면 최상위로 올려줌 ifIE_Exists=EXISTS then begin
SetForegroundWindow(IE_HWND);
Exit;
end;
end;
try
IE:=CreateOleObject('Internetexplorer.Application');
// 위치, 크기 IE.Left:=0;
IE.Top :=0;
IE.Width :=500;
IE.Height:=400;
// IE 윈도우 상태
IE.Toolbar :=False;
IE.Statusbar:=False;
IE.Menubar :=False;
// 띄우기
IE.Visible:=True;
SetForegroundWindow(IE.HWND);
// 띄우는 IE의 핸들을 저장
IE_HWND:=IE.HWND;
IE.Navigate('http://www.naver.com');
finally
IE:=Unassigned;
end;
end;
바탕화면 바꾸기
정확히 말하자면 SHELLDLL_DefView에 명령 넣기.
procedure 바탕화면_바꾸기(이미지파일: String; 바둑판형식: Boolean);
const 바탕화면_복구 = 29699;
var
Reg: TRegIniFile;
바탕화면_핸들: HWND;
begin
// 레지스트리에 바탕화면에 대한 항목 세팅
Reg := TRegIniFile.Create('Control Panel');
Reg.WriteString('desktop', 'Wallpaper', 이미지파일);
if바둑판형식 thenReg.WriteString('desktop', 'TileWallpaper', '1')
else Reg.WriteString('desktop', 'TileWallpaper', '0');
// 바탕화면 변경 메세지 보냄
바탕화면_핸들:=FindWindow('ExploreWClass', nil);
if바탕화면_핸들=0then 바탕화면_핸들:=FindWindow('CabinetWClass', nil);
바탕화면_핸들:=FindWindowEx(바탕화면_핸들, 0, 'SHELLDLL_DefView', nil);
SendMessage(바탕화면_핸들, WM_COMMAND, 바탕화면_복구, 0);
end;
로컬 파일의 날짜 가져오기
function파일날짜(const포맷, 파일경로: String; 종류: String='생성'): String;
var 파일핸들: THandle;
생성, 최종접속, 최종수정, 변환: TFileTime;
Dos날짜: Integer;
begin
파일핸들:=FileOpen(파일경로, fmOpenRead orfmShareDenyNone);
GetFileTime(파일핸들, @생성, @최종접속, @최종수정);
if Trim(종류)='생성' thenFileTimeToLocalFileTime(생성, 변환)
else ifTrim(종류)='최종접속'thenFileTimeToLocalFileTime(최종접속, 변환)
else ifTrim(종류)='최종수정'thenFileTimeToLocalFileTime(최종수정, 변환);
FileTimeToDosDateTime(변환, LongRec(Dos날짜).Hi, LongRec(Dos날짜).Lo);
Result:=FormatDateTime(포맷, FileDateToDateTime(Dos날짜));
FileClose(파일핸들);
end;
var 파일핸들: THandle;
생성, 최종접속, 최종수정, 변환: TFileTime;
Dos날짜: Integer;
begin
파일핸들:=FileOpen(파일경로, fmOpenRead orfmShareDenyNone);
GetFileTime(파일핸들, @생성, @최종접속, @최종수정);
if Trim(종류)='생성' thenFileTimeToLocalFileTime(생성, 변환)
else ifTrim(종류)='최종접속'thenFileTimeToLocalFileTime(최종접속, 변환)
else ifTrim(종류)='최종수정'thenFileTimeToLocalFileTime(최종수정, 변환);
FileTimeToDosDateTime(변환, LongRec(Dos날짜).Hi, LongRec(Dos날짜).Lo);
Result:=FormatDateTime(포맷, FileDateToDateTime(Dos날짜));
FileClose(파일핸들);
end;
윈도우 메세지를 받아먹는 3가지 방법
- 보내는 통신규약은 아래와 같다고 가정.
SendMessage(FindWindow(nil, 'frmDebug'), WM_USER+123, 0, lParam(LongInt(메세지)));
혹은 PostMessage
1. TApplicationEvents 이용.
1. 폼에디터에 TApplicationEvents 를 하나 박아넣음.
2. 박아넣은 TApplicationEvents 의 OnMessage 함수를 만든다. 아래와 같은 모양으로.
procedureTForm1.ApplicationEvents1Message(varMsg: tagMSG; varHandled: Boolean);
begin
ifMsg.message=WM_USER+123then begin
Memo1.Lines.Add(PChar(Msg.lParam));
end;
end;
begin
ifMsg.message=WM_USER+123then begin
Memo1.Lines.Add(PChar(Msg.lParam));
end;
end;
3. 특징
- F1 을 눌러서 헬프를 보면 알 수 있지만, SendMessage 로 보낸 건 못받아먹음. PostMessage 로 해야 함.
2. 메세지별 이벤트 핸들러 이용.
- 각 메세지별 이벤트 핸들러를 만든다. 아래의 모양으로.
<선언부>
procedureWM_USER123(varMSG: TMessage); messageWM_USER+123;
<구현부>
procedureTForm1.WM_USER123(varMSG: TMessage);
begin
Memo1.Lines.Add(PChar(MSG.LParam));
end;
begin
Memo1.Lines.Add(PChar(MSG.LParam));
end;
3. TForm 의 WndProc 을 오버라이딩해서 사용하는 방법.
- 아래와 같은 모양으로 구성.
<선언부>
procedureWndProc(varMessage: TMessage); override;
<구현부>
procedureTForm1.WndProc(varMessage: TMessage);
begin
ifMessage.Msg=WM_USER+123then begin
Memo1.Lines.Add(PChar(Message.LParam));
end;
begin
ifMessage.Msg=WM_USER+123then begin
Memo1.Lines.Add(PChar(Message.LParam));
end;
inherited;
end;
end;
시스템 경로를 받아오는 방법
uses 에 ShlObj 추가.
functionGetSpecialPath(sPath: Integer): PAnsiChar;
var
pIDList: PItemIDList;
Path: array[0..MAX_PATH] ofChar;
begin GetMem(Result, MAX_PATH);
// pIDList에 매개변수로 받은 시스템 경로(=sPath)에 해당하는 포인터 지정
ifSHGetSpecialFolderLocation(0, sPATH, pIDList)=S_OK then begin
// pIDList에 있는 Path 경로를 FavPath 에 대입
SHGetPathFromIDList(pIDList, Path);
Result:=Path;
end;
end;
// 이런식으로 사용
procedureTForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetSpecialPath(CSIDL_FAVORITES)); // 즐겨찾기 경로 출력
end;
functionGetSpecialPath(sPath: Integer): PAnsiChar;
var
pIDList: PItemIDList;
Path: array[0..MAX_PATH] ofChar;
begin GetMem(Result, MAX_PATH);
// pIDList에 매개변수로 받은 시스템 경로(=sPath)에 해당하는 포인터 지정
ifSHGetSpecialFolderLocation(0, sPATH, pIDList)=S_OK then begin
// pIDList에 있는 Path 경로를 FavPath 에 대입
SHGetPathFromIDList(pIDList, Path);
Result:=Path;
end;
end;
// 이런식으로 사용
procedureTForm1.Button1Click(Sender: TObject);
begin
ShowMessage(GetSpecialPath(CSIDL_FAVORITES)); // 즐겨찾기 경로 출력
end;
즐겨찾기 리스트를 리스트박스로 출력하기
uses 에 ShlObj 추가.
// 즐겨찾기를 TStrings 형태로 반환functionGetIEFavorites(constfavpath: String): TStrings;
var Str: TStrings;
SearchRec: TSearchRec;
Path, Dir, FileName: String;
Buffer: array[0..2047] ofChar;
Found: Integer;
begin
Str:=TStringList.Create;
// 일단 .URL 파일을 뒤지고
Path:=FavPath+'\*.url';
Dir:=ExtractFilePath(Path);
Found:=FindFirst(Path, faAnyFile, SearchRec);
whileFound=0do begin
// Buffer 의 내용을 GetPrivateProfileString 길이만큼 FileName 으로 복사
SetString(
FileName,
Buffer,
// INI 형식의 파일에서 특정 Key 읽어오기
// 즐겨찾기 파일인 .URL도 INI 형식으로 저장되어 있음.
GetPrivateProfileString('InternetShortcut', {대분류}
PChar('URL'), {키 이름}
nil, {Default 값}
Buffer, {내용을 복사할 버퍼}
SizeOf(Buffer), {복사할 크기} PChar(Dir+SearchRec.Name)) {읽어올 파일 경로}
);
Str.Add(FileName);
Found:=FindNext(SearchRec);
end;
// 디렉토리일 경우엔 재귀 호출로 파고 들어감
Found:=FindFirst(Dir+'\*.*', faAnyFile, SearchRec);
whilefound=0do begin
if((SearchRec.Attr andfaDirectory)>0) and(SearchRec.Name[1]<>'.') then begin
Str.AddStrings(GetIEFavorites(Dir+'\'+SearchRec.Name));
end;
Found:=FindNext(SearchRec);
end;
FindClose(SearchRec);
Result:=Str;
end;
사용법은 이렇다.
이 함수로 굴리면 리스트박스에 URL만 자동으로 추가됨.
procedureTForm1.Button1Click(Sender: TObject);
var pIDList: PItemIDList;
FavPath: Array[0..MAX_PATH] ofChar;
begin
// pIDList에 CSIDL_FAVORITES(즐겨찾기폴더)에 해당하는 포인터 지정
ifSHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pIDList)=S_OK then begin
// pIDList에 있는 Path 경로를 FavPath 에 대입
ifSHGetPathFromIDList(pIDList, FavPath) then begin
//ShowMessage(FavPath);
ListBox1.Items:=GetIEFavorites(StrPas(FavPath));
end
elseShowMessage('Error: SHGetPathFromIDList');
end
elseShowMessage('Error<>S_OK');
end;
// 즐겨찾기를 TStrings 형태로 반환functionGetIEFavorites(constfavpath: String): TStrings;
var Str: TStrings;
SearchRec: TSearchRec;
Path, Dir, FileName: String;
Buffer: array[0..2047] ofChar;
Found: Integer;
begin
Str:=TStringList.Create;
// 일단 .URL 파일을 뒤지고
Path:=FavPath+'\*.url';
Dir:=ExtractFilePath(Path);
Found:=FindFirst(Path, faAnyFile, SearchRec);
whileFound=0do begin
// Buffer 의 내용을 GetPrivateProfileString 길이만큼 FileName 으로 복사
SetString(
FileName,
Buffer,
// INI 형식의 파일에서 특정 Key 읽어오기
// 즐겨찾기 파일인 .URL도 INI 형식으로 저장되어 있음.
GetPrivateProfileString('InternetShortcut', {대분류}
PChar('URL'), {키 이름}
nil, {Default 값}
Buffer, {내용을 복사할 버퍼}
SizeOf(Buffer), {복사할 크기} PChar(Dir+SearchRec.Name)) {읽어올 파일 경로}
);
Str.Add(FileName);
Found:=FindNext(SearchRec);
end;
// 디렉토리일 경우엔 재귀 호출로 파고 들어감
Found:=FindFirst(Dir+'\*.*', faAnyFile, SearchRec);
whilefound=0do begin
if((SearchRec.Attr andfaDirectory)>0) and(SearchRec.Name[1]<>'.') then begin
Str.AddStrings(GetIEFavorites(Dir+'\'+SearchRec.Name));
end;
Found:=FindNext(SearchRec);
end;
FindClose(SearchRec);
Result:=Str;
end;
사용법은 이렇다.
이 함수로 굴리면 리스트박스에 URL만 자동으로 추가됨.
procedureTForm1.Button1Click(Sender: TObject);
var pIDList: PItemIDList;
FavPath: Array[0..MAX_PATH] ofChar;
begin
// pIDList에 CSIDL_FAVORITES(즐겨찾기폴더)에 해당하는 포인터 지정
ifSHGetSpecialFolderLocation(Handle, CSIDL_FAVORITES, pIDList)=S_OK then begin
// pIDList에 있는 Path 경로를 FavPath 에 대입
ifSHGetPathFromIDList(pIDList, FavPath) then begin
//ShowMessage(FavPath);
ListBox1.Items:=GetIEFavorites(StrPas(FavPath));
end
elseShowMessage('Error: SHGetPathFromIDList');
end
elseShowMessage('Error<>S_OK');
end;
HWND로 ClassName 얻어오기
int GetClassName( HWND hWnd, LPTSTR lpClassName, int nMaxCount);
FindWindow 나 GetForegroundWindow 등으로 얻은 핸들을 이용하여 ClassName 을 얻는 법
아래는 자기자신 윈도우의 ClassName 을 얻어오는 버튼 클릭 이벤트 핸들러
procedureTForm1.Button1Click(Sender: TObject);
varcName: array[0..MAX_PATH] ofChar;
begin
ifGetClassName(GetForegroundWindow, cName, MAX_PATH)<>0then ShowMessage(cName)
else ShowMessage('Error');
end;
동적으로 COM Server 등록하기 (DLL, OCX)
DLL 등을 등록하려면 regsvr32 DLL이름 으로 등록한다. (등록해제는 regsvr32 /u DLL이름)
동적으로 등록하는 방법이 있었다.
RegisterComServer(DLL이름);
ex) 프로젝트 파일(.dpr)에서 한다.
programRegistComServer;
uses
{$R *.res}
constDLL_FILE='xx.dll';
begin
동적으로 등록하는 방법이 있었다.
RegisterComServer(DLL이름);
ex) 프로젝트 파일(.dpr)에서 한다.
programRegistComServer;
uses
Forms,
ComObj,
Main in'Main.pas'{Form1}
{$R *.res}
constDLL_FILE='xx.dll';
begin
Application.Initialize;
ifFileExists(DLL_FILE) then begin
RegisterComServer(DLL_FILE); // DLL 등록
end
else begin
Application.Terminate;
Exit;
end;
Application.Title:='RegistComServer';
Application.CreateForm(TForm1, Form1);
Application.Run;
end; DeleteFile 함수 사용시 읽기전용파일이 지워지지 않을 때
function DeleteFile(lpFileName: PAnsiChar): LongBool;
파일이 없거나 지워지지 않았을 경우 False 를 리턴함.
읽기전용파일의 경우 지워지질 않길래 3분간 고민하다가 읽기전용속성을 없애고 지우니 잘 지워짐...
BOOLSetFileAttributes(
LPCTSTRlpFileName, // 파일이름 DWORDdwFileAttributes // 적용할 속성
);
DeleteFile('C:\xxx.txt');
위의 코드를 사용해서 지워지지 않는다면,
SetFileAttributes(PChar('C:\xxx.txt'), FILE_ATTRIBUTE_NORMAL);
DeleteFile('C:\xxx.txt');
이렇게 해보자.
파일이 없거나 지워지지 않았을 경우 False 를 리턴함.
읽기전용파일의 경우 지워지질 않길래 3분간 고민하다가 읽기전용속성을 없애고 지우니 잘 지워짐...
BOOLSetFileAttributes(
LPCTSTRlpFileName, // 파일이름 DWORDdwFileAttributes // 적용할 속성
);
DeleteFile('C:\xxx.txt');
위의 코드를 사용해서 지워지지 않는다면,
SetFileAttributes(PChar('C:\xxx.txt'), FILE_ATTRIBUTE_NORMAL);
DeleteFile('C:\xxx.txt');
이렇게 해보자.
유니코드인지 판별하는 법 (텍스트 파일)
텍스트 파일은 파일시작부분의 2바이트를 읽어 유니코드인지 구분이 가능하다.
파일시작부분의 2바이트가 $FEFF나 $FFFE일 경우 유니코드 텍스트파일이다.
아래는 파일이름으로 유니코드인지 판별하는 함수
: 유니코드이면 True 아니면 False 를 반환
functionIsUnicodeTextFile(const fileName: String): Boolean;
var
Result:=False;
{1. 파일을 열어 2바이트만 읽어들인다}
fd:=FileOpen(fileName, fmOpenRead);
FileRead(fd, ByteOrderMarker, 2);
{2.파일시작부분의 2바이트가
$FEFF(Little Endian) 혹은 $FFFE(Big Endian)일 경우 유니코드 파일임}
if(ByteOrderMarker=$FEFF) or(ByteOrderMarker=$FFFE) thenResult:=True;
FileClose(fd);
end;
파일시작부분의 2바이트가 $FEFF나 $FFFE일 경우 유니코드 텍스트파일이다.
아래는 파일이름으로 유니코드인지 판별하는 함수
: 유니코드이면 True 아니면 False 를 반환
functionIsUnicodeTextFile(const fileName: String): Boolean;
var
fd: THandle;
ByteOrderMarker: Word;
begin Result:=False;
{1. 파일을 열어 2바이트만 읽어들인다}
fd:=FileOpen(fileName, fmOpenRead);
FileRead(fd, ByteOrderMarker, 2);
{2.파일시작부분의 2바이트가
$FEFF(Little Endian) 혹은 $FFFE(Big Endian)일 경우 유니코드 파일임}
if(ByteOrderMarker=$FEFF) or(ByteOrderMarker=$FFFE) thenResult:=True;
FileClose(fd);
end;
에디트박스에 셀 선택하기 (마우스로 드래그한 효과)
에디트 박스에 원하는 부분만큼 텍스트를 마우스로 드래그하듯 셀 선택하는 법
procedure edtSelect(edt: TEdit; posStart, posEnd: Integer);
begin
Edit1.Text 전부를 선택하고 싶다면
edtSelect(Edit1, 0, Length(Edit1.Text));
이렇게 하면 된다...
procedure edtSelect(edt: TEdit; posStart, posEnd: Integer);
begin
edt.SelStart:=posStart;
edt.SelLength:=posEnd;
end; Edit1.Text 전부를 선택하고 싶다면
edtSelect(Edit1, 0, Length(Edit1.Text));
이렇게 하면 된다...
유니코드 파일 쓰기
procedureSaveUnicode(constfileName: String; s: String);
var
ws: WideString;
fs: TFileStream;
ByteOrderMarker: Word;
begin
ws:=s;
fs:=TFileStream.Create(fileName, fmCreate);
try
ByteOrderMarker:=$FEFF; // 유니코드라는 뜻. 모든 유니코드 파일은 $FEFF 로 시작함.
{1. 유니코드 인식자를 일단 파일의 앞대가리에 써넣는다.}
fs.WriteBuffer(ByteOrderMarker, SizeOf(ByteOrderMarker));
{2. 나머지 스트링을 써넣는다.}
fs.WriteBuffer(ws[1], Length(ws)*SizeOf(ws[1]));
finally
FreeAndNil(fs);
end;
end;
MS Excel 문서 읽기
uses Windows, SysUtils, Forms, Variants, ComObj, OleServer;
...
...
...
functionGetExcelText(fName: String): String;
var
Excel: OleVariant;
i, j: Integer;
tmpString: String;
begin
Result:='';
// 엑셀 어플리케이션 생성
try
Excel:=CreateOleObject('Excel.application');
except MessageBox(0,'Excel이 설치되어 있지 않습니다.','',MB_OK);
Exit;
end;
// 파일이 있는지 확인
if notFileExists(fName)then begin
MessageBox(0,'파일이 없습니다','',MB_OK);
Exit;
end;
// WorkBooks Open
Excel.Workbooks.Open(fName);
// Cell 의 내용을 받아옴
fori:=1 toExcel.ActiveSheet.UsedRange.Rows.Count do begin forj:=1toExcel.ActiveSheet.UsedRange.Columns.Countdo begin
tmpString:=Excel.Cells[i, j];
ifLength(Trim(tmpString))>0thenResult:=Result+#13#10+tmpString;
Application.ProcessMessages;
end;
end;
// 해제과정
Excel.Workbooks.Close;
Excel.Quit;
Excel:=Unassigned;
end;
...
...
...
functionGetExcelText(fName: String): String;
var
Excel: OleVariant;
i, j: Integer;
tmpString: String;
begin
Result:='';
// 엑셀 어플리케이션 생성
try
Excel:=CreateOleObject('Excel.application');
except MessageBox(0,'Excel이 설치되어 있지 않습니다.','',MB_OK);
Exit;
end;
// 파일이 있는지 확인
if notFileExists(fName)then begin
MessageBox(0,'파일이 없습니다','',MB_OK);
Exit;
end;
// WorkBooks Open
Excel.Workbooks.Open(fName);
// Cell 의 내용을 받아옴
fori:=1 toExcel.ActiveSheet.UsedRange.Rows.Count do begin forj:=1toExcel.ActiveSheet.UsedRange.Columns.Countdo begin
tmpString:=Excel.Cells[i, j];
ifLength(Trim(tmpString))>0thenResult:=Result+#13#10+tmpString;
Application.ProcessMessages;
end;
end;
// 해제과정
Excel.Workbooks.Close;
Excel.Quit;
Excel:=Unassigned;
end;
MAC Address 확인
// 읽고 쓰기 파이프 핸들type
TPipeHandles=record
hRead, hWrite: DWORD;
end;
// 실행한 도스 명령어의 결과값을 반환
functionGetDosOutput(cmd:String): String;
constBUFFER_SIZE=4096;
// 넘겨받은 핸들을 닫아줌 ____________________________________________________
procedureClosePipe(var Pipe: TPipeHandles);
begin
withPipe do begin
ifhRead<>0thenCloseHandle(hRead);
ifhWrite<>0thenCloseHandle(hWrite);
hRead:=0;
hWrite:=0;
end;
end;
// 파이프에서 읽어온 정보를 Result 에 저장 ___________________________________ procedureReadPipe(varPipe: TPipeHandles);
var
ReadBuf: array[0..BUFFER_SIZE] ofChar;
BytesRead: DWORD;
begin
// 파이프에 읽을 데이터가 있는지 검사
ifPeekNamedPipe(pipe.hRead, nil, 0, nil, @BytesRead, nil) and(BytesRead>0)
then begin
ReadFile(pipe.hRead, ReadBuf, BytesRead, BytesRead, nil);
if BytesRead>0then begin
ReadBuf[BytesRead]:=#0;
Result:=ReadBuf;
end;
end;
end;
// ___________________________________________________________________________
var
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
SecAttr: TSecurityAttributes;
PipeStdOut: TPipeHandles;
PipeStdErr: TPipeHandles;
dwExitCode: DWORD;
begin
SecAttr.nLength:=SizeOf(SecAttr);
SecAttr.lpSecurityDescriptor:=nil;
SecAttr.bInheritHandle:=True;
// STDOUT 파이프 생성
withPipeStdOutdo // 표준 출력(stdout) 파이프
if notCreatePipe(hRead, hWrite, @SecAttr, BUFFER_SIZE) then ShowMessage('STDOUT pipe 를 만들 수 없습니다.');
try
// STDERR 파이프 생성
withPipeStdErr do// 표준 에러(stderr) 파이프
if notCreatePipe(hRead, hWrite, @SecAttr, BUFFER_SIZE) thenShowMessage('STDERR pipe 를 만들 수 없습니다.');
except
ClosePipe(PipeStdOut);
raise;
Exit;
end;
try
FillChar(StartupInfo, SizeOf(StartupInfo),0);
withStartupInfo do begin
cb:=SizeOf(StartupInfo);
dwFlags:=STARTF_USESHOWWINDOW orSTARTF_USESTDHANDLES;
// 표준출력 and 표준에러 스트림에 생성한 파이프를 연결
hStdOutput:=PipeStdOut.hWrite;
hStdError:=PipeStdErr.hWrite;
wShowWindow:=SW_HIDE;
end;
// 도스 명령어 실행
ifCreateProcess(
nil, PChar(Cmd), @SecAttr, @SecAttr, True,
DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,
nil, nil,
StartupInfo, ProcessInfo
)
then begin
dwExitCode:=STILL_ACTIVE;
Screen.Cursor:=crHourglass;
try
repeat
// 실행완료까지 기다림
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, dwExitCode);
Application.ProcessMessages;
// 실행완료후 결과값을 파이프에서 읽어옴
ReadPipe(PipeStdOut);
ReadPipe(PipeStdErr);
untildwExitCode<>STILL_ACTIVE; // 아직 실행중이면 반복
if notGetExitCodeProcess(ProcessInfo.hProcess, dwExitCode) thenShowMessage('Exit Code 를 읽어올 수 없습니다.');
ifdwExitCode<>0then// 정상종료가 아니면 raiseException.Create('Exit Code '+IntToStr(dwExitCode));
finally Screen.Cursor:=crDefault;
if dwExitCode=STILL_ACTIVE thenTerminateProcess(ProcessInfo.hProcess,1);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
ProcessInfo.hProcess:=0;
end;
end
else ShowMessage(Cmd+' 명령어 실행을 위한 프로세스 생성 실패');
finally
ClosePipe(PipeStdOut);
ClosePipe(PipeStdErr);
end;
end;
procedureTForm1.Button1Click(Sender: TObject);
var s: String;
sList, tList: TStringList;
i: Integer;
begin sList:=TStringList.Create;
tList:=TStringList.Create;
try
s:=GetDosOutput('ipconfig /all');
ExtractStrings([#13],[],PChar(s),sList);
Memo1.Clear;
fori:=0tosList.Count - 1do begin
// 맥어드레스는 Physical Address 라는 항목에 있음
if Pos('Physical Address', sList[i])>0then begin
tList.Clear;
// ':' 로 나눈 뒤에 것이 MAC Address
ExtractStrings([':'], [], PChar(sList[i]), tList);
Memo1.Lines.Add(Trim(tList[1]));
end;
end;
finally
FreeAndNil(tList);
FreeAndNil(sList);
end;
end;
TPipeHandles=record
hRead, hWrite: DWORD;
end;
// 실행한 도스 명령어의 결과값을 반환
functionGetDosOutput(cmd:String): String;
constBUFFER_SIZE=4096;
// 넘겨받은 핸들을 닫아줌 ____________________________________________________
procedureClosePipe(var Pipe: TPipeHandles);
begin
withPipe do begin
ifhRead<>0thenCloseHandle(hRead);
ifhWrite<>0thenCloseHandle(hWrite);
hRead:=0;
hWrite:=0;
end;
end;
// 파이프에서 읽어온 정보를 Result 에 저장 ___________________________________ procedureReadPipe(varPipe: TPipeHandles);
var
ReadBuf: array[0..BUFFER_SIZE] ofChar;
BytesRead: DWORD;
begin
// 파이프에 읽을 데이터가 있는지 검사
ifPeekNamedPipe(pipe.hRead, nil, 0, nil, @BytesRead, nil) and(BytesRead>0)
then begin
ReadFile(pipe.hRead, ReadBuf, BytesRead, BytesRead, nil);
if BytesRead>0then begin
ReadBuf[BytesRead]:=#0;
Result:=ReadBuf;
end;
end;
end;
// ___________________________________________________________________________
var
ProcessInfo: TProcessInformation;
StartupInfo: TStartupInfo;
SecAttr: TSecurityAttributes;
PipeStdOut: TPipeHandles;
PipeStdErr: TPipeHandles;
dwExitCode: DWORD;
begin
SecAttr.nLength:=SizeOf(SecAttr);
SecAttr.lpSecurityDescriptor:=nil;
SecAttr.bInheritHandle:=True;
// STDOUT 파이프 생성
withPipeStdOutdo // 표준 출력(stdout) 파이프
if notCreatePipe(hRead, hWrite, @SecAttr, BUFFER_SIZE) then ShowMessage('STDOUT pipe 를 만들 수 없습니다.');
try
// STDERR 파이프 생성
withPipeStdErr do// 표준 에러(stderr) 파이프
if notCreatePipe(hRead, hWrite, @SecAttr, BUFFER_SIZE) thenShowMessage('STDERR pipe 를 만들 수 없습니다.');
except
ClosePipe(PipeStdOut);
raise;
Exit;
end;
try
FillChar(StartupInfo, SizeOf(StartupInfo),0);
withStartupInfo do begin
cb:=SizeOf(StartupInfo);
dwFlags:=STARTF_USESHOWWINDOW orSTARTF_USESTDHANDLES;
// 표준출력 and 표준에러 스트림에 생성한 파이프를 연결
hStdOutput:=PipeStdOut.hWrite;
hStdError:=PipeStdErr.hWrite;
wShowWindow:=SW_HIDE;
end;
// 도스 명령어 실행
ifCreateProcess(
nil, PChar(Cmd), @SecAttr, @SecAttr, True,
DETACHED_PROCESS or NORMAL_PRIORITY_CLASS,
nil, nil,
StartupInfo, ProcessInfo
)
then begin
dwExitCode:=STILL_ACTIVE;
Screen.Cursor:=crHourglass;
try
repeat
// 실행완료까지 기다림
WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, dwExitCode);
Application.ProcessMessages;
// 실행완료후 결과값을 파이프에서 읽어옴
ReadPipe(PipeStdOut);
ReadPipe(PipeStdErr);
untildwExitCode<>STILL_ACTIVE; // 아직 실행중이면 반복
if notGetExitCodeProcess(ProcessInfo.hProcess, dwExitCode) thenShowMessage('Exit Code 를 읽어올 수 없습니다.');
ifdwExitCode<>0then// 정상종료가 아니면 raiseException.Create('Exit Code '+IntToStr(dwExitCode));
finally Screen.Cursor:=crDefault;
if dwExitCode=STILL_ACTIVE thenTerminateProcess(ProcessInfo.hProcess,1);
CloseHandle(ProcessInfo.hProcess);
CloseHandle(ProcessInfo.hThread);
ProcessInfo.hProcess:=0;
end;
end
else ShowMessage(Cmd+' 명령어 실행을 위한 프로세스 생성 실패');
finally
ClosePipe(PipeStdOut);
ClosePipe(PipeStdErr);
end;
end;
procedureTForm1.Button1Click(Sender: TObject);
var s: String;
sList, tList: TStringList;
i: Integer;
begin sList:=TStringList.Create;
tList:=TStringList.Create;
try
s:=GetDosOutput('ipconfig /all');
ExtractStrings([#13],[],PChar(s),sList);
Memo1.Clear;
fori:=0tosList.Count - 1do begin
// 맥어드레스는 Physical Address 라는 항목에 있음
if Pos('Physical Address', sList[i])>0then begin
tList.Clear;
// ':' 로 나눈 뒤에 것이 MAC Address
ExtractStrings([':'], [], PChar(sList[i]), tList);
Memo1.Lines.Add(Trim(tList[1]));
end;
end;
finally
FreeAndNil(tList);
FreeAndNil(sList);
end;
end;
텍스트 파일읽기 비교
목적 : 파일을 읽어들여 라인별로 StringList 에 저장하는 것
1. FileStream : 빠르다. 라인수도 줄일 수 있다. (사실 Readln 빼고는 거의 동일한 수준)
procedureTest_FileStream;
var
FileStream: TFileStream;
sList: TStringList;
begin sList:=TStringList.Create;
FileStream:=TFileStream.Create(FILE_NAME, fmShareDenyNone);
try
sList.LoadFromStream(FileStream);
finally
FreeAndNil(FileStream);
FreeAndNil(sList);
end;
end;
2. Readln : 두배 이상 느리다. 라인수도 늘어난다. 왜 쓰는지 의문이다...
procedureTest_Readln;
var
Line: String;
sList: TStringList;
f: TextFile;
begin sList:=TStringList.Create;
try
AssignFile(f, FILE_NAME);
Reset(f);
while notEOF(f) do begin
Readln(f, Line);
sList.Add(Line)
end;
finally
CloseFile(f);
FreeAndNil(sList);
end;
end;
3. StringList.LoadFromFile : 가장 빠른편. (어차피 내부적으로 Stream 을 이용) 라인수가 가장 작다.
procedureTest_LoadFromFile;
var
sList: TStringList;
begin
sList:=TStringList.Create;
try sList.LoadFromFile(FILE_NAME);
finally
FreeAndNil(sList);
end;
end;
4. API : 속도는 별반 차이 없음. CreateFile, ReadFile 이용한다는 점이 특이사항.
procedureTest_API;
var
sList: TStringList;
hFile: THandle;
FileSize, ReadSize: Cardinal;
Buffer: String;
begin
sList:=TStringList.Create;
try
hFile:=CreateFile(PChar(FILE_NAME), GENERIC_READ,
FILE_SHARE_READ orFILE_SHARE_WRITEorFILE_SHARE_DELETE,
nil, OPEN_EXISTING, 0, 0);
FileSize:=GetFileSize(hFile,nil);
SetLength(Buffer, FileSize);
ifReadFile(hFile, Buffer[1], FileSize, ReadSize, nil) thensList.Text:=Buffer;
finally
CloseHandle(hfile);
FreeAndNil(sList);
end;
end;
5. BlockRead : 역시 속도는 그다지 차이 없음. BlockRead 함수를 사용한다는 게 특이점.
procedureTest_BlockRead;
var
sList: TStringList;
f: File;
FileSize, ReadSize: Cardinal;
SearchRec: TSearchRec;
Buffer: String;
begin
sList:=TStringList.Create;
try FileSize:=0;
ifFindFirst(FILE_NAME, faAnyFile, SearchRec)=0 then begin
FileSize:=SearchRec.Size;
FindClose(SearchRec);
end;
AssignFile(f, FILE_NAME);
SetLength(Buffer, FileSize);
Reset(f, 1);
BlockRead(f, PChar(Buffer)^, FileSize, ReadSize);
sList.Text:=Buffer;
finally
CloseFile(f);
FreeAndNil(sList);
end;
end;
1. FileStream : 빠르다. 라인수도 줄일 수 있다. (사실 Readln 빼고는 거의 동일한 수준)
procedureTest_FileStream;
var
FileStream: TFileStream;
sList: TStringList;
begin sList:=TStringList.Create;
FileStream:=TFileStream.Create(FILE_NAME, fmShareDenyNone);
try
sList.LoadFromStream(FileStream);
finally
FreeAndNil(FileStream);
FreeAndNil(sList);
end;
end;
2. Readln : 두배 이상 느리다. 라인수도 늘어난다. 왜 쓰는지 의문이다...
procedureTest_Readln;
var
Line: String;
sList: TStringList;
f: TextFile;
begin sList:=TStringList.Create;
try
AssignFile(f, FILE_NAME);
Reset(f);
while notEOF(f) do begin
Readln(f, Line);
sList.Add(Line)
end;
finally
CloseFile(f);
FreeAndNil(sList);
end;
end;
3. StringList.LoadFromFile : 가장 빠른편. (어차피 내부적으로 Stream 을 이용) 라인수가 가장 작다.
procedureTest_LoadFromFile;
var
sList: TStringList;
begin
sList:=TStringList.Create;
try sList.LoadFromFile(FILE_NAME);
finally
FreeAndNil(sList);
end;
end;
4. API : 속도는 별반 차이 없음. CreateFile, ReadFile 이용한다는 점이 특이사항.
procedureTest_API;
var
sList: TStringList;
hFile: THandle;
FileSize, ReadSize: Cardinal;
Buffer: String;
begin
sList:=TStringList.Create;
try
hFile:=CreateFile(PChar(FILE_NAME), GENERIC_READ,
FILE_SHARE_READ orFILE_SHARE_WRITEorFILE_SHARE_DELETE,
nil, OPEN_EXISTING, 0, 0);
FileSize:=GetFileSize(hFile,nil);
SetLength(Buffer, FileSize);
ifReadFile(hFile, Buffer[1], FileSize, ReadSize, nil) thensList.Text:=Buffer;
finally
CloseHandle(hfile);
FreeAndNil(sList);
end;
end;
5. BlockRead : 역시 속도는 그다지 차이 없음. BlockRead 함수를 사용한다는 게 특이점.
procedureTest_BlockRead;
var
sList: TStringList;
f: File;
FileSize, ReadSize: Cardinal;
SearchRec: TSearchRec;
Buffer: String;
begin
sList:=TStringList.Create;
try FileSize:=0;
ifFindFirst(FILE_NAME, faAnyFile, SearchRec)=0 then begin
FileSize:=SearchRec.Size;
FindClose(SearchRec);
end;
AssignFile(f, FILE_NAME);
SetLength(Buffer, FileSize);
Reset(f, 1);
BlockRead(f, PChar(Buffer)^, FileSize, ReadSize);
sList.Text:=Buffer;
finally
CloseFile(f);
FreeAndNil(sList);
end;
end;
피드 구독하기:
글 (Atom)