델파이 유용한 함수정리 3탄

델파이 유용한 함수정리 3탄

 

 

초를 시분초로 분할

function ssTohhnnss(value: double): string;

  var r, r1,r2: double;

begin

  r:= Value;

  r1:= Trunc(r / 60); //분

  r2:= Trunc(r1 / 60); //시

  r:= r - (r1 * 60);

  r1:= r1 - (r2 * 60);

  result:= FloatToStr(r2) + '시 ' + FloatToStr(r1) + '분 ' + FloatToStr(r) + '초';

end;

 

초값으로 정지하기 TTime없이

선언부

procedure Sleep(SleepSecs : Integer);

코딩부

procedure TForm1.Sleep(SleepSecs : Integer);

var

  StartValue : LongInt;

begin

  StartValue := GetTickCount;

  while ((GetTickCount - StartValue) <= (SleepSecs * 1000)) do

  Application.ProcessMessages;

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

  Sleep(10);

end;

 

다른방법(선언 없음)

procedure TForm1.Button1Click(Sender: TObject);

begin

  WaitForSingleObject(Handle,10);

end;

작업시 남은시간을 계산하는 함수

var gfdate: double;

 

procedure f_ListTimeStart;

  var hh,mm,ss,ms: word;

begin

  decodeTime(now,hh,mm,ss,ms);

  gfdate:= (hh * 3600) + (mm * 60) + ss + ms / 1000;

end;

 

function f_ListTime(iMax,iPos: Integer): string;

  var hh,mm,ss,ms: word;

  f: double;

  iValue: Int64;

begin

  decodeTime(now,hh,mm,ss,ms);

  f:= (hh * 3600) + (mm * 60) + ss + ms / 1000;

  f:= f - gfdate;

  f:= f / iPos * iMax - f;

  iValue:= StrToInt64(FormatFloat('0',f));

  sMsg := IntToStr(iValue div 3600) + '시 '

            + IntToStr(iValue mod 3600 div 60) + '분 '

            + IntToStr(iValue mod 60) + '초';

  result:= sMsg;

end;

 

두년도의 차를 00년00월00일형식으로 계산하는 함수

//아래를보면좀복잡하지만

//예외적인숫자처리를위해서입니다.

//전에올린오라클함수는좀에러가있습니다.

//조만간에수정해서올리겠습니다.

//그리고이함수는퇴직정산에서입사일과퇴사일을주고

//00년00월00일근무했나하는것을계산하기위해서만들었습니다.

 

procedureYYMMDDCount(date1,date2:TDate;varyy,mm,dd:word);

  var d1,d2,m1,m2:word;

begin

  yy:=0;

  mm:=0;

  dd:=0;

  d1:=0;

  Date2:=IncDay(Date2);

  yy:=YearsBetween(Date1,Date2);

  Date1:=IncYear(Date1,yy);

  m1:=DaysInMonth(Date1);

  m2:=DaysInMonth(Date2-1);

  d2:=DayOf(Date2-1);

  Date2:=date2-d2;

 

  if DayOf(Date1)>1 then

  begin

    d1:=m1-DayOf(Date1)+1;

    Date1:=Date1+d1;

  end;

 

  if Date1 < Date2 then

  begin

    while Date1+DaysInMonth(Date1) < Date2 + 1 do

    begin

      Inc(mm);

      Date1:=Date1+DaysInMonth(Date1)

    end;

  end;

 

  if d1=m1 then

  begin

    Inc(mm);

    d1:=0;

  end;

 

  if d2=m2 then

  begin

    Inc(mm);

    d2:=0;

  end;

 

  d1:=d1+d2;

 

  if d1>=m1 then

  begin

    d1:=d1-m1;

    Inc(mm);

  end;

 

  if Date1>Date2 then

    Inc(mm,-1);

    dd:=d1;

    yy:=yy+mm div 12;

    mm:=mm mod 12;

  end;

 

Bitmap그림을 흑백으로 그리기

