-
Notifications
You must be signed in to change notification settings - Fork 4
/
KOLOleRE.pas
489 lines (442 loc) · 13.9 KB
/
KOLOleRE.pas
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
unit KOLOleRE;
{$ifdef fpc}
{$mode delphi}//{$H+}
{$endif}
interface
{$I share.inc}
uses
Windows, Messages, KOL;
type
{$ifdef F_P}
TKOLOleRichEdit = class;
PKOLOleRichEdit = TKOLOleRichEdit;
TKOLOleRichEdit = class(TControl)
{$else}
PKOLOleRichEdit =^TKOLOleRichEdit;
TKOLOleRichEdit = object(TControl)
{$endif}
protected
procedure CreateHandle;
function GetDragOle: boolean;
procedure SetDragOle(d: boolean);
public
destructor Destroy; virtual;
function BitmapToRTF(pict: PBitmap): string;
procedure HideFrames;
property CanDragOle: boolean read GetDragOle write SetDragOle;
end;
function NewOLERichEdit( AParent: PControl; Options: TEditOptions ): PKOLOleRichEdit;
implementation
{$B-}
uses
ActiveX,{$ifdef fpc}ComObj{$else}KOLComObj{$endif};
const
{$EXTERNALSYM EM_GETOLEINTERFACE}
EM_GETOLEINTERFACE = WM_USER + 60;
type
_charrange = record
cpMin: Longint;
cpMax: LongInt;
end;
{$EXTERNALSYM _charrange}
TCharRange = _charrange;
CHARRANGE = _charrange;
{$EXTERNALSYM CHARRANGE}
TREOBJECT = packed record
cbStruct: DWORD; // Size of structure
cp: longint; // Character position of object
clsid: TCLSID; // Class ID of object
oleobj: IOleObject; // OLE object interface
stg: IStorage; // Associated storage interface
olesite: IOLEClientSite; // Associated client site interface
sizel: TSize; // Size of object (may be 0,0)
dvaspect: DWORD; // Display aspect to use
dwFlags: DWORD; // Object status flags
dwUser: DWORD; // Dword for user's use
end;
IRichEditOle = interface(IUnknown)
['{00020D00-0000-0000-C000-000000000046}']
function GetClientSite(out lplpolesite: IOLECLIENTSITE): HResult; stdcall;
function GetObjectCount: longint; stdcall;
function GetLinkCount: longint; stdcall;
function GetObject(iob: longint; out reobject: TREOBJECT; dwFlags: DWORD): HRESULT; stdcall;
function InsertObject(const reobject: TREOBJECT): HResult; stdcall;
function ConvertObject(iob: longint; const clsidNew: TCLSID;
lpStrUserTypeNew: POleStr): HRESULT; stdcall;
function ActivateAs(const clsid, clsidAs: TCLSID): HRESULT; stdcall;
function SetHostNames(lpstrContainerApp, lpstrContainerObj: POleStr): HRESULT; stdcall;
function SetLinkAvailable(iob: longint; fAvailable: BOOL): HRESULT; stdcall;
function SetDvaspect(iob: longint; dvaspect: DWORD): HRESULT; stdcall;
function HandsOffStorage(iob: longint): HRESULT; stdcall;
function SaveCompleted(iob: longint; stg: IStorage): HRESULT; stdcall;
function InPlaceDeactivate: HRESULT; stdcall;
function ContextSensitiveHelp(fEnterMode: BOOL): HRESULT; stdcall;
function GetClipboardData(const chrg: TCharRange; reco: DWORD;
out dataobj: IDataObject): HRESULT; stdcall;
function ImportDataObject(dataobj: IDataObject; cf: TClipFormat;
hMetaPict: HGLOBAL): HRESULT; stdcall;
end;
IRichEditOleCallback = interface(IUnknown)
['{00020D03-0000-0000-C000-000000000046}']
function GetNewStorage: IStorage; safecall;
procedure GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo); safecall;
procedure ShowContainerUI(fShow: Bool); safecall;
procedure QueryInsertObject(const ClsID: TCLSID; Stg: IStorage; CP: Longint); safecall;
procedure DeleteObject(OleObj: IOleObject); safecall;
procedure QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reCO: DWord; fReally: Bool; hMetaPict: HGlobal); safecall;
function ContextSensitiveHelp(fEnterMode: Bool): HResult; stdcall;
function GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult; stdcall;
procedure GetDragDropEffect(fDrag: Bool; grfKeyState: DWord;
var dwEffect: DWord); safecall;
procedure GetContextMenu(SelType: Word; OleObj: IOleObject;
const ChRg: TCharRange; var Menu: HMenu); safecall;
end;
TRichEditOleCallback = class(TInterfacedObject, IRichEditOleCallback)
private
FOwner: PKOLOleRichEdit;
protected
{ IRichEditOleCallback }
function GetNewStorage: IStorage; safecall;
procedure GetInPlaceContext(out Frame: IOleInPlaceFrame;
out Doc: IOleInPlaceUIWindow; var FrameInfo: TOleInPlaceFrameInfo); safecall;
procedure ShowContainerUI(fShow: Bool); safecall;
procedure QueryInsertObject(const ClsID: TCLSID; Stg: IStorage; CP: Longint); safecall;
procedure DeleteObject(OleObj: IOleObject); safecall;
procedure QueryAcceptData(dataobj: IDataObject; var cfFormat: TClipFormat;
reCO: DWord; fReally: Bool; hMetaPict: HGlobal); safecall;
function ContextSensitiveHelp(fEnterMode: Bool): HResult; stdcall;
function GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult; stdcall;
procedure GetDragDropEffect(fDrag: Bool; grfKeyState: DWord;
var dwEffect: DWord); safecall;
procedure GetContextMenu(SelType: Word; OleObj: IOleObject;
const ChRg: TCharRange; var Menu: HMenu); safecall;
public
constructor Create(Owner: PKOLOleRichEdit);
destructor Destroy; override;
end;
PData =^TData;
TData = record
IOle: IRichEditOle;
IBck: TRichEditOleCallback;
Drag: boolean;
end;
const
{$EXTERNALSYM EM_SETOLECALLBACK}
EM_SETOLECALLBACK = WM_USER + 70;
function NewOLERichEdit( AParent: PControl; Options: TEditOptions ): PKOLOleRichEdit;
label exit;
var p: PData;
begin
Result := PKOLOleRichEdit(NewRichEdit( AParent, Options ));
new(p);
FillChar(p^, SizeOf(p^), 0);
Result.CustomData := p;
Result.CreateWindow;
Result.CreateHandle;
Result.Perform(EM_GETOLEINTERFACE, 0, integer(@p.IOle));
asm
MOV EDX, offset @@new_call + 4
MOV EDX, [EDX]
ADD EDX, 12
MOV [EBX], EDX
jmp exit
@@new_call:
end;
new( Result, CreateParented( AParent ) );
exit:
end;
{$O-}
destructor TKOLOleRichEdit.Destroy;
var P: PData;
begin
P := CustomData;
P.IBck._Release;
{Dispose(P);
CustomData := nil;}
inherited;
end;
{$O+}
procedure TKOLOleRichEdit.CreateHandle;
var I: IRichEditOleCallback;
T: TRichEditOleCallback;
P: PData;
begin
inherited;
T := TRichEditOleCallback.Create(@Self);
I := T as IRichEditOleCallback;
Perform(em_SetOleCallback, 0, Longint(I));
P := CustomData;
P.IBck := T;
end;
{ TRichEditOleCallback }
constructor TRichEditOleCallback.Create(Owner: PKOLOleRichEdit);
begin
inherited Create;
FOwner := Owner;
end;
destructor TRichEditOleCallback.Destroy;
//var Form: PControl;
begin
{ Form := GetParentForm(FOwner);}
{ if Assigned(Form) and Assigned(Form.OleFormObject) then
(Form.OleFormObject as IOleInPlaceUIWindow).SetActiveObject(nil, nil);}
inherited;
end;
function TRichEditOleCallback.ContextSensitiveHelp(fEnterMode: Bool): HResult;
begin
Result := E_NOTIMPL
end;
procedure TRichEditOleCallback.DeleteObject(OleObj: IOleObject);
begin
OleObj.Close(OLECLOSE_NOSAVE);
end;
function TRichEditOleCallback.GetClipboardData(const ChRg: TCharRange; reCO: DWord; out DataObj: IDataObject): HResult;
begin
Result := E_NOTIMPL;
end;
procedure TRichEditOleCallback.GetContextMenu(SelType: Word;
OleObj: IOleObject; const ChRg: TCharRange; var Menu: HMenu);
begin
Menu := 0
end;
procedure TRichEditOleCallback.GetDragDropEffect(fDrag: Bool;
grfKeyState: DWord; var dwEffect: DWord);
var p: PData;
begin
if fOwner <> nil then begin
if fOwner.CustomData <> nil then begin
p := fOwner.CustomData;
if not p.Drag then begin
dwEffect := 0;
end;
end;
end;
end;
procedure TRichEditOleCallback.GetInPlaceContext(
out Frame: IOleInPlaceFrame; out Doc: IOleInPlaceUIWindow;
var FrameInfo: TOleInPlaceFrameInfo);
var
Form: PControl;
begin
//Get richedit's underlying form
{ Form := ValidParentForm(FOwner);}
//Ensure there is a TOleForm object
{ if Form.OleFormObject = nil then
TOleForm.Create(Form);}
//Get relevant frame interface
{ Frame := Form.OleFormObject as IOleInPlaceFrame;}
Doc := nil; //Document window is same as frame window
FrameInfo.hWndFrame := 0; // Form.Handle;
FrameInfo.fMDIApp := False;
FrameInfo.hAccel := 0;
FrameInfo.cAccelEntries := 0;
end;
function TRichEditOleCallback.GetNewStorage: IStorage;
var
LockBytes: ILockBytes;
begin
//Basically copied from TOleContainer.CreateStorage
OleCheck(CreateILockBytesOnHGlobal(0, True, LockBytes));
OleCheck(StgCreateDocfileOnILockBytes(LockBytes,
STGM_READWRITE or STGM_SHARE_EXCLUSIVE or STGM_CREATE, 0, Result));
end;
procedure TRichEditOleCallback.QueryAcceptData(dataobj: IDataObject;
var cfFormat: TClipFormat; reCO: DWord; fReally: Bool;
hMetaPict: HGlobal);
begin
//Accept anything
end;
procedure TRichEditOleCallback.QueryInsertObject(const ClsID: TCLSID;
Stg: IStorage; CP: Integer);
begin
//Accept anything
end;
procedure TRichEditOleCallback.ShowContainerUI(fShow: Bool);
var
Form: PControl;
begin
if fShow then
begin
{ Form := GetParentForm(FOwner);}
{ if Assigned(Form) and Assigned(Form.Menu) then
begin
Form.Menu.SetOle2MenuHandle(0);
(Form.OleFormObject as IVCLFrameForm).ClearBorderSpace
end}
end
end;
{ TOleRichEdit }
function BytesPerScanline(PixelsPerScanline, BitsPerPixel, Alignment: Longint): Longint;
begin
Dec(Alignment);
Result := ((PixelsPerScanline * BitsPerPixel) + Alignment) and not Alignment;
Result := Result div 8;
end;
procedure InitializeBitmapInfoHeader(Bitmap: HBITMAP; var BI: TBitmapInfoHeader;
Colors: Integer);
var
DS: TDIBSection;
Bytes: Integer;
begin
DS.dsbmih.biSize := 0;
Bytes := GetObject(Bitmap, SizeOf(DS), @DS);
if Bytes = 0 then {InvalidBitmap}
else if (Bytes >= (sizeof(DS.dsbm) + sizeof(DS.dsbmih))) and
(DS.dsbmih.biSize >= DWORD(sizeof(DS.dsbmih))) then
BI := DS.dsbmih
else
begin
FillChar(BI, sizeof(BI), 0);
with BI, DS.dsbm do
begin
biSize := SizeOf(BI);
biWidth := bmWidth;
biHeight := bmHeight;
end;
end;
case Colors of
2: BI.biBitCount := 1;
3..16:
begin
BI.biBitCount := 4;
BI.biClrUsed := Colors;
end;
17..256:
begin
BI.biBitCount := 8;
BI.biClrUsed := Colors;
end;
else
BI.biBitCount := DS.dsbm.bmBitsPixel * DS.dsbm.bmPlanes;
end;
BI.biPlanes := 1;
if BI.biClrImportant > BI.biClrUsed then
BI.biClrImportant := BI.biClrUsed;
if BI.biSizeImage = 0 then
BI.biSizeImage := BytesPerScanLine(BI.biWidth, BI.biBitCount, 32) * Abs(BI.biHeight);
end;
procedure InternalGetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD; Colors: Integer);
var
BI: TBitmapInfoHeader;
begin
InitializeBitmapInfoHeader(Bitmap, BI, Colors);
if BI.biBitCount > 8 then
begin
InfoHeaderSize := SizeOf(TBitmapInfoHeader);
if (BI.biCompression and BI_BITFIELDS) <> 0 then
Inc(InfoHeaderSize, 12);
end
else
if BI.biClrUsed = 0 then
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * (1 shl BI.biBitCount)
else
InfoHeaderSize := SizeOf(TBitmapInfoHeader) +
SizeOf(TRGBQuad) * BI.biClrUsed;
ImageSize := BI.biSizeImage;
end;
procedure GetDIBSizes(Bitmap: HBITMAP; var InfoHeaderSize: DWORD;
var ImageSize: DWORD);
begin
InternalGetDIBSizes(Bitmap, InfoHeaderSize, ImageSize, 0);
end;
function InternalGetDIB(Bitmap: HBITMAP; Palette: HPALETTE;
var BitmapInfo; var Bits; Colors: Integer): Boolean;
var
OldPal: HPALETTE;
DC: HDC;
begin
InitializeBitmapInfoHeader(Bitmap, TBitmapInfoHeader(BitmapInfo), Colors);
OldPal := 0;
DC := CreateCompatibleDC(0);
try
if Palette <> 0 then
begin
OldPal := SelectPalette(DC, Palette, False);
RealizePalette(DC);
end;
Result := GetDIBits(DC, Bitmap, 0, TBitmapInfoHeader(BitmapInfo).biHeight, @Bits,
TBitmapInfo(BitmapInfo), DIB_RGB_COLORS) <> 0;
finally
if OldPal <> 0 then SelectPalette(DC, OldPal, False);
DeleteDC(DC);
end;
end;
function GetDIB(Bitmap: HBITMAP; Palette: HPALETTE; var BitmapInfo; var Bits): Boolean;
begin
Result := InternalGetDIB(Bitmap, Palette, BitmapInfo, Bits, 0);
end;
function TKOLOleRichEdit.BitmapToRTF(pict: PBitmap): string;
var
bi, bb, rtf: string;
bis, bbs: Cardinal;
achar: ShortString;
hexpict: string;
I: Integer;
begin
GetDIBSizes(pict.Handle, bis, bbs);
SetLength(bi, bis);
SetLength(bb, bbs);
GetDIB(pict.Handle, {pict.Palette}0, PChar(bi)^, PChar(bb)^);
rtf := '{\rtf1 {\pict\dibitmap ';
SetLength(hexpict, (Length(bb) + Length(bi)) * 2);
I := 2;
for bis := 1 to Length(bi) do
begin
achar := Format('%x', [Integer(bi[bis])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
for bbs := 1 to Length(bb) do
begin
achar := Format('%x', [Integer(bb[bbs])]);
if Length(achar) = 1 then
achar := '0' + achar;
hexpict[I - 1] := achar[1];
hexpict[I] := achar[2];
Inc(I, 2);
end;
rtf := rtf + hexpict + ' }}';
Result := rtf;
end;
procedure TKOLOleRichEdit.HideFrames;
var p: PData;
i: integer;
n: integer;
o: TREOBJECT;
begin
p := CustomData;
n := p.IOle.GetObjectCount;
for i := n - 1 downto 0 do begin
fillchar(o, sizeof(o), 0);
o.cbStruct := sizeof(O);
if p.IOle.GetObject(i, o, 7) = S_OK then begin
o.dwFlags := 0;
p.IOle.InsertObject(o);
end;
end;
end;
function TKOLOleRichEdit.GetDragOle;
var p: PData;
begin
Result := False;
if CustomData <> nil then begin
p := CustomData;
Result := p.Drag;
end;
end;
procedure TKOLOleRichEdit.SetDragOle;
var p: PData;
begin
if CustomData <> nil then begin
p := CustomData;
p.Drag := d;
end;
end;
end.