注册 登陆
浏览模式: 标准 | 列表 分类: DELPHI

GDI TGPImage 提取 GIF 动画

 

Delphi代码
  1. //代码文件:   
  2. unit Unit1;   
  3.   
  4. interface  
  5.   
  6. uses  
  7.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,   
  8.   Dialogs, StdCtrls;   
  9.   
  10. type  
  11.   TForm1 = class(TForm)   
  12.     Button1: TButton;   
  13.     ListBox1: TListBox;   
  14.     OpenDialog1: TOpenDialog;   
  15.     procedure FormCreate(Sender: TObject);   
  16.     procedure FormDestroy(Sender: TObject);   
  17.     procedure Button1Click(Sender: TObject);   
  18.     procedure FormPaint(Sender: TObject);   
  19.     procedure ListBox1Click(Sender: TObject);   
  20.   end;   
  21.   
  22. var  
  23.   Form1: TForm1;   
  24.   
  25. implementation  
  26.   
  27. {$R *.dfm}  
  28.   
  29. uses GDIPOBJ, GDIPAPI;   
  30.   
  31. var  
  32.   img: TGPImage;   
  33.   GifFrame, GifFrameCount: Word;   
  34.   
  35. procedure TForm1.FormCreate(Sender: TObject);   
  36. begin  
  37.   OpenDialog1.Filter := 'GIF 文件|*.gif';   
  38.   img := TGPImage.Create;   
  39. end;   
  40.   
  41. procedure TForm1.FormDestroy(Sender: TObject);   
  42. begin  
  43.   img.Free;   
  44. end;   
  45.   
  46. procedure TForm1.Button1Click(Sender: TObject);   
  47. var  
  48.   DimensionsCount: Integer;   
  49.   DimensionsIDs: PGUID;   
  50.   i: Integer;   
  51. type  
  52.   ArrDimensions = array of TGUID;   
  53. begin  
  54.   if not OpenDialog1.Execute then Exit;   
  55.   img.Free;   
  56.   img := TGPImage.Create(OpenDialog1.FileName);   
  57.   
  58.   {获取 Gif 总帧数}  
  59.   DimensionsCount := img.GetFrameDimensionsCount;   
  60.   GetMem(DimensionsIDs, DimensionsCount * SizeOf(TGUID));   
  61.   img.GetFrameDimensionsList(DimensionsIDs, DimensionsCount);   
  62.   GifFrameCount := img.GetFrameCount(ArrDimensions(DimensionsIDs)[0]);   
  63.   FreeMem(DimensionsIDs);   
  64.   
  65.   Text := Format('共有 %d 帧', [GifFrameCount]);   
  66.   
  67.   {显示帧列表}  
  68.   ListBox1.Clear;   
  69.   for i := 1 to GifFrameCount do  
  70.     ListBox1.Items.Add(Format('第 %d 帧', [i]));   
  71.   
  72.   Repaint;   
  73. end;   
  74.   
  75. procedure TForm1.FormPaint(Sender: TObject);   
  76. var  
  77.   g: TGPGraphics;   
  78. begin  
  79.   g := TGPGraphics.Create(Canvas.Handle);   
  80.   g.DrawImage(img, ListBox1.Width + 1010, img.GetWidth, img.GetHeight);   
  81.   g.Free;   
  82. end;   
  83.   
  84. procedure TForm1.ListBox1Click(Sender: TObject);   
  85. begin  
  86.   GifFrame := ListBox1.ItemIndex;   
  87.   img.SelectActiveFrame(FrameDimensionTime, GifFrame);   
  88.   Repaint;   
  89. end;   
  90.   
  91. end.   
  92.   
  93. //窗体文件:   
  94.     
  95. object Form1: TForm1   
  96.   Left = 0  
  97.   Top = 0  
  98.   Caption = 'Form1'  
  99.   ClientHeight = 206  
  100.   ClientWidth = 339  
  101.   Color = clBtnFace   
  102.   Font.Charset = DEFAULT_CHARSET   
  103.   Font.Color = clWindowText   
  104.   Font.Height = -11  
  105.   Font.Name = 'Tahoma'  
  106.   Font.Style = []   
  107.   OldCreateOrder = False   
  108.   OnCreate = FormCreate   
  109.   OnDestroy = FormDestroy   
  110.   OnPaint = FormPaint   
  111.   PixelsPerInch = 96  
  112.   TextHeight = 13  
  113.   object ListBox1: TListBox   
  114.     Left = 0  
  115.     Top = 0  
  116.     Width = 89  
  117.     Height = 206  
  118.     Align = alLeft   
  119.     ItemHeight = 13  
  120.     TabOrder = 0  
  121.     OnClick = ListBox1Click   
  122.   end  
  123.   object Button1: TButton   
  124.     Left = 256  
  125.     Top = 173  
  126.     Width = 75  
  127.     Height = 25  
  128.     Caption = 'Button1'  
  129.     TabOrder = 1  
  130.     OnClick = Button1Click   
  131.   end  
  132.   object OpenDialog1: TOpenDialog   
  133.     Left = 160  
  134.     Top = 104  
  135.   end  
  136. end  
  137.   