procedure TForm1.Button1Click(Sender: TObject);

  var x,y: integer;

  c: TColor;

  gray: Byte;

begin

  for y:= 0 to Image1.Picture.Height do

  begin

    for x:= 0 to Image1.Picture.Width do

    begin

      c:= Image1.Picture.Bitmap.Canvas.Pixels[x,y];

      gray:= (Byte(c) + Byte(c shr 8) + Byte(c shr 16)) div 3;

      Image1.Picture.Bitmap.Canvas.Pixels[x,y]:= RGB(gray,gray,gray);

    end;

    Application.ProcessMessages;

  end;

end;

 

Bitmap그림을 흑백으로 그리기 - Pointer사용(위 방법보다 빠름)

선언

procedure GrayBITMAP(Bitmap: TBitmap);

  const

    BPP = 4;

    DefaultPixelFormat=pf32bit;

var

  P1: Pointer;

  W1, H1, DataSize1, LineSize1: Integer;

  x, y: Integer;

  SrcP: PDWORD;

  SrcR, SrcG, SrcB: Byte;

begin

  with Bitmap do

  begin

    PixelFormat:=DefaultPixelFormat;

    W1:=Width;

    H1:=Height;

    LineSize1:=DWORD(ScanLine[0])-DWORD(ScanLine[1]);

    DataSize1:=LineSize1*H1;

    P1:=ScanLine[H1-1];

  end;

 

  for x:=0 to W1 - 1 do

    for y:=0 to H1 - 1 do

    begin

      SrcP:=Pointer(DWORD(P1)+ y * LineSize1 + x * BPP);

      SrcR:= (SrcP^ and $0000FF);

      SrcG:= (SrcP^ and $00FF00) shr 8;

      SrcB:= (SrcP^ and $FF0000) shr 16;

      SrcR:= (SrcR + SrcG + SrcB) div 3;

      SrcP^:=(SrcR shl 16) or (SrcR shl 8) or SrcR;

    end;

end;

사용

procedure TForm1.Button1Click(Sender: TObject);

begin

  GrayBITMAP(Image1.Picture.Bitmap);

end;

 

Bitmap 파일을 MetaFile파일로 변환

function BitmapToMetaFile(Bitmap: TBitmap) : TMetaFile;

  var mc: TMetaFileCanvas;

begin

  result:= TMetaFile.Create;

  result.Height := Bitmap.Height;

  result.Width := Bitmap.Width;

  result.Enhanced := True;

  mc := TMetaFileCanvas.Create(result, 0); // BMP를 EMF의 canvas에 그리기(복사)

  mc.Draw(0, 0, Bitmap);

  mc.Free;

end;

 

procedure TForm1.Button2Click(Sender: TObject);

begin

BitmapToMetaFile(Image1.Picture.Bitmap).SaveToFile('c:\test1.emf');

end;

 

bitmap을 jpeg로 변환

var

  Jpeg1: TJpegImage;

  Image1: TImage;

begin

  Image1:= TImage.Create;

  Jpeg1 := TJpegImage.Create;

 

  // Bitmap을 file에서 불러오기

  Image1.LoadFromFile('TestImage.BMP');

 

  // Assign the BitMap to JPEG

  Jpeg1.Assign(Image1.Picture.Bitmap);

 

  // JPEG파일로 저장

  Jpeg1.SaveToFile('TestJPEG.JPG');

end;

 

Bitmap을 Icon으로 바꾸려면...

먼저 두개의 Bitmap을 생성해야 하는데...

Mask Bitmap(AND Bitmap이라 부른다.)과

Image Bitmap(XOR Bitmap이라 부른다.)

이렇게 두개의 Bitmap을 생성한 후...

Windows API 함수인 CreateIconIndirect()를 사용하여 바꿀 수 있다.

예)

procedure TForm1.Button1Click(Sender: TObject);

var

  IconSizeX : integer;

  IconSizeY : integer;

  AndMask : TBitmap;

  XOrMask : TBitmap;

  IconInfo : TIconInfo;

  Icon : TIcon;

