pickup word's shapes for Delphi

2024-04-29 04:20•杂谈•阅读 3124

unit WordApp;

interface

uses

Windows, Messages, Forms, SysUtils, Variants, Classes, Graphics, Controls, StdCtrls,

Dialogs, ExtCtrls,types, OleCtnrs,dbtables,db, OleServer, Word2000, Office2000,

ComCtrls, math;

type

TAutoShape = Record {自动图形结构}

Style:Byte; {属于那种风格，即：矩形，椭圆，三角形}

Top: Smallint;

Left:Smallint;

Height:Smallint;

Width: Smallint;

end;

type

TLine = Record {直线图形结构}

Color: Byte;

Weight: Byte; {线宽}

EndArrowheadStyle: Byte; {后端风格}

BeginPoint: TPoint; {前端坐标}

EndPoint: TPoint; {后端坐标} {注：此处坐标来源于直线的位置和大小，它本身没有这样的属性}

end;

type

FreeForm = Record {任意多边形－－曲线}

FillColor:Byte;

LineColor:Byte;

Weight:Word;

Count:Word;

{Left:Word;

Top: Word;

Width:Word;

Height:Word;}

Nodes:array of TPoint; {曲线顶数组 }

end;

type

TextFrame = Record {文本框}

Text: String; { WideString;}

{ Font: String;

Color: TColor; }

FontSize:Byte;

Left: Smallint;

Height:Smallint;

Top: Smallint;

Width:Smallint;

Orientation:Byte; {文本框方向}

end;

type

TextEffect = Record {艺术字}

Text : String;

FontSize : Byte;

// FontName:string;

// Color: TColor;

Left : Smallint;

Height : Smallint;

Top : Smallint;

Width : Smallint;

end;

type

TPic = Record

SourceName : String;

Left : Smallint;

Height : Smallint;

Top : Smallint;

Width : Smallint;

end;

Const

GroupStyleNone = 0;

GroupStyleHLadder = 1;

GroupStyleVLadder = 2;

GroupStyleElevator = 3;

GroupStyleWaterSrc = 4;

GroupStyleNorth = 5;

GroupStyleFireFighting = 10;

type

TGroup = Record

Style : Byte; {组合图形类别: 0: 无; 1: 水平梯子; 2: 垂直梯子; 3: 电梯; 4: 水源; 5 :指北图表; 10+x : 救火点 ,x为救火点的旋转角度}

Left : Smallint;

Height : Smallint;

Top : Smallint;

Width : Smallint;

end;

const

PICKUP_NOREAD = 0;

PICKUP_READING = 1;

PICKUP_READED = 2;

type

PickUpWord = Class(TObject)

WordApplication : OleVariant;

PickUp : Byte; {读取文件状态}

AutoShapeCount : Word; {自由图形数量}

LineCount : Word; {直线数量}

FreeFormCount : Word; {任意多边形数量}

GroupCount : Word; {组数量}

ArtWordCount : Word; {艺术字数量}

PictureCount : Word; {图片数量}

TextBoxCount : Word; {文本框数量}

PageHeight : Word; {页高}

PageWidth : Word; {页宽}

{ DocumentId : OleVariant; {目前操作的word文档}

{ PageId : OleVariant; {当前操作的页数}

PicPath : array[1..15] of Char; {图片文件的路径}

PickUpSts : Array[1..19] of Byte; {1: 不提取 2: 提取，未初始化数组 3: 提取且完成初始化数组}

LineArray : Array of TLine; {直线坐标}

FreeFormArray : Array of FreeForm; {存储任意多边形}

TextFrameArray : Array of TextFrame; {文本框变量}

TextEffectArray : Array of TextEffect; {艺术字变量}

AutoShapeArray : Array of TAutoShape; {自由图形变量}

PictureArray : Array of TPic; {图片变量}

GroupArray : Array of TGroup; {组合图形}

App : TApplication;

private

// DocumentIndex : _Document; {处理目标docment} {加入一个_documents对象，用来控制或者获取当前打开的word document,而不影响其他正在使用的document.}

WordOpened: Boolean;

WordClosed: Boolean;

procedure GetDocumentItem;

procedure SortArray(var Sa:Array of TLine); // 直线按有无末端风格(箭头)排序(降序)

procedure SortArrayFreeForm(var Sa: array of FreeForm); // 曲线按顶点数排序(降序)

public

constructor Create;

destructor Destroy; override;

procedure OpenWord(FileName:String;IsVisible:Boolean=False);

procedure CloseWord(IsSave:Boolean=False);

procedure GetGraphicCount;

procedure GetGraphic;

function GetLine(IntIndex:Word; OleIndex: OleVariant; var LA: Array of TLine):Boolean;

function GetFreeForm(IntIndex:Word; OleIndex: OleVariant; var FFA: array of FreeForm):Boolean; {曲线}

function GetArtWord(IntIndex:Word; OleIndex: OleVariant; var TEA: Array of TextEffect):Boolean;

function GetTextFrame(IntIndex:Word; OleIndex: OleVariant; var TFA: Array of TextFrame):Boolean;

function GetAutoShape(IntIndex:Word; OleIndex: OleVariant; var TAS: Array of TAutoShape):Boolean;

function GetPic(IntIndex:Word; OleIndex: OleVariant; var TPc: Array of TPic): Boolean;

function GetGroup(IntIndex: Word; OleIndex: OleVariant; Var TGp: Array of TGroup): Boolean;

function PointRatation(Src,Center: TPoint; Angle: Single):TPoint;

procedure SaveDataInVtr(FileName:String);

procedure PaintFromVtr(FileName:String;Ca:TCanvas);

procedure PaintLadder(Cn:TCanvas; Left, Top, Height, Width : Integer; HorV: Boolean); {绘制梯子}

procedure PaintElevator(Cn :TCanvas; Left, Top, Height, Width: Integer);

procedure PaintWaterSource(Cnv:TCanvas; Left,Top,Right,Bottom:Word);

procedure PaintFireFighting(Cn: TCanvas; Left, Top, Height, Width, Angle: Integer);

function GetAPointFromLine(BeginP,EndP:Tpoint;L:Integer): Tpoint;

procedure PaintNorth(Cn: TCanvas; Left, Top, Height, Width : integer);

end;

var

Ftxt:File; {用于读写的二进制文件变量}

implementation

uses comobj, VarUtils, WaitFor, PickUpPas, StdConvs;

Const

C_DOTPICKUP = 0;

C_PICKUP_NOTINITARRAY = 2;

C_ALLRGHIT =3;

{ PickUpWord }

procedure PickUpWord.CloseWord(IsSave: Boolean);

var

SaveChanges, OriginalFormat, RouteDocument: OleVariant; { close word var }

begin

WordClosed := False;

SaveChanges := WdDoNotSaveChanges;

OriginalFormat := UnAssigned;

RouteDocument := UnAssigned;

Try

WordApplication.ActiveDocument.Close(SaveChanges,OriginalFormat,RouteDocument);

PickUp := PICKUP_NOREAD;

except

on E: Exception do

begin

ShowMessage(E.Message + #13#10 + '激活文档已经关闭或者不存在！');

end;

WordClosed := True;

end;

constructor PickUpWord.Create;

begin { Create PickUpWord }

Inherited;

WordApplication := CreateOleObject('Word.Application');

PickUp :=0;

AutoShapeCount :=0;

LineCount :=0;

FreeFormCount :=0;

GroupCount :=0;

ArtWordCount :=0;

PictureCount :=0;

TextBoxCount :=0;

end;

destructor PickUpWord.Destroy;

begin { Destroy PickUpWord }

WordApplication.Quit(0);

LineArray := nil;

FreeFormArray := nil;

TextFrameArray := nil;

PictureArray := nil;

AutoShapeArray := nil;

TextEffectArray := nil;

inherited Destroy;

end;

function PickUpWord.GetAPointFromLine(BeginP, EndP: Tpoint; { 在一条线段上获得一点，距离线段末端 L 象素}

L: Integer): Tpoint;

var

Li:Integer;

begin

Li := Round(sqrt(sqr(BeginP.X - EndP.x) + Sqr(BeginP.Y - EndP.Y)));

Result.X := EndP.X - Round((EndP.X - BeginP.X) * L / Li);

Result.Y := EndP.Y - Round((EndP.Y - BeginP.Y) * L / Li);

end;

function PickUpWord.GetArtWord(IntIndex:Word;OleIndex: OleVariant; var TEA: Array of TextEffect): Boolean;

begin

try

TEA[IntIndex-1].Text := WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextEffect.Text; {

TEA[IntIndex-1].FontName := WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextEffect.FontName;

TEA[IntIndex-1].Color := Tcolor(WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextEffect.); }

TEA[IntIndex-1].FontSize := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextEffect.FontSize);

TEA[IntIndex-1].Left := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Left * Screen.PixelsPerInch * 10 / (254 * 2.835));

TEA[IntIndex-1].Top := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Top * Screen.PixelsPerInch * 10 / (254 * 2.835));

TEA[IntIndex-1].Width := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Width * Screen.PixelsPerInch * 10 / (254 * 2.835));

TEA[IntIndex-1].Height := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Height * Screen.PixelsPerInch * 10 / (254 * 2.835));