Webbrowser技巧

1.获得网页中变量值     
htm中<script> var currID=123</script>     
程序中可以这么调用 id := Form1.WebBrowser1.OleObject.Document.script.currID     
值得说明的是,变量可以是javascript定义的,也可以是vbscript定义的,如果Webbrowser1中找不到该变量,调用会触发一个异常事件,即变量currID不存在

2.执行网页中的函数     
tmp := 'currID = getNextID(currID)'+#13#10;
Form1.WebBrowser1.OleObject.Document.parentWindow.execScript(tmp,'JavaScript');    
调用函数的方法就是execScript接口,同样,如果函数不存在,或者运行错误也会触发脚本错误异常

3.设置网页背景     
背景图片 WebBrowser1.OleObject.Document.body.background     := 'http://seelearn.com/bg.gif
'        背景颜色 WebBrowser1.OleObject.Document.body.bgcolor     := '#eeeeee'

4.调用网页中已知对象     
src := WebBrowser1.OleObject.Document.getElementByID('img1').src      该方法其实就是javascript中的 getElementByID  

5.获取页面中所有的frame     
使用DHTML。
      frames:=wb.OleObject.document.frames;
      for i:=0 to frames.length do
      memo1.lines.Add(frames[i].document.body.innerHTML);

6.BorderStyle=bsNone后Webbrowser会被重新初始化     
这是一个让人很意外的一个问题,Delphi在窗口控件的控制方面做得非常好,很少出现这种BUG     
根据分析,出现这个现象有很多情况 改变FormStyle也会出现 ; 如果     webbrowser.parent    
由panel1改到panel2.也会导致webbrowser重新初始化。

7.直接向Webbrowser中写入html代码,不需要Navigate到实际存在的文件     
     var
     StrStream:TStringStream;
     SetNoteStr: string;      begin    SetNoteStr :='<body bgcolor=222222 align=center><br><p align=center><font size=+2 color=#FFFFFF>扬帆博客 http://wesohon.com</font></p>';
    SetNoteStr :=SetNoteStr+'<br><p align=center><font size=+2 color=#FFFFFF>点击左边按钮可查看对应图片</font></p>';
    StrStream:=TStringStream.Create(SetNoteStr);
    WebBrowser1.Navigate('about:blank');
    try
      StrStream.Position:=0;
      ( WebBrowser1.Document as IPersistStreamInit).Load(TStreamadapter.Create(StrStream));
    finally
      StrStream.Free;
    end;
8.前进,后退,刷新    
self.WebBrowser1.GoBack    
self.WebBrowser1.GoForward     
self.WebBrowser1.Refresh

9.捕捉NewWindow2事件,即新开窗口事件    
procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
    var ppDisp: IDispatch; var Cancel: WordBool);