begin

  IconSizeX := GetSystemMetrics(SM_CXICON);

  IconSizeY := GetSystemMetrics(SM_CYICON);

 

  AndMask := TBitmap.Create;

  AndMask.Monochrome := true;

  AndMask.Width := IconSizeX;

  AndMask.Height := IconSizeY;

  AndMask.Canvas.Brush.Color := clWhite;

  AndMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));

  AndMask.Canvas.Brush.Color := clBlack;

  AndMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

 

  Form1.Canvas.Draw(IconSizeX * 2, IconSizeY, AndMask);

 

  XOrMask := TBitmap.Create;

  XOrMask.Width := IconSizeX;

  XOrMask.Height := IconSizeY;

  XOrMask.Canvas.Brush.Color := ClBlack;

  XOrMask.Canvas.FillRect(Rect(0, 0, IconSizeX, IconSizeY));

  XOrMask.Canvas.Pen.Color := clRed;

  XOrMask.Canvas.Brush.Color := clRed;

  XOrMask.Canvas.Ellipse(4, 4, IconSizeX - 4, IconSizeY - 4);

 

  Form1.Canvas.Draw(IconSizeX * 4, IconSizeY, XOrMask);

 

  Icon := TIcon.Create;

  IconInfo.fIcon := true;

  IconInfo.xHotspot := 0;

  IconInfo.yHotspot := 0;

  IconInfo.hbmMask := AndMask.Handle;

  IconInfo.hbmColor := XOrMask.Handle;

  Icon.Handle := CreateIconIndirect(IconInfo);

 

  AndMask.Free;

  XOrMask.Free;

 

  Form1.Canvas.Draw(IconSizeX * 6, IconSizeY, Icon);

  Application.Icon := Icon;

  InvalidateRect(Application.Handle, nil, true);

  Icon.Free;

end;

 

Canvas의 색상수

그래픽 프로그램을 작성할 때 Canvas의 색상수를 알고자 할 때가 있습니다

이때 사용하는 함수가 GetDeviceCaps() 입니다

 

TotalNumBitsPerPixel :=

GetDeviceCaps(Canvas.Handle, BITSPIXEL) *

GetDeviceCaps(Canvas.Handle, PLANES);

 

Return values of:

1 = 2 colors (monochrome)

4 = 16 colors

8 = 256 colors

15 = 32,768 colors

16 = 65,536 colors

24 = 16,777,216 colors

 

bitmap(그림)의 각종 정보 얻기

var

  Info: PBitmapInfo;

  InfoSize: Integer;

  ImageSize: Longint;

  Image: Pointer;

begin

// 아래 예제는 Image1.Picture.Bitmap의 높이와 폭을 구하는 예제입니다

// 더 많은 정보를 원하시면 원도우즈 API 도움말에서 BITMAPINFOHEADER 로

// 검색해 보시면 아래와 같은 구조체의 정보가 있습니다

// typedef struct tagBITMAPINFOHEADER{

// DWORD biSize;

// LONG biWidth;

// LONG biHeight;

// WORD biPlanes;

// WORD biBitCount

// DWORD biCompression;

// DWORD biSizeImage;

// LONG biXPelsPerMeter;

// LONG biYPelsPerMeter;

// DWORD biClrUsed;

// DWORD biClrImportant;

// } BITMAPINFOHEADER;

​

  GetDIBSizes(Image1.Picture.Bitmap.Handle, InfoSize, ImageSize);

  GetMem(Info, InfoSize);

  try

    GetMem(Image, ImageSize);

    try

      GetDIB(Image1.Picture.Bitmap.Handle, Image1.Picture.Bitmap.Palette, Info^, Image^);

      ShowMessage(Info^.bmiHeader.biWidth);

      ShowMessage(Info^.bmiHeader.biHeight);

    finally

      FreeMem(Image, ImageSize);

    end;

  finally

    FreeMem(Info, InfoSize);

  end;