except

Result:= False;

end;

Result:=True;

end;

function PickUpWord.GetAutoShape(IntIndex: Word; OleIndex: OleVariant; var TAS: Array of TAutoShape): Boolean;

var

Angle: Single;

Tmp:TPoint;

x1,y1,x2,y2:Integer;

begin

TAS[IntIndex-1].Style := WordApplication.ActiveDocument.Shapes.Item(OleIndex).AutoShapeType;

TAS[IntIndex-1].Top := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Top * Screen.PixelsPerInch * 10 / (254*2.835));

TAS[IntIndex-1].Left := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Left * Screen.PixelsPerInch * 10 / (254*2.835));

TAS[IntIndex-1].Height := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Height * Screen.PixelsPerInch * 10 / (254*2.835));

TAS[IntIndex-1].Width := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Width * Screen.PixelsPerInch * 10 / (254*2.835));

Angle := WordApplication.ActiveDocument.Shapes.Item(OleIndex).Rotation;

Tmp.X := (TAS[IntIndex-1].Left+TAS[IntIndex-1].Width) div 2;

Tmp.Y := (TAS[IntIndex-1].Top+TAS[IntIndex-1].Height) div 2;

x1 := TAS[IntIndex-1].Left;

y1 := TAS[IntIndex-1].Top;

x2 := x1 + TAS[IntIndex-1].Width;

y2 := y1 + TAS[IntIndex-1].Height;

TAS[IntIndex-1].Left := PointRatation(point(x1,y1),Tmp,Angle).X;

TAS[IntIndex-1].Top := PointRatation(point(x1,y1),Tmp,Angle).y;

TAS[IntIndex-1].Width := PointRatation(point(x2,y2),Tmp,Angle).X-TAS[IntIndex-1].Left;

TAS[IntIndex-1].Height := PointRatation(point(x2,y2),Tmp,Angle).Y-TAS[IntIndex-1].Top;

Result:=True;

end;

procedure PickUpWord.GetDocumentItem;

begin

//DocumentId:=WordApplication.ActiveDocument;

end;

function PickUpWord.GetFreeForm(IntIndex:Word;OleIndex: OleVariant; var FFA: array of FreeForm): Boolean;

var

j:word;

OleIndex2:OleVariant;

WordApp, Nodes, Points: OleVariant;

begin

Result:=True;

try

WordApp := GetActiveOleObject('Word.Application');

except

WordApp := CreateOleObject('Word.Application');

ShowMessage('无法获得激活的word文件！');

end;

FFA[IntIndex-1].FillColor := WordApp.ActiveDocument.Shapes.Item(OleIndex).Fill.ForeColor.RGB;

FFA[IntIndex-1].LineColor := WordApp.ActiveDocument.Shapes.Item(OleIndex).Line.ForeColor.RGB; {

FFA[IntIndex-1].Left := Round(WordApp.ActiveDocument.Shapes.Item(OleIndex).Left * Screen.PixelsPerInch * 10 / (254*2.835));

FFA[IntIndex-1].Top := Round(WordApp.ActiveDocument.Shapes.Item(OleIndex).Top * Screen.PixelsPerInch * 10 / (254*2.835));

FFA[IntIndex-1].Height := Round(WordApp.ActiveDocument.Shapes.Item(OleIndex).Height * Screen.PixelsPerInch * 10 / (254*2.835));

FFA[IntIndex-1].Width := Round(WordApp.ActiveDocument.Shapes.Item(OleIndex).Width * Screen.PixelsPerInch * 10 / (254*2.835)); }

FFA[IntIndex-1].Weight := WordApp.ActiveDocument.Shapes.Item(OleIndex).Line.Weight;

FFA[IntIndex-1].Count := WordApp.ActiveDocument.Shapes.Item(OleIndex).Nodes.Count;

SetLength(FFA[IntIndex-1].Nodes,FFA[IntIndex-1].Count); {确定一条曲线有几个节点}

for j := 1 to WordApp.ActiveDocument.Shapes.Item(OleIndex).Nodes.Count do

begin

OleIndex2 := j;

Nodes := WordApp.ActiveDocument.Shapes.Item(OleIndex).Nodes;

Points := Nodes.Item(OleIndex2).Points;

FFA[IntIndex-1].Nodes[j-1].X := Round(Points[1,1] * Screen.PixelsPerInch * 10 / (254*2.835));

FFA[IntIndex-1].Nodes[j-1].Y := Round(Points[1,2] * Screen.PixelsPerInch * 10 / (254*2.835));

end;

finally

end;

procedure PickUpWord.GetGraphic;

var

i : integer;

Ff, ln, pc, te, tb, au, Gp: Word;

Index : OleVariant;

begin

Ff := 0;

ln := 0;

pc := 0;

te := 0;

tb := 0;

au := 0;

Gp := 0;

PageHeight := WordApplication.ActiveDocument.PageSetup.PageHeight;

PageWidth := WordApplication.ActiveDocument.PageSetup.PageWidth;

Frm_WaitFor.Pb_Pickup.Max:=WordApplication.ActiveDocument.Shapes.Count;

for i := 1 to WordApplication.ActiveDocument.Shapes.Count do

begin

App.ProcessMessages;

Index := i;

Frm_WaitFor.Pb_Pickup.Position := i;

Frm_WaitFor.Lb_Shape.Caption := '正在提取图形：' + String(WordApplication.ActiveDocument.Shapes.Item(Index).Name);

if PickUpSts[Integer(WordApplication.ActiveDocument.Shapes.Item(Index).type)] = C_DOTPICKUP then Continue; {不提取}

try

case WordApplication.ActiveDocument.Shapes.Item(Index).type of

1 : {msoAutoShape}

begin

if PickUpSts[1] = C_PICKUP_NOTINITARRAY then

begin

SetLength(AutoShapeArray,AutoShapeCount);

PickUpSts[1] := C_ALLRGHIT;

end;

Inc(au);

GetAutoShape(au, Index, AutoShapeArray);

end;

5 : {msoFreeform}

begin

if PickUpSts[5] = C_PICKUP_NOTINITARRAY then

begin

SetLength(FreeFormArray,FreeFormCount);

PickUpSts[5] := C_ALLRGHIT;

end;

Inc(Ff);

GetFreeForm(Ff, Index, FreeFormArray);

end;

6 : {msoGroup}

begin

if PickUpSts[6] = C_PICKUP_NOTINITARRAY then

begin

SetLength(GroupArray, GroupCount);

PickUpSts[6] := C_ALLRGHIT;

end;

Inc(Gp);

GetGroup(Gp, Index, GroupArray);

end;

9 : {msoLine}

begin

if PickUpSts[9] = C_PICKUP_NOTINITARRAY then

begin

SetLength(LineArray, LineCount);

PickUpSts[9] := C_ALLRGHIT;

end;

inc(ln);

GetLine(ln,Index, LineArray);

end;

13 : {msoPicture}

begin

if PickUpSts[13] = C_PICKUP_NOTINITARRAY then

begin

SetLength(PictureArray, PictureCount);

PickUpSts[13] := C_ALLRGHIT;

end;

inc(pc);

GetPic(pc,Index, PictureArray);

end;

15 : {ArtWord} {msoTextEffect}

begin

if PickUpSts[15] = C_PICKUP_NOTINITARRAY then

begin

SetLength(TextEffectArray, ArtWordCount);

PickUpSts[15] := C_ALLRGHIT;

end;

Inc(te);

GetArtWord(te, Index, TextEffectArray);

end;

17 : {msoTextBox}

begin

if PickUpSts[17] = C_PICKUP_NOTINITARRAY then

begin

SetLength(TextFrameArray, TextBoxCount);

PickUpSts[17] := C_ALLRGHIT;

end;

Inc(tb);

GetTextFrame(tb, Index, TextFrameArray);

end

else ;

end;

except

on e:exception do

begin

ShowMessage(e.Message+#13#10+VarToStr(WordApplication.ActiveDocument.Shapes.item(index).name));

end;

PickUp:=PICKUP_READED;

end;

procedure PickUpWord.GetGraphicCount;

var

i : word;

OleIndex : OleVariant;

GroupTag : boolean;

begin

if not WordOpened then exit;

AutoShapeCount := 0;

FreeFormCount := 0;

LineCount := 0;

PictureCount := 0;

GroupCount := 0;

TextBoxCount := 0;

ArtWordCount := 0;

AutoShapeArray := nil;

FreeFormArray := nil;

LineArray := nil;

GroupArray := nil;

PictureArray := nil;

TextFrameArray := nil;

TextEffectArray := nil;

// GroupTag:=false;

PickUp:=PICKUP_READING;

App := TApplication.Create(nil);

{ while not GroupTag do { 取消所有组合.

begin

GroupTag:=True;

for i:=1 to WordApplication.ActiveDocument.Shapes.Count do

begin

OleIndex:=i;

if Integer(WordApplication.ActiveDocument.Shapes.Item(OleIndex).type) =6 then

begin

GroupTag:=false;

WordApplication.ActiveDocument.Shapes.Item(OleIndex).Ungroup;

end;

end; }

for i := 1 to WordApplication.ActiveDocument.Shapes.Count do

begin

OleIndex := i;

App.ProcessMessages;

case Integer(WordApplication.ActiveDocument.Shapes.Item(OleIndex).type) of

1: Inc(AutoShapeCount);

5: Inc(FreeFormCount);

6: Inc(GroupCount);

9: Inc(LineCount);

13: Inc(PictureCount);

15: Inc(ArtWordCount);

17: Inc(TextBoxCount)

else ;

end;

function PickUpWord.GetGroup(IntIndex: Word; OleIndex: OleVariant;

var TGp: array of TGroup): Boolean;

var

TmpInt: Byte;

TmpOleVar,GroupItemOle: OleVariant;

Angle : integer;

TmpH, TmpW : Single;

IsElevator : Boolean;

begin

Result := True;

IsElevator := False;

try

TGp[IntIndex-1].Left := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Left * Screen.PixelsPerInch * 10 / (254*2.835));

TGp[IntIndex-1].Top := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Top * Screen.PixelsPerInch * 10 / (254*2.835));

