pickup word's shapes for Delphi
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;
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
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;
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;
end;
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;
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;
end;
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
1:
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;
5:
begin
TGp[IntIndex-1].Style := GroupStyleWaterSrc;
end;
15:
begin
TGp[IntIndex-1].Style := GroupStyleNorth;
end
else ;
end;
end;
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;
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;
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;
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;
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;
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;
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: ;
1:
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;
end;
Inc(j, 9);
end;
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;
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;
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;
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;
end;
Inc(DataLin, 11 + Data);
end;
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;
end;
$FF03: {纯文本部分}
begin
end;
$FFFF: {end}
begin
end
else
Inc(CurrPos,2);
end;
end;
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;
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;
end;
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;
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;
end;
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;
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;
end;
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;
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;
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;
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;
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;
end;
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;
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;
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;
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;
end;
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;
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;
end;
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;
end;
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;
end;
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;
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.