end;

 

JPG 이미지파일에 주석 읽고/쓰기

{ This function reads the JPEG comment from the file }

function ReadComment(sFileName: string): string;

var

  btL1, btL2, btS1, btS2,

  btX : Byte;

  fByte : file of Byte;

  sComment, sTempComment: string;

  lI : Longint;

begin

  sTempComment := '';

  sComment := ''; 

  AssignFile(fByte, sFileName);

  FileMode := 0;

  Reset(fByte);

  Read(fByte, btS1);

  Read(fByte, btS1);

 

  repeat

    repeat 

      Read(fByte, btS1);

    until btS1 = $FF;

      Read(fByte, btS2);

      Read(fByte, btL1);

      Read(fByte, btL2);

      sTempComment := '';

      for lI := 1 to (256 * btL1 + btL2) - 2 do

        if not Eof(fByte) then begin

          Read(fByte, btX);

      sTempComment := sTempComment + Chr(btX);

    end;

 

    if btS2 = $FE then

    sComment := sTempComment;

  until Eof(fByte) or (btS2 = $DA);

    CloseFile(fByte);

    Result := sComment;

  end;

 

{ These functions write the JPEG comment to the file }

procedure WriteCommentTo(sFileName, sComment: string);

var

  bNotYet : Boolean;

  btA,

  btS1, btS2, btX : Byte

  fByteIn, fByteOut: file of Byte;

  fFileIn, fFileOut: file;

  p,pp : file;

  i,ii,ss : longint;

  s,r : string;

  buf : array[1..1000000] of byte;

begin

  r := '';

  s := '';

  bNotYet := True;

  AssignFile(fByteIn, fname);

  AssignFile(fByteOut, sFileName);

  Reset(fByteIn);

  Rewrite(fByteOut);

  for btS1 := 1 to 2 do begin

    Read(fByteIn, btA);

    Write(fByteOut, btA);

  end;

repeat

repeat

Read(fByteIn, btS1);

until btS1 = $FF;

Read(fByteIn, btS2);

Read(fByteIn, btL1);

Read(fByteIn, btL2);

s := '';

for i := 1 to (256 * btL1 + bTL2) - 2 do

if not Eof(fByteIn) then begin

Read(fByteIn, btX)l

s := s + Chr(btX);

end;

if ((btS2 and $F0) = $C0) and bNotYet and (sComment <> '') then begin

Write(fByteOut, $FFFE);

Write(fByteOut, (Length(sComment) + 2) div 256);

Write(fByteOut, (Length(sComment) + 2) mod 256);

for i := 1 to Length(sComment) do

Write(fByteOut, Ord(sComment[i]));

bNotYet := False;

end;

if s2 <> $FE then begin

Write(fByteOut, s1, s2, l1, l2);

for i := 1 to Length(s) do

Write(fByteOut, Ord(s[i]));

end;

until Eof(fByteIn) or (s2 = $DA);

i := FilePos(fByteIn);

ii := FilePos(fByteOut);

ss := FileSize(fByteIn);

CloseFile(fByteIn);

CloseFile(fByteOut);

 

AssignFile(fFileIn, fname);

AssignFile(fFileOut, nameoffile);

Reset(fFileIn, 1);

FileMode := 2;

Reset(fFileOut, 1);

Seek(fFileIn, i);

Seek(fFileOut, ii);

BlockRead(fFileIn, Buf, ss-i);

BlockWrite(fFileOut, Buf, ss-i);

CloseFile(fFileIn);

CloseFile(fFileOut);

end;

 

procedure WriteComment(sFileName, sComment: string);

var

sTempFile: string;

begin

(* To create a temporary file name it's best to use the

* CreateUniqueFileName() function from tip 4.7

*)

