1 unit oleutils;
2
3 { OLE helper functions
4
5 Copyright (C) 2007 Luiz Am�rico Pereira C�mara
6 pascalive@bol.com.br
7
8 This library is free software; you can redistribute it and/or modify it
9 under the terms of the GNU Library General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or (at your
11 option) any later version with the following modification:
12
13 As a special exception, the copyright holders of this library give you
14 permission to link this library with independent modules to produce an
15 executable, regardless of the license terms of these independent modules,and
16 to copy and distribute the resulting executable under terms of your choice,
17 provided that you also meet, for each linked independent module, the terms
18 and conditions of the license of that module. An independent module is a
19 module which is not derived from or based on this library. If you modify
20 this library, you may extend this exception to your version of the library,
21 but you are not obligated to do so. If you do not wish to do so, delete this
22 exception statement from your version.
23
24 This program is distributed in the hope that it will be useful, but WITHOUT
25 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
26 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public License
27 for more details.
28
29 You should have received a copy of the GNU Library General Public License
30 along with this library; if not, write to the Free Software Foundation,
31 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
32 }
33
34
35 //todo: add error handling
36
37 {$mode objfpc}{$H+}
38
39 interface
40 {$ifdef Windows}
41 uses
42 Windows, Classes, SysUtils, ActiveX;
43
44 type
45
46 { TOLEStream }
47
48 TOLEStream = class (TStream)
49 private
50 FSrcStream: IStream;
51 procedure InternalSetSize(NewSize: LARGE_INTEGER);
52 public
53 constructor Create(const Stream: IStream);
Readnull54 function Read(var Buffer; Count: Integer): Integer; override;
Seeknull55 function Seek(Offset: Integer; Origin: Word): Integer; overload; override;
56 procedure SetSize(const NewSize: Int64); override;
57 procedure SetSize(NewSize: Longint); override;
Writenull58 function Write(const Buffer; Count: Integer): Integer; override;
59 end;
60 {$endif}
61 implementation
62 {$ifdef Windows}
63
ErrorStringnull64 function ErrorString(Error: HRESULT): String;
65 begin
66 case Error of
67 E_PENDING: Result:='E_PENDING';
68 S_FALSE: Result:='S_FALSE';
69 STG_E_MEDIUMFULL: Result:='STG_E_MEDIUMFULL';
70 STG_E_ACCESSDENIED: Result:= 'STG_E_ACCESSDENIED';
71 STG_E_CANTSAVE: Result:='STG_E_CANTSAVE';
72 STG_E_INVALIDPOINTER: Result:='STG_E_INVALIDPOINTER';
73 STG_E_REVERTED: Result:='STG_E_REVERTED';
74 STG_E_WRITEFAULT: Result:='STG_E_WRITEFAULT';
Resultnull75 STG_E_INVALIDFUNCTION: Result:='STG_E_INVALIDFUNCTION';
76 else
77 Result:='Unknow error';
78 end;
79
80 end;
81
82 { TOLEStream }
83
84 constructor TOLEStream.Create(const Stream: IStream);
85 begin
86 inherited Create;
87 FSrcStream:=Stream;
88 end;
89
Readnull90 function TOLEStream.Read(var Buffer; Count: Integer): Integer;
91 var
92 Res: HRESULT;
93 begin
94 Res:=FSrcStream.Read(@Buffer, Count, @Result);
95 if Res <> S_OK then
96 Raise Exception.Create('TOLEStream - Error while reading: '+ErrorString(Res));
97 end;
98
TOLEStream.Seeknull99 function TOLEStream.Seek(Offset: Integer; Origin: Word): Integer;
100 var
101 liResult, liOffset : LARGE_INTEGER;
102 Res: HRESULT;
103 begin
104 //soFrom* constants are equal to STREAM_SEEK_* constants. Assume it here
105 liOffset.LowPart:=Offset;
106 liOffset.HighPart:=0;
107 {$if FPC_FULLVERSION >= 30001}
108 Res:=FSrcStream.Seek(QWord(liOffset), Origin, QWord(liResult));
109 {$else}
110 Res:=FSrcStream.Seek(Int64(liOffset), Origin, Int64(liResult));
111 {$endif}
112 Result:=liResult.LowPart;
113 if Res <> S_OK then
114 Raise Exception.Create('TOLEStream - Error while seeking: '+ErrorString(Res));
115 end;
116
117 procedure TOLEStream.SetSize(NewSize: Longint);
118 var
119 liSize: LARGE_INTEGER;
120 begin
121 liSize.LowPart:=NewSize;
122 liSize.HighPart:=0;
123 InternalSetSize(liSize);
124 end;
125
126 procedure TOLEStream.SetSize(const NewSize: Int64);
127 var
128 liSize: LARGE_INTEGER;
129 begin
130 liSize.QuadPart:=NewSize;
131 InternalSetSize(liSize);
132 end;
133
134 procedure TOLEStream.InternalSetSize(NewSize: LARGE_INTEGER);
135 var
136 Res:HRESULT;
137 begin
138 Res:=FSrcStream.SetSize(Int64(NewSize));
139 if Res <> S_OK then
140 Raise Exception.Create('TOLEStream - Error while setting size: '+ErrorString(Res));
141 end;
142
Writenull143 function TOLEStream.Write(const Buffer; Count: Integer): Integer;
144 var
145 Res: HRESULT;
146 begin
147 Res:=FSrcStream.Write(@Buffer,Count,@Result);
148 if Res <> S_OK then
149 Raise Exception.Create('TOLEStream - Error while writing: '+ErrorString(Res));
150 end;
151 {$endif}
152 end.
153
154