TGp[IntIndex-1].Height := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Height * Screen.PixelsPerInch * 10 / (254*2.835));

TGp[IntIndex-1].Width := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Width * Screen.PixelsPerInch * 10 / (254*2.835));

case WordApplication.ActiveDocument.Shapes.Item(OleIndex).GroupItems.Count of

2: {指北图表,水源,梯子}

begin

for TmpInt := 1 to 2 do

begin

TmpOleVar := TmpInt; {artw,group} {freef,group} {autoshap,group}

case WordApplication.ActiveDocument.Shapes.Item(OleIndex).GroupItems.Item(TmpOleVar).Type of

begin

Angle := WordApplication.ActiveDocument.Shapes.Item(OleIndex).GroupItems.Item(TmpOleVar).Rotation;

if Abs(Sin(Angle * Pi/180)) = 1 then {根据梯子中间的矩形框的宽高值判断它的方向}

TGp[IntIndex-1].Style := GroupStyleHLadder

else TGp[IntIndex-1].Style := GroupStyleVLadder;

end;

begin

TGp[IntIndex-1].Style := GroupStyleWaterSrc;

end;

15:

begin

TGp[IntIndex-1].Style := GroupStyleNorth;

end

else ;

end;

3: {救火点, 电梯}

begin

for TmpInt := 1 to 3 do {组合元素中包括矩形的为电梯,否则为救火点}

begin

TmpOleVar := TmpInt;

if WordApplication.ActiveDocument.Shapes.Item(OleIndex).GroupItems.Item(TmpOleVar).Type = 1 then

IsElevator := True;

end;

if IsElevator then

TGp[IntIndex-1].Style := GroupStyleElevator

else TGp[IntIndex-1].Style := GroupStyleFireFighting + WordApplication.ActiveDocument.Shapes.Item(OleIndex).GroupItems.Rotation;

end

else ;

end;

except

end;

function PickUpWord.GetLine(IntIndex:Word;OleIndex: OleVariant; var LA: Array of TLine): boolean;

const

pin=Pi/180;

var

TmpPoint:TPoint;

Angle:Double; {旋转角度}

p1,p2: TPoint;

begin

try

LA[IntIndex-1].Weight:=Byte(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Line.Weight);

LA[IntIndex-1].EndArrowheadStyle:=Byte(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Line.EndArrowheadStyle);

LA[IntIndex-1].Color:=WordApplication.ActiveDocument.Shapes.Item(OLeIndex).Line.ForeColor.RGB;

if WordApplication.ActiveDocument.Shapes.Item(OleIndex).HorizontalFlip=0 then

begin

LA[IntIndex-1].BeginPoint.X := (Round(WordApplication.ActiveDocument.Shapes.item(OleIndex).

Left* Screen.PixelsPerInch * 10 / (254*2.835)));

LA[IntIndex-1].EndPoint.X := (Round((WordApplication.ActiveDocument.Shapes.item(OleIndex).

left+WordApplication.ActiveDocument.Shapes.item(OleIndex).Width)* Screen.PixelsPerInch * 10 /(254*2.835)));

end

else begin

LA[IntIndex-1].EndPoint.X := (Round(WordApplication.ActiveDocument.Shapes.item(OleIndex).Left* Screen.PixelsPerInch * 10 / (254*2.835)));

LA[IntIndex-1].BeginPoint.X := (Round((WordApplication.ActiveDocument.Shapes.item(OleIndex).left+WordApplication.ActiveDocument.Shapes.item(OleIndex).Width)* Screen.PixelsPerInch * 10 /(254*2.835)));

end;

if WordApplication.ActiveDocument.Shapes.Item(OleIndex).VerticalFlip=0 then

begin

LA[IntIndex-1].BeginPoint.Y := (Round(WordApplication.ActiveDocument.Shapes.item(OleIndex).Top* Screen.PixelsPerInch * 10 / (254*2.835)));

LA[IntIndex-1].EndPoint.Y := (Round((WordApplication.ActiveDocument.Shapes.item(OleIndex).Top+

WordApplication.ActiveDocument.Shapes.item(OleIndex).Height)* Screen.PixelsPerInch * 10 /(254*2.835)));

end

else begin

LA[IntIndex-1].EndPoint.Y := (Round(WordApplication.ActiveDocument.Shapes.item(OleIndex).Top* Screen.PixelsPerInch * 10 / (254*2.835)));

LA[IntIndex-1].BeginPoint.Y := (Round((WordApplication.ActiveDocument.Shapes.item(OleIndex).Top+

WordApplication.ActiveDocument.Shapes.item(OleIndex).Height)* Screen.PixelsPerInch * 10 /(254*2.835)));

end;

{处理旋转问题}

TmpPoint.X:=(LA[IntIndex-1].BeginPoint.X+LA[IntIndex-1].EndPoint.X) div 2;

TmpPoint.Y:=(LA[IntIndex-1].BeginPoint.Y+LA[IntIndex-1].EndPoint.Y) div 2;

Angle:=WordApplication.ActiveDocument.Shapes.Item(OleIndex).Rotation;

p1:=LA[IntIndex-1].BeginPoint;

p2:=LA[IntIndex-1].EndPoint;

LA[IntIndex-1].BeginPoint:=PointRatation(p1,TmpPoint,Angle);

LA[IntIndex-1].EndPoint:=PointRatation(p2,TmpPoint,Angle);

except

on E: Exception do

begin

Result:=False;

ShowMessage(E.Message+#13#10+' 报错图形：'+WordApplication.ActiveDocument.Shapes.item(OleIndex).Name);

// WordApplication.Disconnect;

end;

Result:=True;

end;

function PickUpWord.GetPic(IntIndex: Word; OleIndex: OleVariant;

var TPc: array of TPic): Boolean;

begin

TPc[IntIndex-1].SourceName := Copy(Trim(WordApplication.ActiveDocument.Fields.Item(intIndex).LinkFormat.SourceName),1,

Length(Trim(WordApplication.ActiveDocument.Fields.Item(intIndex).LinkFormat.SourceName))-3)+'jpg';

TPc[IntIndex-1].Left := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Left* Screen.PixelsPerInch * 10 / (254*2.835)) ;

TPc[IntIndex-1].Top := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Top* Screen.PixelsPerInch * 10 / (254*2.835)) ;

TPc[IntIndex-1].Height := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Height* Screen.PixelsPerInch * 10 / (254*2.835)) ;

TPc[IntIndex-1].Width := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Width* Screen.PixelsPerInch * 10 / (254*2.835)) ;

Result := true;

end;

function PickUpWord.GetTextFrame(IntIndex: Word; OleIndex: OleVariant; var TFA: Array of TextFrame): Boolean;

var

b:Byte;

begin

TFA[IntIndex-1].Text:= Trim(WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextFrame.TextRange.Text);

try

b:=StrToInt(Copy(TFA[IntIndex-1].Text,1,2));

TFA[IntIndex-1].Text:=IntToStr(b);

except

;

end;

TFA[IntIndex-1].Orientation := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextFrame.Orientation); {

TFA[IntIndex-1].Font := WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextFrame.TextRange.Font.Name;}

TFA[IntIndex-1].FontSize := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).TextFrame.TextRange.Font.Size);

TFA[IntIndex-1].Left := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Left* Screen.PixelsPerInch * 10 / (254*2.835));

TFA[IntIndex-1].Top := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Top* Screen.PixelsPerInch * 10 / (254*2.835));

TFA[IntIndex-1].Width := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Width* Screen.PixelsPerInch * 10 / (254*2.835));

TFA[IntIndex-1].Height := Round(WordApplication.ActiveDocument.Shapes.Item(OleIndex).Height* Screen.PixelsPerInch * 10 / (254*2.835));

Result:= True;

end;

procedure PickUpWord.OpenWord(FileName: String; IsVisible: Boolean);

var

TempDoc,NewTempDoc,TempWord,TempEmpty:OleVariant;

begin

WordOpened:=False;

try

TempEmpty := EmptyParam;

TempDoc := EmptyParam;

NewTempDoc := True;

TempWord := FileName;

WordApplication.Visible := IsVisible;

WordApplication.Documents.Open(TempWord,TempEmpty,NewTempDoc,NewTempDoc,TempEmpty,TempEmpty,TempEmpty,TempEmpty,TempEmpty,TempEmpty,TempEmpty,TempEmpty);