sTempFile := CreateUniqueFileName('C:\');

WriteCommentTo(sTempFile, sComment);

DeleteFile(sTempFile);

RenameFile(sTempFile, sFileName);

end;

 

 

ComboBox가 Drop-Down될때 Width 자동조정

procedure TForm1.AdjustDropDownWidth;

var i, ItemWidth: Integer;

begin

ItemWidth := 0;

// 최대 pixel수를 구한다

for i := 0 to ComboBox1.Items.Count - 1 do

if Canvas.TextWidth(ComboBox1.Items[i]) > ItemWidth then

ItemWidth := Canvas.TextWidth(ComboBox1.Items[i]) + 8;

// TComboBox 의 drop-down list 의 width를 변경하는 것은 단지

// pixel를 파라미터로 하여 CB_SETDROPPEDWIDTH 메시지를

// TComboBox 보내면 된다

SendMessage(ComboBox1.Handle,CB_SETDROPPEDWIDTH,ItemWidth, 0);

end;

 

Combobox에서 focus 가 올때 자동으로 펼쳐 내리기

procedure TForm1.ComboBox1Enter(Sender: TObject);

begin

  SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(True), 0);

end;

 

procedure TForm1.ComboBox1Exit(Sender: TObject);

begin

  SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(False), 0);

end;

 

Combobox에 color 넣기

procedure TForm1.FormCreate(Sender: TObject);

begin

  with ComboBox1.Items do

begin

// 색상값을 문자로 바꾸어서 item으로 추가한다

// 추가된 값은 아래 OnDrawItem에서 color값으로만 쓰이고 화면에는

// 나타나지 않는다

Add(IntToStr(clRed));

Add(IntToStr(clFuchsia));

Add(IntToStr(clBlue));

Add(IntToStr(clGreen));

Add(IntToStr(clYellow));

end;

end;

 

procedure TForm1.ComboBox1DrawItem(Control: TWinControl; Index: Integer;

Rect: TRect; State: TOwnerDrawState);

begin

with Control as TComboBox,Canvas do

begin

Brush.Color := clWhite;

FillRect(Rect);

InflateRect(Rect,-2,-2);

Brush.Color := StrToInt(Items[Index]); // item의 값을 color로 사용

FillRect(Rect);

end;

end;

 

Combobox 를 강제로 드롭시키기

// ComboBox에 Enter시 drop시킴

procedure TForm1.ComboBox1Enter(Sender: TObject);

begin

SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(True), 0);

end;

 

// ComboBox에서 Exit시 닫음

procedure TForm1.ComboBox1Exit(Sender: TObject);

begin

SendMessage(ComboBox1.handle, CB_SHOWDROPDOWN, Integer(False), 0);

end;

 

WebBrowser에 글추가

procedure WebString(Web: TWebBrowser; msg : string);

var tmp : string;

begin

tmp := Web.OleObject.Document.Body.innerHTML;

tmp := tmp + msg;

Web.OleObject.Document.Body.innerHTML := tmp;

Web.OleObject.Document.Body.Doscroll('PageDown');

end;

웹브라우져 컨트롤을 이용할때, enter key와 ctrl+c/x 동작 하도록 하기

IOleInPlaceActiveObject로 검색을 해보니 비슷한 문서들이 많이 있긴 하던데,

대부분 enter key에 대한 언급 뿐이더군요.

그래서 ctrl+c/ctrl+x에 대해서도 처리하도록 조금 수정 해 봤습니다.

참고하세요..

 

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

uses

ActiveX, ClipBrd;

 

var

Form1: TForm1;

FOleInPlaceActiveObject: IOleInPlaceActiveObject;

SaveMessageHandler: TMessageEvent;

 

procedure TForm1.FormActivate(Sender: TObject);

begin

SaveMessageHandler := Application.OnMessage;

Application.OnMessage := MyMessageHandler;

end;

 

procedure TForm1.FormDeactivate(Sender: TObject);

begin

Application.OnMessage := SaveMessageHandler;

end;

 

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

begin

Application.OnMessage := SaveMessageHandler;

FOleInPlaceActiveObject := nil;

end;

 

procedure TForm1.MyMessageHandler(var Msg: TMsg; var Handled: Boolean);