var
    NewWindow: TForm2;
begin
    //exit;
    NewWindow:= TForm2.Create(nil);
    NewWindow.Show;
    ppDisp:= NewWindow.Webbrowser1.DefaultDispatch;
end;    值得一题的是该方法不能获得新开窗口的URL,退一步的方法只能是等到在新的Webbrowser中触发BeforeNavigate2事件判断了

10.网页中存在iframe时判断页面是否下载结束      
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;const pDisp: IDispatch; var URL: OleVariant);
   begin    
   if WebBrowser1.Application = pDisp then showmessage('页面已全部下载完毕')end;
   说明一下,每个iframe下载完毕都会触发DocumentComplete事件,所以一个页面在真正下载完毕前可能被触发多次

11. 获取网页中图片//使用DOM模型,什么都能读下来   
   uses    MSHtml,    ActiveX;       
   var  
           html_doc:    IHTMLDocument2;  
           doc_all :    IHtmlElementCollection;  
           vI      :    IHtmlImgElement;  
   begin  
           html_doc    :=    WebBrowser1.Document    as    IHTMLDocument2;  
           doc_all     :=    html_doc.images;  
           for    I    :=    0    to    doc_all.length    -    1      do  
           begin  
                   vI  :=    doc_all.item(I,    EMPTYPARAM)    as    IHtmlImgElement;  
                   //读取vI.src  
                   Memo1.Lines.Add(vI.src);  
           end;  
   end;12. 下面函数获得ISomeControl接口var  
           html_doc:    IHTMLDocument2;  
           doc_all :    IHtmlElementCollection;  
           vI      :    IHtmlElement;  
           vD      :    IDispatch;  
   begin  
           html_doc    :=    WebBrowser1.Document    as    IHTMLDocument2;  
           doc_all     :=    html_doc.all;  
           for    I    :=    0    to    doc_all.length    -    1      do  
           begin  
                   vI  :=    doc_all.item(I,    EMPTYPARAM)    as    IHtmlElement;  
                   if    vI.tagName='OBJECT'    then  
                   begin  
                           //读取Classid  
                           Memo1.Lines.Add((vI    as    IHtmlObjectElement).classid);  
                           //读取包容的对象接口  
                           vD    :=    (vI    as      IHtmlObjectElement).object_;  
                           ...  
                   end;  
           end;  
   end;

删除整个目录 API DelDirectory

转自:http://www.wesoho.com/default.asp?CateID=5&page=2

以往删除目录时,都需要先用递归删干净目录下的文件和子文件夹,这样做的时候,如果文件数量大,那么删除会非常慢
于是找了个方便一点的方法,直接使用API将目录删除

代码如下:

function DelDirectory(const Source: string): boolean;
var
    fo: TSHFILEOPSTRUCT;