PickUp:=PICKUP_NOREAD;

// SetLength(PicPath,15);

PicPath:='D:\word\SubPic\';

except

ShowMessage('打开word文档错误！'+#13#10+'请检查您是否安装了word，或者您开启了防火墙。');

Raise;

end;

WordOpened:=True;

end;

procedure PickUpWord.PaintElevator(Cn: TCanvas; Left, Top, Height,

Width: Integer);

begin

Cn.Rectangle(Left, Top, Left + Width, Top + Height);

Cn.MoveTo(Left, Top);

Cn.LineTo(Left + Width, Top + Height);

Cn.MoveTo(Left, Top + Height);

Cn.LineTo(Left + Width, Top);

end;

procedure PickUpWord.PaintFireFighting(Cn: TCanvas; Left, Top, Height,

Width, Angle: Integer);

var

BeginP, EndP, Tmp, Tmpc, Tmps, Tmp_s:TPoint;

begin

BeginP.X := Left + Width Div 2;

BeginP.Y := Top + Height;

EndP.X := Left + Width Div 2;

EndP.Y := Top;

with Cn do

begin

Tmpc.X := (BeginP.X + EndP.Y) div 2;

TmpC.Y := (BeginP.Y + EndP.Y) div 2;

Tmps := PointRatation(BeginP,Tmpc,Angle);

BeginP := Tmps;

Tmps := PointRatation(Endp,Tmpc,Angle);

Endp := Tmps;

Tmp := GetAPointFromLine(BeginP, EndP, Round(0.28 * Height));

Tmpc := EndP;

Tmps := PointRatation(tmp, tmpc, Angle);

Tmp_s := PointRatation(tmp, tmpc, 360 - Angle); //45 为箭头和线之间的角度

MoveTo(BeginP.X, BeginP.Y);

LineTo(EndP.X, EndP.Y);

moveto(tmp.X, tmP.Y);

Lineto(tmps.x, tmps.y);

moveto(tmP.X, tmP.Y);

Lineto(tmp_s.x, tmp_s.Y);

end;

procedure PickUpWord.PaintFromVtr(FileName: String; Ca: TCanvas);

var

f : File;

i, j, CurrPos, Step, ReadSize, FileL : Integer;

s : String;

ShapeType, DataL, DataLin, Wd1, Wd2, Wd3, Wd4: Word;

D1, D2, D3, D4 : Smallint;

Data, Data1, Data2 ,Data3, Data4: Byte;

c : array[1..127] of Char;

begin

AssignFile(F, FileName); { 变量类型保持和写入文件时使用同样的类型.}

Try

Reset(F,1);

Seek(F,0);

except

ShowMessage('文件打开错误,请重试!');

Exit;

end;

Seek(f, 4);

BlockRead(F, FileL, 4, ReadSize); {Read File Length and set var FileL}

Seek(f, 12);

CurrPos := 12; {shape data start}

Ca.Pen.Color := clBlack;

Ca.Pen.Width := 1;

Ca.Brush.Color := clNone;

while CurrPos < FileL do

begin

BlockRead(F, ShapeType, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

case ShapeType of

$FF01: {65281}

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos); { autoshape图形数据开始处}

j := 1;

While j < DataL do

begin

BlockRead(F,Data,1,ReadSize);

Inc(CurrPos,1);

Seek(F,CurrPos);

BlockRead(F,D1,2,ReadSize);

Inc(CurrPos,2);

Seek(F,CurrPos);

BlockRead(F,D2,2,ReadSize);

Inc(CurrPos,2);

Seek(F,CurrPos);

BlockRead(F,D3,2,ReadSize);

Inc(CurrPos,2);

Seek(F,CurrPos);

BlockRead(F,D4,2,ReadSize);

Inc(CurrPos,2);

Seek(F,CurrPos);

if Data = 1 then

Ca.Rectangle(D1, D2, D1 + D4, D2 + D3)

else Ca.Ellipse(D1, D2, D1 + D4, D2 + D3);

Inc(j,9);

end;

$FF05:

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos); { FreeForm图形数据开始处}

j := 1;

while j < DataL do

begin

BlockRead(F, DataLin, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, Data2, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, Data3, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, Data4, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F, CurrPos);

Ca.Pen.Color := Data2;

Ca.Brush.Color := Data3;

Ca.Pen.Width := Data4;

Step := 5;

BlockRead(F, D1, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.MoveTo(D1, D2);

while Step < DataLin do

begin

BlockRead(F, D1, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.LineTo(D1, D2);

Inc(Step, 4);

end;

Inc(j, DataLin + 5);

end;

$FF55:

begin // FreeForm图形顶点数小于70的数据开始处

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

j := 1;

while j < DataL do

begin

BlockRead(F, Wd1, 2, ReadSize); {Left}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, Wd2, 2, ReadSize); {Top}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, Wd3, 2, ReadSize); {Height}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, Wd4, 2, ReadSize); {width}

Inc(CurrPos, 2);

Seek(F, CurrPos);

PickUpForm.PaintWaterSource(Ca, Wd1, Wd2, Wd3, Wd4);

Inc(j, 8);

end;

$FF06:

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

j := 1;

Ca.Pen.Width := 1;

While j < DataL do

begin

BlockRead(F, Data, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F,CurrPos);

BlockRead(F, D1, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F,CurrPos);

BlockRead(F, D2, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F,CurrPos);

BlockRead(F, D3, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F,CurrPos);

BlockRead(F, D4, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F,CurrPos);

case Data of

0: ;

begin

PaintLadder(Ca, D1, D2, D4, D3, True);

end;

2: PaintLadder(Ca, D1, D2, D3, D4, False);

3: PaintElevator(Ca, D1, D2, D3, D4);

4: PaintWaterSource(Ca, D1, D2, D1 + D4, D2 + D3);

5: PaintNorth(Ca, D1, D2, D3, D4);

else begin

PaintFireFighting(Ca, D1, D2, D3, D4, Data - 10);

end;

Inc(j, 9);

end;

$FF09: {65289}

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.Pen.Width := 1;

j := 1;

while j < DataL do

begin

BlockRead(F, D1, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D3, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D4, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.MoveTo(D1, D2);

Ca.LineTo(D3, D4);

Inc(j, 8);

end;

$FF99:

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

j := 1;

while j < DataL do

begin

BlockRead(F, Data1, 1, ReadSize); {data1 is weight}

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, Data2, 1, ReadSize); {data2 is color}

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, D1, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D3, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D4, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.Pen.Width := Data1;

Ca.Pen.Color := TColor(Data2);

PickUpForm.PaintArrowHeadLine(Ca, Point(D1, D2), Point(D3, D4));

Inc(j, 10);

end;

$FF0D: {pic}

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

j := 1;

while j < DataL do

begin

BlockRead(F, D1, 2);

Inc(CurrPos, 2);

Seek(F, CurrPos); {待处理}

BlockRead(F, D2, 2);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D3, 2);

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D4, 2);

Inc(CurrPos, 2);

Seek(F, CurrPos);

Inc(j, 9);

end;

$FF11: {textbox}

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

DataLin := 0;

while DataLin < DataL do

begin

FillChar(C,SizeOf(C),0);

BlockRead(F, Data, 1, ReadSize); {文本长度}

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, C, Data, ReadSize); {取出文本内容}

Inc(CurrPos, Data);

Seek(F, CurrPos);

BlockRead(F, Data1, 1, ReadSize); {取出文本方向}

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, Data2, 1, ReadSize); {取出文本字体}

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, D1, 2, ReadSize); {取出文本left}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize); {取出文本top}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D3, 2, ReadSize); {取出文本height}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D4, 2, ReadSize); {取出文本width}

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.Brush.Color := clBtnFace;

Ca.Pen.Color := clBlack;

if Data1 = 1 then

Ca.TextOut(D1,D2,c)

else begin

i:=1;

while i < Data do

begin {绘制垂直的文本框}

if byte(c[i])>128 then

begin

Ca.TextOut(D1,D2 + i* (Data2-5),C[i]+C[i+1]);

inc(i);

end;

inc(i);

end;

Inc(DataLin, 11 + Data);

end;

$FF0F: {artword}

begin

BlockRead(F, DataL, 2, ReadSize);

Inc(CurrPos, 2);

Seek(F, CurrPos);

j := 1;

while j < DataL do

begin

FillChar(c,SizeOf(c),0);

BlockRead(F, Data, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F, CurrPos); {}

BlockRead(F, c, Data, ReadSize);

Inc(CurrPos, Data);

Seek(F, CurrPos);

BlockRead(F, Data1, 1, ReadSize);

Inc(CurrPos, 1);

Seek(F, CurrPos);

BlockRead(F, D1, 2, ReadSize); {取出艺术字left}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D2, 2, ReadSize); {取出艺术字top}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D3, 2, ReadSize); {取出艺术字height}

Inc(CurrPos, 2);

Seek(F, CurrPos);

BlockRead(F, D4, 2, ReadSize); {取出艺术字width}

Inc(CurrPos, 2);

Seek(F, CurrPos);

Ca.Brush.Color := clBtnFace;