const

DialogKeys: set of Byte = [VK_LEFT, VK_RIGHT, VK_BACK, VK_UP, VK_DOWN,

$30..$39, $41..$42, $44..$55, $57, $59..$5A];

begin

{ exit if we don't get back a webbrowser object }

if WebBrowser1 = nil then

begin

Handled := False;

Exit;

end;

 

if (Msg.hwnd = WebBrowser1.Handle) or (IsChild(WebBrowser1.Handle, Msg.hwnd)) then

begin

if ((Msg.message = WM_KEYDOWN) or

(Msg.message = WM_KEYUP)) and

(GetKeyState(VK_CONTROL) < 0) then

begin

Handled := (WebBrowser1.Application as IOleInPlaceActiveObject).TranslateAccelerator(Msg)=S_OK;

if (Msg.wParam = 67) then

Clipboard.AsText := WebBrowser1.OleObject.Document.selection.createRange().text;

if (Msg.wParam = 88) then

WebBrowser1.OleObject.Document.selection.createRange().text := '';

WebBrowser1.OleObject.Document.selection.createRange().select();

end

else

begin

Handled := not word(Msg.wParam) in [byte('A')..byte('Z'),VK_RETURN];

if Handled or (Msg.wParam = VK_RETURN) then

Handled := (WebBrowser1.Application as IOleInPlaceActiveObject).TranslateAccelerator(Msg)=S_OK;

end

end;

end;

 

WebBrowser에 메인과 프레임 읽기 완료 알기

procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;

const pDisp: IDispatch; var URL: OleVariant);

var

CurWebrowser: IWebBrowser;

TopWebBrowser: IWebBrowser;

Document: OleVariant;

WindowName: string;

begin

CurWebrowser := pDisp as IWebBrowser;

TopWebBrowser := (Sender as TWebBrowser).DefaultInterface;

if CurWebrowser = TopWebBrowser then

Memo1.Lines.Add('Complete document was loaded')

else;

begin

Document := CurWebrowser.Document;

WindowName := Document.ParentWindow.Name;

Memo1.Lines.Add(Format('Frame "%s" was loaded', [WindowName]));

end;

end;

 

TWebBrowser에서 특정문자를 부각시키고 위치하기

TWebBrowser에 불려진 윕분서에서 특정 문자열을 찾아서 부각시키고

찾은 문자열에 화면을 스크롤하여 보여줍니다.

아래의 코드는 찾은 문자열의 배경을 빨간색으로 바꾸어 줍니다.

prefix 를 바꾸어주면 다르게도 가능하겠죠. ^^

 

TEmbeddedWB에서도 WBLocateHighlight(WB: TWebBrowser; Text: string)을

WBLocateHighlight(WB: TEmbeddedWB; Text: string)으로 바꾸어주면 사용 할 수 있습니다.

 

uses mshtml;

procedure WBLocateHighlight(WB: TWebBrowser; Text: string) ;

const

prefix = '<span style="color:white; background-color: red;">';

suffix = '</span>';

var

tr: IHTMLTxtRange;

begin

if Assigned(WB.Document) then

begin

tr := ((wb.Document AS IHTMLDocument2).body AS IHTMLBodyElement).createTextRange;

while tr.findText(Text, 1, 0) do

begin

tr.pasteHTML(prefix + tr.htmlText + suffix) ;

tr.scrollIntoView(True) ;

end;

end;

end;

사용 방법은

WBLocateHighlight(WebBrowser1,'musk95') ;

입니다.

WebBrowser를 이용하여 폼 필드에 값 할당과 submit

i) 직접 접근 방법

WebBrowser1.OleObject.Document.frmMain.userID.value := 'k133';

// 폼 이름과 폼 필드 이름을 직접 코딩

WebBrowser1.OleObject.Document.frmMain.submit;

=> "구성원이 없습니다." 라는 에러 발생합니다.

ii) 이름으로 접근 방법

WebBrowser1.OleObject.Document.all.item('userID').value := 'k133';