begin
    FillChar(fo, SizeOf(fo), 0);
    with fo do
    begin
      Wnd    := 0;
      wFunc := FO_Delete;
      pFrom := PChar(Source + #0);
      pTo    := #0#0;
      fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
    end;
    Result := (SHFileOperation(fo) = 0);
end;

关于Delphi中预编译指令的使用方法

   Delphi中,也有与C相似的预编译指令,虽然该类指令只在当前的单个文件有效(也有可能是笔者未全面了解该类指令的真正用法),但是这一类指令对于进行多版本的制作工作(如从标准版中出学习版),确实有着相当不错的用途。

 

一.指令介绍:

1. DEFINE指令:

格式:{$DEFINE 名称}

              说明  :用于定义一个在当前单元有效的符号(Symbol)。定义了

               之后可以使用IF DEFIFNDEF指令来判断该符号是否存在。

 

2. UNDEF指令:

格式:{$UNDEF 名称}

说明:用于取消一个在当前单元已经定义的符号(Symbol)。该指令和DEFINE

配合使用。

 

3. IFDEF指令:

格式:{$IFDEF 名称}

说明:如果该指令后的名称已经定义,则编译该指令后直到{$ELSE}{$ENDIF}之间的代码段。

 

4. IFNDEF指令:

格式:{$IFNDEF 名称}

说明:如果该指令后的名称没有定义,则编译该指令后直到{$ELSE}{$ENDIF}之间的代码段。

 

5. IFOPT指令:

格式:{$IFOPT 开关}

说明:如果该指令后的开关已经设立,则编译该指令后直到{$ELSE}{$ENDIF}之间的代码段。

举例:{$IFOPT R+}

 Writeln('编译时打开范围检查开关');

{$ENDIF}

 

6. ELSE指令:

格式:{$ELSE}

说明:通过判断前缀Ifxxx的条件式来确定该指令到{$ENDIF}之间的代码段是否应该被编译或者忽略掉。

 

7. ENDIF指令:

格式:{$ENDIF}

说明:和Ifxxx配合,指明条件预编译段源代码段的结束位置。

 

二.范例:

编写例子,通过预先定义不同的编译符号,进行不用代码段的编译工作。

1. 新建一个Delphi项目,在Unit1单元的窗体上添加一个Button按钮。

2. 编写程序如下:

   unit Unit1;

 

 interface

 

 uses

     Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

 StdCtrls;

type

 TForm1 = class(TForm)

        Button1: TButton;

    procedure FormCreate(Sender: TObject);

        procedure Button1Click(Sender: TObject);

 private

        { Private declarations }

 public

        { Public declarations }

 a : String;

 end;

 

var

 Form1: TForm1;

 

implementation

 

{$R *.DFM}

 

{$DEFINE AAA}                            // 定义行。

 

procedure TForm1.FormCreate(Sender: TObject);

begin

a := 'Other';

{$IFDEF AAA}

 a := 'AAA';

{$ENDIF}

{$IFDEF BBB}

 a := 'BBB';

{$ENDIF}

end;

 

procedure TForm1.Button1Click(Sender: TObject);

begin

 Caption := a;

end;

 

end.

{注:粗体字部分为输入的代码}

3. 编译后运行,按下Button,则看到窗体标题栏显示“AAA”。程序编译了a := ’AAA’的语句。

4. 改变定义行的程序段:

当改为

 {$DEFINE BBB}

时,再次编译运行,则看到窗体标题栏显示“BBB”。程序编译了a := ’BBB’的语句。

当取消定义行或改为

 {$DEFINE NOTHING}

或其他名称时,再次编译运行,则看到窗体标题栏显示“Other”。程序只编译了a := ’Other’的语句。

 

三.如何快速的制作和更改版本:

使用预编译指令,在制作同一个程序的多个版本时,只需找出各版本中有区别的单元,依次定义统一的版本符号(Symbol),然后在程序段中加入条件预编译指令,就可以在实际编译中取舍编译不同的程序部分,这样对于程序的规范性(定义统一的版本符号)和保密性(不同的版本编译不同的程序部分)有很好的作用。

然而,由于该类预编译指令只能作用于当前单元,所以不便之处在于不能在一个公共单元定义一次版本符号,而必须在各单元中定义统一版本符号才行,故此,在更换版本时,需要确定所有的版本符号都已改变,这样才能保证各版本的正确性,对此,可以使用Delphi IDE的“Find in Files…”(多个文件中查找字符串)的功能,找出所有定义版本符号的文件和位置,然后依次更改,保证所有位置已经改正

Tags: 预编译, 指令

Delphi SQL冒号要小心

入库的时候要注意【:】这个能导致TADOQuery.ParamCheck设置为False即可.

TADOQuery.ParamCheck设置为False即可.

Delphi的对象注销方法Destroy和free的区别

        当您使用完对象后,您应该及时撤销它,以便把这个对象占用的内存释放出来。您可以通过调用一个注销方法来撤销您的对象,它会释放分配给这个对象的内存。

         Delphi的注销方法有两个:Destroy和Free。Delphi建议使用Free,因为它比Destroy更为安全,同时调用Free会生成效率更高的代码。

          您可以用下列的语句释放用完的Employee对象: 

Employee.Free; 

          和Create方法一样,Free方法也是TEmployee从TObject中继承过来的。把您的注销放在try…finally程序模块的finally部分,而把对象的程序代码放在try部分是编程的好习惯。这样,即使您的程序代码在使用对象时发生了异常事件,也会确保您为这个对象分配的内存会被释放。

二者的区别是,Destroy    会直接释放对象,而Free会事实检查该对象是否存在,如果对象存在,或者对象不为nil,它才会调用Destroy。因此,程序中应  
     该尽量使用free来释放对象,这样更加安全一些。(但要注意,free    也不会自动将对象置为nil,所以在调用free之后,最好是再手动将对象置为nil。)
      TObject类有一个虚拟的Destroy虚构函数和一个非虚拟的Free函数。Free函数中是调用Destroy的。因此,当我们对任何对象(都是TObject的子类对象)调用    .Free();之后,都会执行    TObject.Free();,它会调用我们所使用的对象的析构函数    Destroy();。这就保证了任何类型的对象都可以正确地被析构。  

Delphi中关于listview的一些使用

//增加
   i := listview1.Items.Count;
   with ListView1 do
   begin
     ListItem:=Items.Add;
     ListItem.Caption:= IntToStr(i);
     ListItem.SubItems.Add('第 '+IntToStr(i)+' 行');
     ListItem.SubItems.Add('第三列内容');
   end;

//按标题删除
   for i:=ListView1.Items.Count-1 downto 0 Do
     if ListView1.Items[i].Caption = Edit1.Text then
     begin
       ListView1.Items.Item[i].Delete();   //删除当前选中行
     end;

//选中一行
   if ListView1.Selected <> nil then
   Edit1.Text := ListView1.Selected.Caption;

//    listview1.Items[Listview1.Items.Count -1].Selected := True;
//    listview1.Items[Listview1.Items.Count -1].MakeVisible(True);  

// 选择第一条
procedure TForm1.Button2Click(Sender: TObject);
begin
   listview1.SetFocus;
   listview1.Items[0].Selected := True;
end;

// 选择最后一条
procedure TForm1.Button1Click(Sender: TObject);  
begin
   listview1.SetFocus;
   listview1.Items[Listview1.Items.Count -1].Selected := True;
end;  

//此为调用过程,可以任意指定要移动的Item,下面是当前(Selected)Item
procedure ListViewItemMoveUpDown(lv : TListView; Item : TListItem; MoveUp, SetFocus : Boolean);
var
   DestItem : TListItem;
begin
   if (Item = nil) or
      ((Item.Index - 1 < 0) and MoveUp) or
      ((Item.Index + 1 >= lv.Items.Count) and (not MoveUp))
     then Exit;
   lv.Items.BeginUpdate;
   try
     if MoveUp then
       DestItem := lv.Items.Insert(Item.Index - 1)
     else
       DestItem := lv.Items.Insert(Item.Index + 2);
     DestItem.Assign(Item);
     lv.Selected := DestItem;
     Item.Free;
   finally
     lv.Items.EndUpdate;
   end;
   if SetFocus then lv.SetFocus;
   DestItem.MakeVisible(False);
end;


   ListViewItemMoveUpDown(ListView1, ListView1.Selected, True, True);//上移
   ListViewItemMoveUpDown(ListView1, ListView1.Selected, False, True);//下移


TListView组件使用方法

引用CommCtrl单元

procedure TForm1.Button1Click(Sender: TObject);
begin
   ListView_DeleteColumn(MyListView.Handle, i);//i是要删除的列的序号,从0开始
end;

用LISTVIEW显示表中的信息:
procedure viewchange(listv:tlistview;table:tcustomadodataset;var i:integer);
   begin
     tlistview(listv).Items.BeginUpdate;    {listv:listview名}
     try
       tlistview(listv).Items.Clear;
       with table do          {table or query名}
       begin
         active:=true;
         first;
         while not eof do
         begin
           listitem:=tlistview(listv).Items.add;
           listitem.Caption:=trim(table.fields[i].asstring);
//           listitem.ImageIndex:=8;
           next;
         end;
       end;
     finally
       tlistview(listv).Items.EndUpdate;
     end;
end;


ListView使用中的一些要点。以下以一个两列的ListView为例。
→增加一行:
with ListView1 do
   begin
     ListItem:=Items.Add;
     ListItem.Caption:='第一列内容';
     ListItem.SubItems.Add('第二列内容');
   end;
   →清空ListView1:
ListView1.Items.Clear;
   →得到当前被选中行的行的行号以及删除当前行:
For i:=0 to ListView1.Items.Count-1 Do
   If ListView1.Items[i].Selected then   //i=ListView1.Selected.index
     begin
       ListView1.Items.Delete(i);   //删除当前选中行
     end;
当然,ListView有OnSelectItem事件,可以判断选择了哪行,用个全局变量把它赋值出来。
   →读某行某列的操作:
Edit1.Text := listview1.Items[i].Caption;   //读第i行第1列
Edit2.Text := listview1.Items[i].SubItems.strings[0];   //读第i行第2列
Edit3.Text := listview1.Items[i].SubItems.strings[1];   //读第i行第3列
以次类推,可以用循环读出整列。
   →将焦点上移一行:
For i:=0 to ListView1.Items.Count-1 Do
   If (ListView1.Items[i].Selected) and (i>0) then
     begin
       ListView1.SetFocus;
       ListView1.Items.Item[i-1].Selected := True;
     end;

 引用内容
不过在Delphi7中,ListView多了一个ItemIndex属性,所以只要
ListView1.SetFocus;
ListView1.ItemIndex:=3;
就能设定焦点了。




Delphi的listview能实现交替颜色么?

 程序代码
procedure TForm1.ListView1CustomDrawItem(
   Sender: TCustomListView; Item: TListItem; State: TCustomDrawState;
   var DefaultDraw: Boolean);
var
   i: integer;
begin
   i:= (Sender as TListView).Items.IndexOf(Item);
   if odd(i) then sender.Canvas.Brush.Color:= $02E0F0D7
   else sender.Canvas.Brush.Color:= $02F0EED7;
   Sender.Canvas.FillRect(Item.DisplayRect(drIcon));
end;

Tags: listview

具有自动查找Web页面上所有链接的网络浏览器

具有自动查找Web页面上所有链接的网络浏览器

1. 概述
WEB的应用已经深入到现在社会的方方面面,作为一个软件开发人员或其他技术人员,都有可能遇见在Internet上查询大量的资料和信息的情况,一般来说用的最多的就是WEB的搜索Engine。当我们使用它查出大量的资料链接后,还有可能遇到更多的链接,但要自己去看他们是否是链接,那确实是一件很麻烦的事情。这篇文章就是来讲,如何用Delphi的MSHTML_TLB.pas来开发一个具有自动查找Web页面上所有链接的简单网络浏览器。我是在IE5的环境下写的这个程序,当然它可以向下兼容,如IE4。
2.关于MSHTML_TLB.pas
MSHTML_TLB.pas是Deliphi里面自带的一个类。它的含义是Microsoft HTML对象库。它不能够包含在所有的工程或程序中,原因是它实在是太大了,整个文件的代码共有241,899l行,那么长。大小约有12M。下面我们来看看它是如何加入到程序中的。
1. 首先,我们打开Delphi,建立一个新的application。我把form1保存为MainFrm.pas,把application保存为FindLinks.dpr.
2. 要想实现IE 的功能我们就必须要使用Microsoft HTML对象库(MSHTML type library.)如何实现呢?如图1, Project->Import Type Library:

然后你会看到关于"Microsoft HTML Object Library (Version 4.0)"的列表,如图2。
接下来可能会遇到一些问题。比如,在列表里面没有出现"Microsoft HTML Object Library (Version 4.0)"。这是为什么呢?那是IE的问题,由于IE版本的不同(我用的是IE5)。我建议最好是先查询你的计算机里面有没有mshtml.tlb这个文件。
在9x里面它是存在与C:\WINDOWS\SYSTEM目录里面,在2000里面它在\WINNT\system32目录里面。如果找到了这个文件,就可以用图2的click on the "Add..." button,然后选择mshtml.tlb,就可以了,如果没有找到它,那说明你没有安装IE或你的IE版本太低,请升级IE。
最后,当我们选择了倒入的库后,会等待一段时间,因为它实在是太长了,不过请千万不要因为是死机了。它会给自动查找提供很多帮助。
3. 工程实现。
界面设计如下图:


使用以下组件:
控件 命名 TEXT
TLabel lblURL 资料网址
TEdit edtURL http://www.huihu.com
TButton btnFindLinks 查询连接
TListBox lstbxLinks null

4. 程序设计
1. 在Form1的interface部分,在uses后面加入,OleCtrls, SHDocVw, and OleServer.这些所应用的类,都是基于我们所要创建的TinternetExplorer的,它是IE的ActiveX的对象。但是这里还有其它的方式(TinternetExplorer)进行,我们采用TwebBrowser 控制在我们的form1。
2. 我们在private里面加入如下代码:
FInternetExplorer: TInternetExplorer;
procedure WebBrowserDocumentComplete(Sender: TObject; var pDisp: OleVariant;
var URL: OleVariant);
最后用Ctrl-Shift-C完成类的声明。
3. 在impelmentation后面加入如下声明:
uses MSHTML_TLB, ComObj;
要使用的类。
4. 在form1的OnCreate事件中加入如下:
FInternetExplorer := TInternetExplorer.Create(Self);
FInternetExplorer.OnDocumentComplete := WebBrowserDocumentComplete;
5. 最后在form1的TForm1.WebBrowserDocumentComplete里面加入如下代码:
1. procedure TForm1.WebBrowserDocumentComplete(Sender: TObject;
2. var pDisp: OleVariant; var URL: OleVariant);
3. var
4. Doc: IHTMLDocument2;
5. ElementCollection: IHTMLElementCollection;
6. HtmlElement: IHTMLElement;
7. I: Integer;
8. AnchorString: string;
9. begin
10. lstbxLinks.Clear;
11. // 在处理网页的时候发现它没有完全下载,将不会进行处理连接
12. Doc := FInternetExplorer.Document as IHTMLDocument2;
13. if Doc = nil then
14. raise Exception.Create(''''Couldn''''''''t convert the ''''
15. ''''FInternetExplorer.Document to an IHTMLDocument2'''');
16. // 夺取web上的所有元素。
17. ElementCollection := Doc.all;
18. for I := 0 to ElementCollection.length - 1 do
19. begin
20. file://得到当前的元素
21. HtmlElement := ElementCollection.item(I, '''''''') as IHTMLElement;
22. // 查找网页原代码中的LINK标记。
23. // 发现其它的html标记 (例如: TABLE, FONT, etc.)
24. if HTMLElement.tagName = ''''A'''' then
25. begin
26. // 在详细的link里面抓取innerText,innertext就是标记中<href=后面的东西>例如:

27. // 我们在web里面看见"西南民族学院"
28. // <a href="http://www.swun.edu.cn"><b>西南民族学院</b></a>.
29. AnchorString := HtmlElement.innerText;
30. if AnchorString = '''''''' then
31. AnchorString := ''''(Empty Name)'''';
32. AnchorString := AnchorString '''' - ''''
33. (HtmlElement as IHTMLAnchorElement).href;
34. lstbxLinks.Items.Add(AnchorString);
35. end;
36. end;
37. end;

最后我们在button(btnFindLinks)加入Onclick 事件:
1. // 在被浏览的web里面进行查询连接。
2. FInternetExplorer.Navigate(edtURL.Text, EmptyParam, EmptyParam,
EmptyParam, EmptyParam);
从以上的程序里面我们可以看出它的原理了,实际上是很简单的,看过html原代码的人都知道,使网页产生连接的代码就是:<a href="http://www.swun.edu.cn"><b>西南民族学院</b></a>.
我程序的原理就是通过截取href后面的字符串,并在"""号后面截止。
然后把它保存为另外的字符串。然后通过TwebBrowser显示出来。
最后让我们来编译这个程序,的却,编译它很费时间,因为编译多达241,899l行的MSHTML_TLB.pas,是一件很麻烦的事情。其中还包括多达20多个的warning错误,但请放心这是MSHTML_TLB.pas的问题,与其它程序无关。这样一个小型的查找Web页面上所有链接的简单网络浏览器就出现在我们面前。本程序在IE5.0和Delphi6下编译通过。

解决WebBroswer多次载入问题

Delphi代码
  1. 因为你浏览的页面可能有框架,每个单独的框架都可能会触发DocumentComplete事件。   
  2. 正在装载数据……    
  3.   
  4. 框架集页面会最后触发DocumentComplete事件。   
  5. 发送事件的对象可以通过DocumentComplete事件的第一个参数访问   
  6.   
  7. procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;   
  8. const pDisp: IDispatch; var URL: OleVariant);   
  9. var  
  10. CurWebrowser: IWebBrowser;   
  11. TopWebBrowser: IWebBrowser;   
  12. Document: OleVariant;   
  13. WindowName: string;   
  14. begin  
  15. CurWebrowser := pDisp as IWebBrowser;   
  16. TopWebBrowser := (Sender as TWebBrowser).DefaultInterface;   
  17. if CurWebrowser = TopWebBrowser then  
  18. ShowMessage('Complete document was loaded')   
  19. else  
  20. begin  
  21. Document := CurWebrowser.Document;   
  22. WindowName := Document.ParentWindow.Name;   
  23. ShowMessage(Format('Frame "s" was loaded', [WindowName]));   
  24. end;   
  25. end;   

关于Delphi中的Assigned

Delphi代码
  1. function assigned(var P): Boolean;   
  2.   
  3. Description   
  4.   
  5. Use Assigned to determine whether the pointer or procedure referenced by P is nil. P must be a variable reference of a pointer or procedural type. Assigned(P) corresponds to the test P<> nil for a pointer variable, and @P <> nil for a procedural variable.   
  6.   
  7. Assigned returns False if P is nil, True otherwise.   
  8.   
  9. 检查指针指向的参考变量或过程是否为nil  
  10.   
  11. 每次我通常的处理方法都是:   
  12.   
  13.  if assigned(frm) then frm.close;   但是当下次调用时就会出错。为什么呢,直到咋天我才知道原因   
  14.   
  15. frm.close;frm.free;  只是指定这块内存可以重写,并未释放为NIL 因此当下次调用时即使frm.free已经   
  16.   
  17. 执行过assigned(frm)仍为TRUE;   
  18.   
  19. 正确的处理方法:   
  20.   
  21.  if assigned(frm) then    
  22. begin  
  23.    frm.close;   
  24.    frm:=nil;   
  25. end;   
  26.   
  27. 或:   
  28.   
  29. if assigned(frm) then    
  30. begin  
  31.   frm.close;   
  32.   freeandnil(frm);   
  33. end;   
  34.   
  35. freeandnil的说明:   
  36.   
  37. procedure FreeAndNil(var Obj);   
  38.   
  39. Description   
  40.   
  41. Use FreeAndNil to ensure that a variable is nil after you free the object it references. Pass any variable that represents an object as the Obj parameter.    

Tags: assigned