Ca.Pen.Color := clBlack;

Ca.TextOut(D1, D2, C);

Inc(j,10 + Data);

end;

$FF03: {纯文本部分}

begin

end;

$FFFF: {end}

begin

end

else

Inc(CurrPos,2);

end;

procedure PickUpWord.PaintLadder(Cn: TCanvas; Left, Top, Height,

Width: Integer; HorV: Boolean);

var

i : integer;

begin

if HorV then

With Cn do

begin

MoveTo(Left, Top);

LineTo(Left + Width, Top);

MoveTo(Left, Top + Height);

LineTo(Left + Width, Top + Height); {两条平行线}

for i:= 1 to 9 do

begin

MoveTo(Left + i * Width div 10, Top);

LineTo(Left + i * Width div 10, Top + Height);

end;

Rectangle(Left + Round(Width/12), Top + Round(4 * Height/9), Left + Round(1 - 1/12) * Width, Top + Round(5 * Height/9));

end

else

With Cn do

begin

MoveTo(Left, Top);

LineTo(Left, Top + Height);

MoveTo(Left + Width , Top);

LineTo(Left + Width, Top + Height); {两条平行线}

for i:= 1 to 9 do

begin

MoveTo(Left, Top + i * Height div 10);

LineTo(Left + Width, Top + i * Height div 10);

end;

Rectangle(Left + Round(4 * Width/9), Top + Round(Height/12), Left + Round(5 * Width/9), Top + Round(1 - 1/12) * Height);

end;

procedure PickUpWord.PaintNorth(Cn: TCanvas; Left, Top, Height,

Width: integer);

begin

Cn.Brush.Color := clBtnFace;

Cn.TextOut(Left,Top,'北');

end;

procedure PickUpWord.PaintWaterSource(Cnv: TCanvas; Left, Top, Right,

Bottom: Word);

begin

Cnv.Ellipse(Left, Top, Right, Bottom);

Cnv.Brush.Color:=clred;

Cnv.Pie(Left,Top,Right,Bottom,(Right + Left) div 2,Bottom,(Left + Right) div 2,Top); {扇形部分}

Cnv.Brush.Color := clBtnFace;

end;

function PickUpWord.PointRatation(Src,Center: TPoint; Angle: Single): TPoint;

const

pin=Pi/180;

begin

Result.X:= Round(Center.X+(Src.X-Center.X)*cos(Angle*Pin)-(Src.Y-Center.Y)*Sin(Angle*Pin));

{ x0+(x-x0)cos@-(y-y0)sin@ }

Result.Y:= Round(Center.Y+(Src.X-Center.X)*Sin(Angle*Pin)+(Src.Y-Center.Y)*Cos(Angle*Pin));

{ y0+(x-x0)sin(θ)+(y-y0)cos(θ)}

end;

procedure PickUpWord.SaveDataInVtr(FileName: String);

var

s : array[1..4] of Char;

C : array[1..127] of Char;

i,j,frfm,tb,at,tt:Smallint;

AllLength:Integer;

ShapeType,ShapeL, LineNormalL,FreeFormNormalL, FreeFormNormCount, LineNormCount,PicSrcNameL, GroupDL:Word;

TextL,F_L:Byte;

begin

AssignFile(Ftxt,FileName);

try

Reset(Ftxt,1);

except

On EInOutError do

begin

try

if FileExists(FileName) = False then

ReWrite(Ftxt, 1)

else

MessageDlg('文件不能打开', mtWarning, [mbOK], 0);

except

On EInOutError do

MessageDlg('文件不能创建', mtWarning, [mbOK], 0);

end;

{open file}

try

s:='vtr ';

BlockWrite(Ftxt, s, 4); {文件头(4字节)}

except

on e:Exception do