WebBrowser1.OleObject.Document.all.item('submit').Click;

빈화면을 만들기

procedure NewDocument;

var

C: array[0..MAX_PATH-1] of Char;

FileName: String;

begin

GetTempPath( MAX_PATH, C );

FileName := C;

if FileName[ Length( FileName ) ] <> '\' then FileName := FileName + '\';

FileName := FileName + 'test.htm';

with TFileStream.Create( FileName, fmCreate ) do Free;

WebBrowser.Navigate( FileName );

end;

소스보기

procedure 프로시져명;

var MyDocument: OleVariant;

begin

MyDocument := WebBrowser1.Document;

Memo1.Lines.Clear;

// HTML 소스 보기

Memo1.Lines.Add(MyDocument.DocumentElement.InnerHTML);

// 일반 내용 보기

Memo1.Lines.Add(WebBrowser1.OleObject.Document.DocumentElement.InnerText);

Memo1.Visible:= True;

Memo1.Align:= alClient;

if Memo1.CanFocus then

Memo1.SetFocus;

end;

싸이트이동

WebBrowser1.Navigate('싸이트명');

WebBrowser1.Navigate('About:Blank'); //웹브라우져초기화

현재오픈된 URL가지고 오기

procedureOKGetURL(AStrings:TStrings);

functionWebBrowserCheck(constWebb:IWebBrowser2):Boolean;

var WebV:Variant;

Buf:string;

begin

WebV:=Webb;

Result:=False;

if Assigned(Webb)then

try

Buf:=WebV.Document.URL;

Result:=True;

except;

end;

end;

var

Count,i:integer;

mShellWindow:IShellWindows;

Webb:IWebBrowser2;

WebV:Variant;

begin

mShellWindow:=CreateComObject(CLASS_ShellWindows) as IShellWindows;

Count:=mShellWindow.Count;

fori:=0 to Count-1 do

begin

ifWebBrowserCheck(mShellWindow.Item(i)asIWebBrowser2) then

begin
try

Webb:=IWebBrowser2(mShellWindow.Item(i));

WebV:=Webb;

AStrings.Add(WebV.Document.URL);

except;

end;

end;

end;

end;

 

WebBrowser에서 이미지 찾아서 클릭하기
uses

MSHTML;

var

iDoc: IHtmlDocument2;

i: integer;

ov: OleVariant;

iDisp: IDispatch;

iColl: IHTMLElementCollection;

InputImage: HTMLInputImage;

begin

WebBrowser1.ControlInterface.Document.QueryInterface(IHtmlDocument2, iDoc);

if not Assigned(iDoc) then

begin

Exit;

end;

ov := 'INPUT';

iDisp := iDoc.all.tags(ov);

if Assigned(IDisp) then

begin

IDisp.QueryInterface(IHTMLElementCollection, iColl);

if Assigned(iColl) then

begin

for i := 1 to iColl.Get_length do

begin

iDisp := iColl.item(pred(i), 0);

iDisp.QueryInterface(HTMLInputImage, InputImage);

if Assigned(InputImage) then

begin

if InputImage.Name = 'submit' then

// if the name is submit / falls der name submit lautet

begin

InputImage.Click; // click it / klick es

end;

end;

end;

end;

end;

end;

 

// 2.

procedure TForm1.Button1Click(Sender: TObject);

var

i: Word;

Document: IHtmlDocument2;

str: string;

begin

// Schleife uber alle Bilder im Webbrowser

for i := 0 to WebBrowser1.OleObject.Document.Images.Length - 1 do

begin

Document := WebBrowser1.Document as IHtmlDocument2;

// URL auslesen

Str := (Document.Images.Item(i, 0) as IHTMLImgElement).Href;

// Dateiname des Bildes uberprufen

if Pos('submit_icon.gif', str) <> 0 then

begin

((Document.Images.Item(i, 0) as IHTMLImgElement) as IHTMLElement).Click;
end;

end;

end;