ShowMessage('写入异常:'+#10#13+e.Message);

end;

frfm := 0;

tb := 0;

at := 0;

{ ****** 获得所有数据的长度 ******** }

AllLength := 14; // 文件头和尾的长度. 详见设计文档<矢量图形开发综述文档>

if AutoShapeArray <> nil then

AllLength := AllLength + AutoShapeCount * 9 + 4;

///

if FreeFormArray <> nil then

begin

SortArrayFreeForm(FreeFormArray); // 按图形定点数升序排序

for i := Low(FreeFormArray) to High(FreeFormArray) do // 处理顶点数小于70的多边形,

frfm := frfm + FreeFormArray[i].Count;

FreeFormNormCount := FreeFormCount;

AllLength:=AllLength + 4 * (frfm + 1) + 5 * FreeFormNormCount;

end;

///

if GroupArray <> nil then {组合图形数据长度}

AllLength := AllLength + GroupCount * 9 + 4;

if LineArray <> nil then

begin

SortArray(LineArray);

for i:=Low(LineArray) to High(LineArray) do

if LineArray[i].EndArrowheadStyle = 1 then

LineNormCount := i // 从数组中取出末尾有箭头的直线的开始点.

else break;

Inc(LineNormCount);

LineNormalL:= LineNormCount * 8 + 4;

AllLength := AllLength + LineNormalL;

if LineNormCount <> LineCount then

AllLength:= AllLength + (LineCount-LineNormCount) * 10 + 4;

end;

/////////////////

if PictureArray <> nil then

begin

AllLength:=AllLength + PictureCount * 9 + 5;

AllLength:=AllLength + Length(PicPath);

for i:=Low(PictureArray) to High(PictureArray) do

PicSrcNameL:=PicSrcNameL + Length(PictureArray[i].SourceName);

AllLength := AllLength + PicSrcNameL;

end;

/// pic data length

if TextFrameArray <> nil then

begin

AllLength := AllLength + 4 + 11 * TextBoxCount;

for i:=Low(TextFrameArray) to High(TextFrameArray) do

tb:=tb+Length(TextFrameArray[i].Text);

AllLength := AllLength + tb;

end;

/// text frame data Length

if TextEffectArray <> nil then

begin

AllLength := AllLength + 4 + 10 * ArtWordCount;

for i:=Low(TextEffectArray) to High(TextEffectArray) do

at:=at+Length(TextEffectArray[i].Text);

AllLength := AllLength + at;

end;

// art word data length

{如果涉及到纯文本, 在此处加入获得纯文本长度代码}

/////////////////////////////////////////////////////////////////////////////

try

BlockWrite(Ftxt,AllLength,4); // 文件的总长度； (4字节)

ShowMessage('file Length:'+IntToStr(AllLength));{}

/////////////////////////////////////////////////////////////////////////////////////

s:='0.91'; // 文件版本信息: (4字节)

BlockWrite(Ftxt,s,4);

if AutoShapeArray <> nil then

begin

ShapeType:=$FF01; // 自动图形头标识 (2字节)

BlockWrite(Ftxt,ShapeType, 2);

ShapeL:= AutoShapeCount * 9 ;

BlockWrite(Ftxt,ShapeL, 2); // 自动图形的总数据长度 (2字节)

for i:=Low(AutoShapeArray) to High(AutoShapeArray) do

begin

BlockWrite(Ftxt,AutoShapeArray[i].Style,1); // 自动图形类型 (1字节)

BlockWrite(Ftxt,AutoShapeArray[i].Left,2); // 图形位置以下三行同 (每个都是2字节)

BlockWrite(Ftxt,AutoShapeArray[i].Top,2);

BlockWrite(Ftxt,AutoShapeArray[i].Height,2);

BlockWrite(Ftxt,AutoShapeArray[i].Width,2);

end;

if FreeFormArray<>nil then

begin

ShapeType:= $FF05 ;

BlockWrite(Ftxt,ShapeType, 2); // 任意多边形头标识 (2字节)

FreeFormNormalL:=4*frfm + FreeFormCount * 5;

BlockWrite(Ftxt,FreeFormNormalL, 2); // 任意多边形数据长度 (2字节)

for i:=Low(FreeFormArray) to High(FreeFormArray) do

begin

FreeFormNormalL:=FreeFormArray[i].Count * 4;

BlockWrite(Ftxt,FreeFormNormalL,2); // 任意多边形的每个图形的顶点数据长度 (2字节)

BlockWrite(Ftxt,FreeFormArray[i].LineColor,1); // 任意多边形画笔颜色 (1字节)

BlockWrite(Ftxt,FreeFormArray[i].FillColor,1); // 任意多边形填充颜色 (1字节)

BlockWrite(Ftxt,FreeFormArray[i].Weight,1); // 任意多边形画笔宽度 (1字节)

for j:=Low(FreeFormArray[i].Nodes) to High(FreeFormArray[i].Nodes) do

begin

BlockWrite(Ftxt,Smallint(FreeFormArray[i].Nodes[j].x),2);//任意多边形每个顶点的坐标 (每个2字节)

BlockWrite(Ftxt,Smallint(FreeFormArray[i].Nodes[j].y),2);

end;

if GroupArray <> nil then

begin

ShapeType:= $FF06 ;

BlockWrite(Ftxt,ShapeType, 2); // 线段数据头标识 (2字节)

GroupDL := GroupCount * 9;

BlockWrite(Ftxt,GroupDL, 2);

for i := Low(GroupArray) to High(GroupArray) do

begin

BlockWrite(Ftxt, GroupArray[i].Style, 1);

BlockWrite(Ftxt, GroupArray[i].Left, 2);

BlockWrite(Ftxt, GroupArray[i].Top, 2);

BlockWrite(Ftxt, GroupArray[i].Height, 2);

BlockWrite(Ftxt, GroupArray[i].Width, 2);

end;

if LineArray <> nil then

begin // 按线段的末端风格升序排序

ShapeType:= $FF09 ;

BlockWrite(Ftxt,ShapeType, 2); // 线段数据头标识 (2字节)

LineNormalL := LineNormalL - 4;

BlockWrite(Ftxt,LineNormalL, 2); // 无末端风格的线段数据长度 (2字节)

for i:=Low(LineArray) to LineNormCount-1 do

begin

BlockWrite(Ftxt,Smallint(lineArray[i].BeginPoint.X),2);

BlockWrite(Ftxt,Smallint(lineArray[i].BeginPoint.y),2);

BlockWrite(Ftxt,Smallint(lineArray[i].EndPoint.X),2);

BlockWrite(Ftxt,Smallint(lineArray[i].endPoint.y),2);

end;

if LineNormCount <> LineCount then

begin

ShapeType:= $FF99;

BlockWrite(Ftxt,ShapeType,2); // 有末端风格线段的数据头标识 (2字节)

LineNormalL := (LineCount - LineNormCount)*10;

BlockWrite(Ftxt,LineNormalL,2); // 带末端风格线段数据长度 (2字节)

for i:=LineNormCount to High(LineArray) do

begin

BlockWrite(Ftxt,LineArray[i].Weight,1); // 带末端风格线段画笔宽度 (1字节)

BlockWrite(Ftxt,LineArray[i].Color,1); // 带末端风格线段画笔颜色 (1字节)

BlockWrite(Ftxt,Smallint(lineArray[i].BeginPoint.X),2); // 带末端风格线段坐标 (每个2字节)

BlockWrite(Ftxt,Smallint(lineArray[i].BeginPoint.y),2);

BlockWrite(Ftxt,Smallint(lineArray[i].EndPoint.X),2);

BlockWrite(Ftxt,Smallint(lineArray[i].endPoint.y),2);

end;

/////////////

if PictureArray<> nil then

begin

ShapeType:= $FF0D ;

BlockWrite(Ftxt,ShapeType,2); // 图片头标识 (2字节)

ShapeL:= PictureCount*9+Length(PicPath);

BlockWrite(Ftxt,ShapeL,2); // 图片数据长度 (2字节)

for i:=Low(PictureArray) to High(PictureArray) do

begin

TextL:=Length(PictureArray[i].SourceName);

BlockWrite(Ftxt,TextL,1); // 每个图片的源文件名称长度 (1字节)

BlockWrite(Ftxt,PictureArray[i].SourceName,Length(PictureArray[i].SourceName)); //每个图片的源文件名称 (长度可变)

BlockWrite(Ftxt,PictureArray[i].Left,2); //图片位置及大小 (每个2字节)

BlockWrite(Ftxt,PictureArray[i].Top,2);

BlockWrite(Ftxt,PictureArray[i].Height,2);

BlockWrite(Ftxt,PictureArray[i].Width,2);

end;

if TextFrameArray <> nil then

begin

ShapeType:= $FF11 ;

BlockWrite(Ftxt, ShapeType, 2); // 文本框头标识 (2字节)

ShapeL:= TextBoxCount * 11 + tb;

BlockWrite(Ftxt, ShapeL, 2); // 文本框文件长度(２字节)

for i := Low(TextFrameArray) to High(TextFrameArray) do

begin

TextL := Length(TextFrameArray[i].Text);

CopyMemory(@c[1],@(TextFrameArray[i].Text[1]),Textl);

BlockWrite(Ftxt, TextL, 1); // 文本框包含文本的长度(1字节)

BlockWrite(Ftxt, C, TextL); // 文本框具体内容 (长度可变) TextFrameArray[i].Text Length(TextFrameArray[i].Text)

BlockWrite(Ftxt, TextFrameArray[i].Orientation, 1); // 文本框走向 (1字节)

BlockWrite(Ftxt, TextFrameArray[i].FontSize, 1); // 文本框字体大小(1字节)

BlockWrite(Ftxt, TextFrameArray[i].Left, 2); // 文本框位置及大小(每个2字节)

BlockWrite(Ftxt, TextFrameArray[i].Top, 2);

BlockWrite(Ftxt, TextFrameArray[i].Height, 2);

BlockWrite(Ftxt, TextFrameArray[i].Width, 2);

end;

if TextEffectArray <> nil then

begin

ShapeType := $FF0F ;

BlockWrite(Ftxt, ShapeType, 2); //艺术字头标识(2字节)

ShapeL := ArtWordCount * 10 + at;

BlockWrite(Ftxt,ShapeL, 2); //艺术字数据长度(2字节)

for i := Low(TextEffectArray) to High(TextEffectArray) do

begin

TextL := Length(TextEffectArray[i].Text) ;

CopyMemory(@c[1],@(TextEffectArray[i].Text[1]),TextL);

BlockWrite(Ftxt, TextL, 1); //艺术字包含内容长度(1字节)

BlockWrite(Ftxt, c, TextL); // 艺术字具体内容(可变长度) Length(TextEffectArray[i].Text)

BlockWrite(Ftxt, TextEffectArray[i].FontSize, 1); //艺术字字体大小 (1字节)

BlockWrite(Ftxt, TextEffectArray[i].Left, 2); //艺术字位置及大小(每个两个字节)

BlockWrite(Ftxt, TextEffectArray[i].Top, 2);

BlockWrite(Ftxt, TextEffectArray[i].Height, 2);

BlockWrite(Ftxt, TextEffectArray[i].Width, 2);

end;

ShapeType:=$FFFF;

BlockWrite(Ftxt,ShapeType,2); //文件结尾符号(2个字节)

except

on e:Exception do

ShowMessage('写入文件异常'+#10#13+e.Message);

end;

CloseFile(Ftxt);

//ShowMessage('文件保存完毕！');

end;

procedure PickUpWord.SortArray(var Sa: array of TLine);

procedure QuickSort(var Sa: array of TLine; iLo, iHi: Integer);

var

Lo, Hi, Mid: Integer; T : TLine;

begin

Lo := iLo;

Hi := iHi;

Mid := Sa[(Lo + Hi) div 2].EndArrowheadStyle;

repeat

while Sa[Lo].EndArrowheadStyle < Mid do Inc(Lo);

while Sa[Hi].EndArrowheadStyle > Mid do Dec(Hi);

if Lo <= Hi then

begin

T := Sa[Lo];

Sa[Lo] := Sa[Hi];

Sa[Hi] := T;

Inc(Lo);

Dec(Hi);

end;

until Lo > Hi;

if Hi > iLo then QuickSort(Sa, iLo, Hi);

if Lo < iHi then QuickSort(Sa, Lo, iHi);

end;

begin

QuickSort(Sa, Low(Sa), High(Sa));

end;

procedure PickUpWord.SortArrayFreeForm(var Sa: array of FreeForm);

procedure QuickSort(var Sa: array of FreeForm; iLo, iHi: Integer);

var

Lo, Hi, Mid: Integer; T : FreeForm;

begin

Lo := iLo;

Hi := iHi;

Mid := Sa[(Lo + Hi) div 2].Count;

repeat

while Sa[Lo].Count < Mid do Inc(Lo);

while Sa[Hi].Count > Mid do Dec(Hi);

if Lo <= Hi then

begin

T := Sa[Lo];

Sa[Lo] := Sa[Hi];

Sa[Hi] := T;

Inc(Lo);

Dec(Hi);

end;

until Lo > Hi;

if Hi > iLo then QuickSort(Sa, iLo, Hi);

if Lo < iHi then QuickSort(Sa, Lo, iHi);

end;

begin

QuickSort(Sa, Low(Sa), High(Sa));

end;

end.

/////////////////////////////////////////////////////////////////////////////////

unit PickUpPas;

interface

uses

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

Dialogs, StdCtrls, ExtCtrls, OleCtnrs,dbtables,db, OleServer, Word2000,

office2000, math, ComCtrls, Grids, DBGrids,WordApp,VarConv, Types,DSIntf,typinfo,

jpeg;

type

TPickUpForm = class(TForm)

PageControl1: TPageControl;

TabSheet1: TTabSheet;

TabSheet2: TTabSheet;

TabSheet3: TTabSheet;

Ledt_WordName: TLabeledEdit;

BtnWordFile: TButton;

Ledt_SvFile: TLabeledEdit;

BtnLastPath: TButton;

Grb_pickuped: TGroupBox;

Rb_Paint: TRadioButton;

Rb_SaveAndPaint: TRadioButton;

Rb_transmit: TRadioButton;

GroupBox1: TGroupBox;

Chkb_Line: TCheckBox;

Chkb_Freeform: TCheckBox;

Chkb_Group: TCheckBox;

Chkb_Pic: TCheckBox;

Chkb_ArtWord: TCheckBox;

Chkb_TextFrame: TCheckBox;

Chb_Autoshap: TCheckBox;

Grb_setPickup: TGroupBox;

Chkb_IsVisible: TCheckBox;

Ledt_ImgPath: TLabeledEdit;

BtnImgPath: TButton;

Chkb_Closeword: TCheckBox;

Stsb: TStatusBar;

BtnExc: TButton;

BtnCancel: TButton;

BtnHelp: TButton;

WordApplication1: TWordApplication;

Memo1: TMemo;

Btn_Paint: TButton;

Button6: TButton;

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

procedure Btn_PaintClick(Sender: TObject);

procedure PaintBox1Paint(Sender: TObject);

procedure FormKeyPress(Sender: TObject; var Key: Char);

procedure BtnExcClick(Sender: TObject);

procedure Button6Click(Sender: TObject);

procedure Chkb_LineClick(Sender: TObject);

procedure BtnWordFileClick(Sender: TObject);

procedure BtnImgPathClick(Sender: TObject);

procedure BtnCancelClick(Sender: TObject);

procedure BtnHelpClick(Sender: TObject);

procedure BtnLastPathClick(Sender: TObject);

private

{ Private declarations }

ViewId:SHORT;

procedure ControlView(id:SHORT);

procedure BtnEnab;

procedure PaintAutoShape(Ta:array of TAutoShape);

procedure PaintLine(Tl:array of TLine);

procedure PaintTextBox(Tb:Array of TextFrame);

procedure PaintArtWord(Te:Array of TextEffect);

procedure PaintFreeForm(Tf:Array of FreeForm);

procedure PaintPicture(Pc:Array of TPic);

procedure DeleteElseGroup;

procedure ShowUnVisible;

public

{ Public declarations }

function GetAPointFromLine(BeginP,EndP:Tpoint;L:Integer): Tpoint; ///从一条直线(提供坐标得两个点)获得距末端一定长度的点的坐标

function PointRatation(Src,Center: TPoint; Angle: Single): TPoint; //一点关于另一点的旋转,返回旋转后的点坐标

procedure PaintWaterSource(Cnv:TCanvas; Left,Top,Right,Bottom:Word);

Procedure PaintArrowHeadLine(Cnv:TCanvas; BeginP,EndP:Tpoint;Angle:Single=45); // 绘制一条带箭头的直线,Angle为箭头角度,默认为45度.

end;

var

PickUpForm: TPickUpForm;

MyPickup:pickupword;

implementation

uses comobj, VarUtils, WaitFor, PaintShape;

{$R *.dfm}

procedure TPickUpForm.FormCloseQuery(Sender: TObject; var CanClose: Boolean);

begin

if MyPickup <> nil then

MyPickup.Free;

end;

procedure TPickUpForm.Btn_PaintClick(Sender: TObject);

begin

// PaintBox1Paint(nil);

If Trim(Ledt_SvFile.Text) = '' then exit;

Frm_Paint:=TFrm_Paint.Create(nil);

{Frm_Paint.Height:=MyPickup.PageHeight;

Frm_Paint.Width:=MyPickup.PageWidth; }

Frm_Paint.ShowModal;

Frm_Paint.Free;

end;

procedure TPickUpForm.PaintBox1Paint(Sender: TObject);

begin

if MyPickup = nil then exit;

if MyPickup.PickUp <> PICKUP_READED then Exit;

if MyPickup.PickUpSts[1] = 3 then

PaintAutoShape(MyPickup.AutoShapeArray);

if MyPickup.PickUpSts[17] = 3 then

PaintTextBox(MyPickup.TextFrameArray);

if MyPickup.PickUpSts[15] = 3 then

PaintArtWord(MyPickup.TextEffectArray);

if MyPickup.PickUpSts[9] = 3 then

PaintLine(MyPickup.LineArray);

if MyPickup.PickUpSts[5] = 3 then

PaintFreeForm(MyPickup.FreeFormArray);

if MyPickup.PickUpSts[13]= 3 then

PaintPicture(MyPickup.PictureArray); {此处代码可以改进}

end;

procedure TPickUpForm.ControlView(id: SHORT);

var i:integer;

begin

for i:=0 to Componentcount-1 do

if components[i].Tag>0 then

if Components[i].Tag=id then

begin

if Components[i] is TControl then

TControl(Components[i]).Visible:=true;

end

else if Components[i] is TControl then

Tcontrol(Components[i]).Visible:=false;

end;

procedure TPickUpForm.FormKeyPress(Sender: TObject; var Key: Char);

begin

if Key = #27 then

Close;

end;

procedure TPickUpForm.BtnExcClick(Sender: TObject);

var

i:Word;

begin

try

for i:= 0 to ComponentCount-1 do

if Components[i] is TCheckBox then

if TCheckBox(Components[i]).Checked then

MyPickup.PickUpSts[TCheckBox(Components[i]).Tag]:= 2;

try

Frm_WaitFor:=TFrm_WaitFor.Create(nil);

Self.Hide;

Frm_WaitFor.Show;

MyPickup.GetGraphicCount; {获取要提取的图形类别}

except

On E: Exception do

ShowMessage(E.Message);

end;

Application.ProcessMessages;

MyPickup.GetGraphic;

{ if MyPickup <> nil then

begin

PaintBox1.Width:= Round(MyPickup.WordApplication.ActiveDocument.PageSetup.PageWidth);

PaintBox1.Height:= Round(MyPickup.WordApplication.ActiveDocument.PageSetup.PageHeight);

end; }

// PaintBox1Paint(PaintBox1);

MyPickup.SaveDataInVtr(Ledt_SvFile.Text);

Self.Show;

Frm_WaitFor.Free;

except

on e:exception do

showmessage(e.Message);

end;

procedure TPickUpForm.Button6Click(Sender: TObject);

begin

MyPickup:=PickUpWord.Create;

try

MyPickup.OpenWord(Ledt_WordName.Text,Chkb_IsVisible.Checked);

except

Raise;

Exit;

end;

Caption:=Ledt_WordName.Text+'-----word文件已经打开';

BtnEnab;

end;

procedure TPickUpForm.BtnEnab;

begin

BtnExc.Enabled:= not BtnExc.Enabled;

end;

procedure TPickUpForm.PaintLine(Tl: array of TLine);

var i:word;

begin

if high(Tl)-low(tl)= 0 then exit;

for i:=low(tl) to high(tl) do

begin

with {paintbox1.}Canvas do

begin

MoveTo(tl[i].BeginPoint.X,tl[i].BeginPoint.Y);

LineTo(tl[i].EndPoint.X,tl[i].EndPoint.Y);

end;

procedure TPickUpForm.PaintTextBox(tb:Array of TextFrame);

var

i:word;

rec:TRect;

begin

if (high(tb)-low(tb))= 0 then exit;

for i:=low(tb) to high(tb) do

begin

rec.Left:= tb[i].Left;

rec.Top:= tb[i].Top;

rec.Right:=tb[i].Left+tb[i].Width-1;

rec.Bottom:=tb[i].Top+tb[i].Height;

with {PaintBox1.}Canvas do

TextRect(rec,tb[i].Left,tb[i].Top,tb[i].Text);

end;

procedure TPickUpForm.PaintArtWord(Te: array of TextEffect);

var

i:word;

begin

if high(te)-low(te) = 0 then exit;

for i:=low(te) to high(te) do

begin

with {PaintBox1.}Canvas do

TextOut(te[i].Left,te[i].Top,te[i].Text);

end;

procedure TPickUpForm.Chkb_LineClick(Sender: TObject);

begin

if MyPickup = nil then exit;

with Sender as TCheckBox do

begin

if TCheckBox(Sender).Checked then

MyPickup.PickUpSts[TCheckBox(Sender).Tag]:= 2;

end;

procedure TPickUpForm.PaintFreeForm(Tf: array of FreeForm);

var

Line,Node: Word;

begin

with {PaintBox1.}Canvas do

for Line:= Low(Tf) to high(Tf) do

begin

Brush.Color:=Tcolor(Tf[Line].FillColor); //

Pen.Width:=Tf[Line].Weight;

Pen.Color:=Tcolor(Tf[line].LineColor);

MoveTo(Tf[Line].Nodes[Low(Tf[Line].Nodes)].X,Tf[Line].Nodes[Low(Tf[Line].Nodes)].Y);

for Node:= Low(Tf[Line].Nodes) to High(Tf[Line].Nodes) do

begin

LineTo(Tf[Line].Nodes[Node].X,Tf[Line].Nodes[Node].Y);

end;

procedure TPickUpForm.PaintAutoShape(Ta: array of TAutoShape);

var

i:Word;

begin

for i:=Low(Ta) to High(Ta) do

begin

if Ta[i].Style = $00000001 then

{PaintBox1.}Canvas.Rectangle(Ta[i].Left,Ta[i].Top,Ta[i].Left+Ta[i].Width,Ta[i].Top+Ta[i].Height)

else {PaintBox1.}Canvas.Ellipse(Ta[i].Left,Ta[i].Top,Ta[i].Left+Ta[i].Width,Ta[i].Top+Ta[i].Height);

end;

procedure TPickUpForm.PaintPicture(Pc: array of TPic);

var

i,j:Word;

TmpPc:array of TImage;

begin

SetLength(TmpPc,Length(Pc));

J:=Low(Pc)-0;

for i:=Low(Pc) to High(Pc) do

begin

TmpPc[i-j]:=TImage.Create(nil);

TmpPc[i-j].Parent:=Self;

TmpPc[i-j].BringToFront;

TmpPc[i-j].Left:=Pc[i].Left;

TmpPc[i-j].Top:= Pc[i].Top;

try // 'D:\word\SubPic\p1.jpg'

TmpPc[i-j].Picture.LoadFromFile(MyPickup.PicPath+Pc[i].SourceName);

except

Raise;

end;

procedure TPickUpForm.DeleteElseGroup;

var i,j:integer;

o:OleVariant;

begin

if MyPickup<> nil then

begin

j:=MyPickup.WordApplication.ActiveDocument.Shapes.count;

for i:=1 to j do

begin

o:=i;

if MyPickup.WordApplication.ActiveDocument.Shapes.Item(o).Type<>6 then

MyPickup.WordApplication.ActiveDocument.Shapes.Item(o).Delete;

end;

procedure TPickUpForm.ShowUnVisible;

var i,j:integer;

o:OleVariant;

begin

if MyPickup<> nil then

begin

j:=MyPickup.WordApplication.ActiveDocument.Shapes.count;

for i:=1 to j do

begin

o:=i;

if (MyPickup.WordApplication.ActiveDocument.Shapes.Item(o).Visible=msoFalse) then

//Memo1.lines.Add(vartostr(MyPickup.WordApplication.ActiveDocument.Shapes.Item(o).name));

end;

{88384190 }

procedure TPickUpForm.BtnWordFileClick(Sender: TObject);

var

OpDlg:TOpenDialog;

begin

OpDlg:=TOpenDialog.Create(nil);

OpDlg.Filter:='Word files (*.Doc)|*.Doc';

if OpDlg.Execute then

begin

Ledt_WordName.Text:=OpDlg.FileName;

Ledt_SvFile.Text:=Ledt_WordName.Text;

while pos('\',Ledt_SvFile.Text)<>0 do

Ledt_SvFile.Text:=copy(Ledt_SvFile.Text,pos('\',Ledt_SvFile.Text)+1,Length(Ledt_SvFile.Text));

Ledt_SvFile.Text:=copy(Ledt_SvFile.Text,1,Length(Ledt_SvFile.Text)-4)+'.vtr';

end;

OpDlg.Free;

end;

procedure TPickUpForm.BtnImgPathClick(Sender: TObject);

var

SvDlg:TOpenDialog;

begin

SvDlg:=TSaveDialog.Create(nil);

SvDlg.Title:='打开';

if Ledt_ImgPath.Text='' then

SvDlg.FileName:='tmp'

else SvDlg.FileName:=Ledt_ImgPath.Text;

if SvDlg.Execute then

Ledt_ImgPath.Text:=SvDlg.FileName;

SvDlg.Free;

end;

procedure TPickUpForm.BtnCancelClick(Sender: TObject);

begin

if MyPickup<>nil then

MyPickup.Free;

Application.Terminate;

end;

procedure TPickUpForm.BtnHelpClick(Sender: TObject);

var

i:integer; s:string; ss:Widestring; o, Filename,tmp:olevariant;

j: word; OP:TOpenDialog;

t:array[1..20] of char; f:file;

begin

o:=1;

OP := TOpenDialog.Create(nil);

if not OP.Execute then exit;

MyPickup := PickUpWord.Create;

MyPickup.OpenWord(op.FileName,true);

for i:= 1 to WordApplication1.Documents.Count do

begin

o := i;

Filename:= 'D:\Documents and Settings\Administrator\桌面\'+inttostr(i)+'.doc';

WordApplication1.ActiveDocument.Shapes.Item(o).Name; //Item(o).SaveAs(Filename,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam,EmptyParam);

end;

MyPickup.CloseWord();

MyPickup.Free;

{AssignFile(F,Ledt_SvFile.Text); 变量类型保持和写入文件时使用同样的类型.

Try

Rewrite(F,1);

Seek(F,0);

except

ShowMessage('文件打开错误,请重试!');

Exit;

end;

i:=0;

s:='a中国c人d民ef解放gg';

BlockWrite(f,s,Length(s));

Seek(f,0);

BlockRead(f,ss,Length(s));

showmessage(ss); ShowMessage(IntToStr(filesize(f)));

CloseFile(f); }

end;

function TPickUpForm.GetAPointFromLine(BeginP, EndP: Tpoint;L:Integer): Tpoint;

var

Li:Integer;

begin

Li:=Round(sqrt(sqr(BeginP.X-EndP.x)+Sqr(BeginP.Y-EndP.Y)));

Result.X:= EndP.X-Round((EndP.X-BeginP.X)*L/Li);

Result.Y:= EndP.Y-Round((EndP.Y-BeginP.Y)*L/Li);

end;

procedure TPickUpForm.PaintArrowHeadLine(Cnv:TCanvas; BeginP, EndP: Tpoint;Angle:Single=45);

var

tmp,tmpc ,tmps,tmp_s:Tpoint;

begin

with Cnv do

begin

MoveTo(BeginP.X,BeginP.Y);

LineTo(EndP.X,EndP.Y);

tmp:=GetAPointFromLine(Point(BeginP.X,BeginP.Y),Point(EndP.X,EndP.Y),10);

tmpc:=point(EndP.X,EndP.Y);

tmps:=PointRatation(tmp,tmpc,Angle);

tmp_s:=PointRatation(tmp,tmpc,360-Angle); //45 为箭头和线之间的角度

moveto(EndP.X,EndP.Y);

Lineto(tmps.x,tmps.y);

moveto(EndP.X,EndP.Y);

Lineto(tmp_s.x,tmp_s.Y);

end;

function TPickUpForm.PointRatation(Src,Center: TPoint; Angle: Single): TPoint;

const

pin=Pi/180;

begin

Result.X:= Round(Center.X+(Src.X-Center.X)*cos(Angle*Pin)-(Src.Y-Center.Y)*Sin(Angle*Pin));

{ x0+(x-x0)cos@-(y-y0)sin@ }

Result.Y:= Round(Center.Y+(Src.X-Center.X)*Sin(Angle*Pin)+(Src.Y-Center.Y)*Cos(Angle*Pin));

{ y0+(x-x0)sin(θ)+(y-y0)cos(θ)}

end;

procedure TPickUpForm.PaintWaterSource(Cnv:TCanvas; Left,Top,Right,Bottom:Word);

begin

Cnv.Brush.Color:=clred;

Cnv.Pie(Left,Top,Right,Bottom,(Right+Left) div 2,Bottom,(Bottom+Top) div 2,0);

end;

procedure TPickUpForm.BtnLastPathClick(Sender: TObject);

var

SvDlg:TOpenDialog;

begin

SvDlg:=TSaveDialog.Create(nil);

SvDlg.Title:='打开';

if Ledt_SvFile.Text='' then

SvDlg.FileName:='tmp'

else SvDlg.FileName:=Ledt_SvFile.Text;

if SvDlg.Execute then

Ledt_SvFile.Text:=SvDlg.FileName;

SvDlg.Free;

end;

end.

/////////////////////////////////////////////////////////////////////////////////////

unit PaintShape;

interface

uses

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

Dialogs, ExtCtrls;

type

TFrm_Paint = class(TForm)

PaintBox1: TPaintBox;

procedure PaintBox1Paint(Sender: TObject);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Frm_Paint: TFrm_Paint;

implementation

uses WordApp, PickUpPas;

{$R *.dfm}

procedure TFrm_Paint.PaintBox1Paint(Sender: TObject);

begin

MyPickup.PaintFromVtr(PickUpForm.Ledt_SvFile.Text,PaintBox1.Canvas);

end;

end.

//////////////////////////////////////////////////////////////////////////////////////

unit WaitFor;

interface

uses

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

Dialogs, StdCtrls, Buttons, ExtCtrls, ComCtrls;

type

TFrm_WaitFor = class(TForm)

Lb_Shape: TLabel;

Pb_Pickup: TProgressBar;

Bevel1: TBevel;

Cancel: TBitBtn;

Label1: TLabel;

procedure CancelClick(Sender: TObject);

procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);

private

{ Private declarations }

public

{ Public declarations }

end;

var

Frm_WaitFor: TFrm_WaitFor;

implementation

uses Math, PickUpPas;

{$R *.dfm}

procedure TFrm_WaitFor.CancelClick(Sender: TObject);

begin

if Application.MessageBox('您真的想退出程序嘛?','提示: 图形还没有提取完',MB_OKCANCEL)=idok then

Application.Terminate;

end;

procedure TFrm_WaitFor.FormCloseQuery(Sender: TObject;

var CanClose: Boolean);

begin

CancelClick(nil);

end;

end.

上一篇 »delphi 712 Word 2
下一篇 »Delphi对Word的基本操作

pickup word's shapes for Delphi

相关推荐

Delphi 操作Word怎么控制光标的位置？

DELPHI与WORD怎样连用 急～急～？

ASP.Net 添加 Interop for Word, excel 插件

Delphi对Word一些进阶操作

delphi控制 word的几种方法--转 - westsoft？

Delphi操作Word的方法

Delphi与Ole,Word,Excel,查找与替换等

Delphi与Word之间的融合技术

DELPHI与WORD怎样连用急～急～？