Browse Source

WebP image format support in chat ans separate window

Fixed: plugin tabs headers, black chat on popupmenu dismiss, memory consumption for images in chat and separate window
oldchat
Mikanoshi 7 years ago
parent
commit
bf717a2fb5
22 changed files with 2531 additions and 340 deletions
  1. BIN
      Distro/RnQ1110_m.zLng
  2. +1
    -1
      Distro/RnQ1110_rus.utflng
  3. +7
    -3
      README.html
  4. BIN
      RnQ/Res/NoWebp.png
  5. BIN
      RnQ/Res/RnQ_Icon.png
  6. BIN
      RnQ/Res/RnQ_Icon1.ico
  7. BIN
      RnQ/Res/RnQ_Icon2.ico
  8. BIN
      RnQ/Res/RnQ_Icon_Updater.png
  9. BIN
      RnQ/Res/RnQ_Icon_Updater.ufo
  10. +1
    -1
      RnQ/Res/WinXP2.rc
  11. +2
    -2
      RnQ/RnQBuiltTime.inc
  12. BIN
      RnQ/RnQx64.res
  13. BIN
      RnQ/WinXP2.res
  14. +44
    -37
      RnQ/chatDlg.pas
  15. +1
    -1
      RnQ/globalLib.pas
  16. +25
    -24
      RnQ/historyVCL.pas
  17. +45
    -60
      RnQ/mainDlg.pas
  18. +97
    -84
      RnQ/utilLib.pas
  19. +4
    -0
      clear_all.bat
  20. +2187
    -0
      for.RnQ/RTL/Bitmap32.pas
  21. +117
    -71
      for.RnQ/RTL/RnQGraphics32.pas
  22. +0
    -56
      for.RnQ/Stretch32BitBitmap.pas

BIN
Distro/RnQ1110_m.zLng View File


+ 1
- 1
Distro/RnQ1110_rus.utflng View File

@ -3208,7 +3208,7 @@ _________
[R&Q error: Could't decrypt message. Need password.\n[%s]]
R&Q: Ошибка, не удалось расшифровать сообщение. Нужен пароль.\n[%s]
[This picture format is not supported]
Формат это картинки не поддерживается
Формат этой картинки не поддерживается
[Error saving contact list]
Ошибка сохранения контакт-листа


+ 7
- 3
README.html View File

@ -1,8 +1,8 @@
<div style="line-height: 150%;">
<h1>R&Q 1124 Кастомная сборка</h1>
Номер сборки: 10<br>
Последнее обновление: 18.08.2014
Номер сборки: 11<br>
Последнее обновление: 20.08.2014
<br /><div style="width: 100%; height: 1px; border-top: #D3D3D3 solid 1px;"></div><br />
<u>Особенности сборки</u><br>
@ -18,7 +18,7 @@ frame.selected.color=969696
[menu]
smiles.selected.color=DEDEDE
smiles.selected.frame.color=969696</pre></blockquote>
- Добавлена поддержка отображения ICO и TIFF в чате, открытие изображений в отдельном окне двойным щелчком или из выпадающего меню<br>
- Добавлена поддержка отображения <a href="https://developers.google.com/speed/webp/docs/webp_codec" target="_blank">WEBP</a>, ICO и TIFF в чате, открытие изображений в отдельном окне двойным щелчком или из выпадающего меню<br>
- Полностью изменены заголовки вкладок чата, вместо прежних теперь кнопки, похожие на SpeedButton, переменные выше также задают цвет выделения и для них.<br>
- Полностью выпилен RTTI юнит из exe<br>
- Улучшена отзывчивость интерфейса при запуске<br>
@ -38,6 +38,10 @@ smiles.selected.frame.color=969696</pre></blockquote>
<br><br>
<h2>История версий</h2>
1124 Сборка 11<br>
- Поддержка WEBP изображений в чате, требуется установка <a href="https://developers.google.com/speed/webp/docs/webp_codec" target="_blank">кодека</a><br>
- Исправлено: отрисовка заголовков для плагинных вкладок чата, баг с чёрным чатом при закрытии меню, потребление памяти при показе изображений в чате и отдельном окне<br><br>
1124 Сборка 10<br>
- Ограничение размера изображений в чате, масштабирование с Lanczos3 фильтром<br>
- Просмотр текста сообщения и нескольких изображений в отдельном окне<br>


BIN
RnQ/Res/NoWebp.png View File

Before After
Width: 120  |  Height: 54  |  Size: 5.2 KiB

BIN
RnQ/Res/RnQ_Icon.png View File

Before After
Width: 48  |  Height: 48  |  Size: 3.7 KiB

BIN
RnQ/Res/RnQ_Icon1.ico View File

Before After

BIN
RnQ/Res/RnQ_Icon2.ico View File

Before After

BIN
RnQ/Res/RnQ_Icon_Updater.png View File

Before After
Width: 64  |  Height: 64  |  Size: 5.1 KiB

BIN
RnQ/Res/RnQ_Icon_Updater.ufo View File


+ 1
- 1
RnQ/Res/WinXP2.rc View File

@ -1,2 +1,2 @@
1 24 "rnq.manifest1"
//101 ICON "RnQ.ico"
NOWEBP RCDATA "NoWebp.png"

+ 2
- 2
RnQ/RnQBuiltTime.inc View File

@ -1,2 +1,2 @@
{ 18.08.2014 22:04:40 }
BuiltTime = 41869.919908588;
{ 20.08.2014 22:18:27 }
BuiltTime = 41871.9294893866;

BIN
RnQ/RnQx64.res View File


BIN
RnQ/WinXP2.res View File


+ 44
- 37
RnQ/chatDlg.pas View File

@ -241,8 +241,7 @@ type
procedure FormActivate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure CLPanelDockDrop(Sender: TObject; Source: TDragDockObject; X, Y: integer);
procedure CLPanelDockOver(Sender: TObject; Source: TDragDockObject; X, Y: integer; State: TDragState;
var Accept: boolean);
procedure CLPanelDockOver(Sender: TObject; Source: TDragDockObject; X, Y: integer; State: TDragState; var Accept: boolean);
procedure CLPanelUnDock(Sender: TObject; Client: TControl; NewTarget: TWinControl; var Allow: boolean);
procedure quoteBtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
procedure findBtnMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
@ -258,6 +257,7 @@ type
procedure hAShowSmilesExecute(Sender: TObject);
procedure sbarDblClick(Sender: TObject);
procedure pagectrlDrawTab(Control: TCustomTabControl; TabIndex: integer; const Rect: TRect; Active: boolean);
procedure popupHistmenu(X, Y: integer);
{$IFDEF usesDC}
procedure WMDROPFILES(var Message: TWMDROPFILES); message WM_DROPFILES;
{$ENDIF usesDC}
@ -316,6 +316,7 @@ type
{$ENDIF USE_SMILE_MENU}
MainFormWidth: integer;
// favMenuExt : TPopupMenu;
menuWasCancelled: boolean;
procedure SetSmilePopup(pIsMenu: boolean);
procedure UpdatePluginPanel;
@ -499,34 +500,34 @@ begin
end;
Inc(Rect.Left, 1 + theme.drawPic(hnd, Rect.Left, Rect.Top, pic).cx)
end;
end;
if (Message.DrawItemStruct.itemState = 1) then
p := 'chat.tab.active'
else
p := 'chat.tab.inactive';
theme.ApplyFont(p, Canvas.Font);
if (Message.DrawItemStruct.itemState = 1) then
p := 'chat.tab.active'
else
p := 'chat.tab.inactive';
theme.ApplyFont(p, Canvas.Font);
if UseContactThemes and Assigned(ContactsTheme) then
begin
ContactsTheme.ApplyFont(TPicName('group.') + TPicName(AnsiLowerCase(groups.id2name(c.group))) + '.' + p,
Canvas.Font);
ContactsTheme.ApplyFont(TPicName(c.UID2cmp) + '.' + p, Canvas.Font);
end;
if UseContactThemes and Assigned(ContactsTheme) then
begin
ContactsTheme.ApplyFont(TPicName('group.') + TPicName(AnsiLowerCase(groups.id2name(c.group))) + '.' + p, Canvas.Font);
ContactsTheme.ApplyFont(TPicName(c.UID2cmp) + '.' + p, Canvas.Font);
end;
dec(Rect.Top, 4);
if ci.chatType = CT_IM then
begin
Inc(Rect.Left, 4);
ss := dupAmperstand(c.displayed);
DrawText(hnd, PChar(ss), Length(ss), Rect, DT_LEFT or DT_SINGLELINE or DT_VCENTER);
// or DT_ DT_END_ELLIPSIS);
end
else
begin
Inc(Rect.Left, 1 + theme.drawPic(hnd, Rect.Left, Rect.Top,
'plugintab' + IntToStrA(chatFrm.chats.byIdx(TabIndex).ID)).cx);
Inc(Rect.Top, 2);
TextOut(Rect.Left, Rect.Top, ci.lastInputText);
Inc(Rect.Left, 4 + theme.drawPic(hnd, Rect.Left, Rect.Top,
'plugintab' + IntToStrA(chatFrm.chats.byIdx(Message.DrawItemStruct.itemID).ID)).cx);
ss := dupAmperstand(ci.lastInputText);
end;
dec(Rect.Top, 4);
DrawText(hnd, PChar(ss), Length(ss), Rect, DT_LEFT or DT_SINGLELINE or DT_VCENTER);
end;
Rgn := CreateRectRgn(0, 0, 0, 0);
@ -822,6 +823,7 @@ end; // applyFormXY
procedure TchatFrm.FormCreate(Sender: TObject);
begin
menuWasCancelled := false;
lastClickIdx := -1;
chats := Tchats.create;
plugBtns := TPlugButtons.create;
@ -1508,10 +1510,11 @@ begin
if usePlugPanel then
begin
if plugBtns.PluginsTB <> toolbar then
begin
plugBtns.PluginsTB.parent := ch.btnPnl;
plugBtns.PluginsTB.visible := TRUE;
end;
try
plugBtns.PluginsTB.parent := ch.btnPnl;
plugBtns.PluginsTB.visible := TRUE;
except
end;
end
else
for i := Low(plugBtns.btns) to High(plugBtns.btns) do
@ -2530,7 +2533,7 @@ begin
WM_mousewheel, WM_VSCROLL:
if (Assigned(chats)) and (thisChat <> NIL) and (thisChat.chatType = CT_IM) then
if message.wparam shr 31 > 0 then
if message.WParam shr 31 > 0 then
thisChat.historyBox.histScrollEvent(+wheelVelocity)
else
thisChat.historyBox.histScrollEvent(-wheelVelocity);
@ -2832,8 +2835,7 @@ begin
if ch.chatType = CT_IM then
if ch.who.fProto.ProtoID = ICQProtoID then
if TICQSession(ch.who.fProto).UseCryptMsg and
(TICQContact(ch.who).crypt.supportCryptMsg or TICQSession(ch.who.fProto)
.useMsgType2for(TICQContact(ch.who))) then
(TICQContact(ch.who).crypt.supportCryptMsg or TICQSession(ch.who.fProto).useMsgType2for(TICQContact(ch.who))) then
begin
if TICQContact(ch.who).crypt.supportCryptMsg then
// theme.drawPic(statusbar.canvas.Handle, rect.left,rect.top+1, PIC_KEY);
@ -2886,8 +2888,8 @@ begin
end;
procedure TchatFrm.sbarMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: integer);
//var
// ch: TchatInfo;
// var
// ch: TchatInfo;
begin
case whatStatusPanel(sbar, X) of
1:
@ -2928,7 +2930,7 @@ function TchatFrm.moveToTimeOrEnd(c: TRnQContact; time: Tdatetime; NeedOpen: boo
var
ch: TchatInfo;
ev: Thevent;
// i: integer;
// i: integer;
begin
Result := false;
ch := chats.byContact(c);
@ -2940,7 +2942,7 @@ begin
begin
with ch.historyBox do
begin
// i := topVisible;
// i := topVisible;
go2end(TRUE);
ev := history.getAt(topVisible);
end;
@ -3027,8 +3029,7 @@ begin
exit;
end;
wnd := TselectCntsFrm.doAll(mainDlg.RnQmain, 'Send multiple', 'Send message', Account.AccProto,
Account.AccProto.readList(LT_ROSTER).clone.Add(notInList), sendMessageAction,
[sco_multi, sco_groups, sco_predefined], @wnd);
Account.AccProto.readList(LT_ROSTER).clone.Add(notInList), sendMessageAction, [sco_multi, sco_groups, sco_predefined], @wnd);
wnd.toggle(thisContact);
// theme.getIco2(PIC_MSG, wnd.icon);
theme.pic2ico(RQteFormIcon, PIC_MSG, wnd.icon);
@ -3160,8 +3161,7 @@ begin
Max := ch.who.fProto.maxCharsFor(ch.who);
if Length(ch.input.text) > Max then
if MessageDlg
(getTranslation('Your message is too long. Max %d characters.\n\n Split the message?',
if MessageDlg(getTranslation('Your message is too long. Max %d characters.\n\n Split the message?',
[Max]), mtInformation, [mbYes, mbNo], 0) = mrYes then
begin
s := grabThisText;
@ -3259,8 +3259,8 @@ procedure TchatFrm.chatcloseignore1Click(Sender: TObject);
begin
sawAllhere;
addToIgnoreList(thisContact);
if MessageDlg(getTranslation('Do you want to remove %s from your contact list?', [thisChat.who.displayed]),
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
if MessageDlg(getTranslation('Do you want to remove %s from your contact list?', [thisChat.who.displayed]), mtConfirmation,
[mbYes, mbNo], 0) = mrYes then
removeFromRoster(thisContact);
closeThisPage;
end;
@ -3423,6 +3423,13 @@ begin
thisChat.input.SelText := TRQmenuitem(Sender).ImageName;
end;
procedure TchatFrm.popupHistmenu(X, Y: integer);
var msg: tagMSG;
begin
chatFrm.histmenu.popup(X, Y);
menuWasCancelled := not PeekMessage(msg, PopupList.Window, WM_COMMAND, WM_COMMAND, PM_NOREMOVE);
end;
procedure TchatFrm.histmenuPopup(Sender: TObject);
begin
chatshowlsb1.checked := showLSB;


+ 1
- 1
RnQ/globalLib.pas View File

@ -56,7 +56,7 @@ Longword = $000A01FF; // remember: it's hex
RnQBuild =;
{$ELSE ~DB_ENABLED}
RnQBuild = 1124;
RnQBuildCustom = 10;
RnQBuildCustom = 11;
PIC_CLIENT_LOGO = TPicName('rnq');
{$ENDIF ~DB_ENABLED}
// {$Include RnQBuiltTime.inc}


+ 25
- 24
RnQ/historyVCL.pas View File

@ -32,8 +32,8 @@ type
ASS_ENABLENOTSCROLL, // fAutoscroll = True, not2go2end = True
ASS_FULLDISABLED); // fAutoscroll = False, not2go2end = Any
TitemKind = (PK_NONE, PK_HEAD, PK_TEXT, PK_ARROWS_UP, PK_ARROWS_DN, PK_LINK, PK_SMILE, PK_CRYPTED, PK_RQPIC,
PK_RQPICEX, PK_RNQBUTTON);
TitemKind = (PK_NONE, PK_HEAD, PK_TEXT, PK_ARROWS_UP, PK_ARROWS_DN, PK_LINK, PK_SMILE, PK_CRYPTED, PK_RQPIC, PK_RQPICEX,
PK_RNQBUTTON);
PhistoryItem = ^ThistoryItem;
ThistoryLink = record
@ -451,16 +451,14 @@ var
procedure setResult(lk: TlinkKind; end_: integer = 0);
const
allowedChars: array [TlinkKind] of set of char = (FTPURLCHARS, EMAILCHARS, WEBURLCHARS, ['0' .. '9'],
EDURLCHARS);
allowedChars: array [TlinkKind] of set of char = (FTPURLCHARS, EMAILCHARS, WEBURLCHARS, ['0' .. '9'], EDURLCHARS);
begin
if end_ = 0 then
begin
end_ := i;
if lk = LK_WWW then
begin
while (end_ < length(BodyText)) and not (BodyText[end_ + 1].IsSeparator) and
not (BodyText[end_ + 1].IsControl) do
while (end_ < length(BodyText)) and not(BodyText[end_ + 1].IsSeparator) and not(BodyText[end_ + 1].IsControl) do
inc(end_);
// if TCharacter.IsSeparator(BodyText[end_]) then
// dec(end_);
@ -1554,8 +1552,8 @@ begin
// (vR.Right > 0)and(vR.Bottom > 0) then
// begin
{$IFDEF RNQ_FULL}
if Assigned(theme.AnibgPic) and (theme.AnibgPic.Width = vFullR.Right) and (theme.AnibgPic.Height = vFullR.Bottom)
and (history.ThemeToken = lastBGToken) and (not UseContactThemes or (Self.who = lastBGCnt)) then
if Assigned(theme.AnibgPic) and (theme.AnibgPic.Width = vFullR.Right) and (theme.AnibgPic.Height = vFullR.Bottom) and
(history.ThemeToken = lastBGToken) and (not UseContactThemes or (Self.who = lastBGCnt)) then
BitBlt(cnv.Handle, vR.left, vR.Top, vR.Right - vR.left, vR.Bottom - vR.Top, theme.AnibgPic.canvas.Handle, vR.left,
vR.Top, SRCCOPY)
// BitBlt(cnv.Handle, 0, 0, vFullR.Right, vFullR.Bottom,
@ -1876,8 +1874,7 @@ begin
begin
SOS := endSel;
EOS := startSel;
if (lastClickedItem.kind = PK_SMILE) and (lastClickedItem.evIdx = EOS.evIdx) and (lastClickedItem.ofs = EOS.ofs)
then
if (lastClickedItem.kind = PK_SMILE) and (lastClickedItem.evIdx = EOS.evIdx) and (lastClickedItem.ofs = EOS.ofs) then
inc(EOS.ofs, lastClickedItem.l);
end;
@ -1981,8 +1978,8 @@ begin
ev := history.getAt(i);
// ev.applyFont(fnt);
fnt.Assign(ev.getFont);
addStr(CRLF + applyHtmlFont(fnt, '<u>[' + getTranslation(event2ShowStr[ev.kind]) + '] ' + datetimeToStr(ev.when) +
', ' + ev.who.displayed + '</u>' + '<br>' + str2html(ev.getBodyText) + '<br><br>'));
addStr(CRLF + applyHtmlFont(fnt, '<u>[' + getTranslation(event2ShowStr[ev.kind]) + '] ' + datetimeToStr(ev.when) + ', ' +
ev.who.displayed + '</u>' + '<br>' + str2html(ev.getBodyText) + '<br><br>'));
end;
addStr(CRLF + '</body></html>');
@ -2110,8 +2107,8 @@ begin
end;
addStr(AnsiString(CRLF + '<div class="uin' + ev.who.UID2cmp + '">' + '<u>[') +
StrToUTF8(getTranslation(event2ShowStr[ev.kind]) + '] ' + datetimeToStr(ev.when) + ', ' + ev.who.displayed +
'</u>' + '<br/>' + str2html2(ev.getBodyText)) + '</div>');
StrToUTF8(getTranslation(event2ShowStr[ev.kind]) + '] ' + datetimeToStr(ev.when) + ', ' + ev.who.displayed + '</u>' +
'<br/>' + str2html2(ev.getBodyText)) + '</div>');
end;
setLength(Content, dim);
// Content:= StringReplace(Content, '&', '&amp;', [rfReplaceAll]);
@ -2121,8 +2118,8 @@ begin
result := StringReplace(HTMLTemplate, AnsiString('%TITLE%'), HTMLElement, []);
// %BODY%
HTMLElement := ' body {' + CRLF + ' background-color: ' + color2html(theme.GetColor(ClrHistBG, clWindow)) +
';' + CRLF + ' }' + CRLF;
HTMLElement := ' body {' + CRLF + ' background-color: ' + color2html(theme.GetColor(ClrHistBG, clWindow)) + ';' + CRLF +
' }' + CRLF;
result := StringReplace(result, AnsiString('%BODY%'), HTMLElement, []);
// %HOST%
@ -2202,7 +2199,7 @@ begin
chatFrm.selectall1.enabled := historyNowCount > 0;
lastClickedItem := pointedItem;
with clientToScreen(Point(X, Y)) do
chatFrm.histMenu.popup(X, Y);
chatFrm.popupHistmenu(X, Y);
// startSel.ofs := -1; endSel.ofs := -1;
exit;
end;
@ -2216,6 +2213,13 @@ begin
inherited;
exit;
end;
if chatFrm.menuWasCancelled then
begin
chatFrm.menuWasCancelled := false;
exit;
end;
deselect();
case pointedSpace.kind of
PK_NONE:
@ -2255,8 +2259,7 @@ end; // mouseDown
procedure ThistoryBox.Click();
begin
if not dontTriggerLink and (pointedItem.kind = lastClickedItem.kind) and
(pointedItem.link.id = lastClickedItem.link.id) then
if not dontTriggerLink and (pointedItem.kind = lastClickedItem.kind) and (pointedItem.link.id = lastClickedItem.link.id) then
begin
selecting := false;
triggerLink(pointedItem);
@ -2536,7 +2539,7 @@ begin
endSel.ofs := -1
else if endSel.ofs < 0 then
endSel.ofs := 0;
repaint();
Paint();
end; // updatePointedItem
function ThistoryBox.triggerLink(item: ThistoryItem): boolean;
@ -3058,8 +3061,7 @@ var
begin
history.add(ev);
// if autoScroll and (not not2go2end or P_lastEventIsFullyVisible) then
if (fAutoScrollState = ASS_FULLSCROLL) or ((fAutoScrollState = ASS_ENABLENOTSCROLL) and P_lastEventIsFullyVisible)
then
if (fAutoScrollState = ASS_FULLSCROLL) or ((fAutoScrollState = ASS_ENABLENOTSCROLL) and P_lastEventIsFullyVisible) then
begin
i := topVisible;
go2end(true, true);
@ -3080,8 +3082,7 @@ function ThistoryBox.getAutoScroll: boolean;
begin
// result := fAutoScrollState < ASS_FULLDISABLED;
// result := fAutoScrollState = ASS_FULLSCROLL;
result := (fAutoScrollState = ASS_FULLSCROLL) or
((fAutoScrollState = ASS_ENABLENOTSCROLL) and P_lastEventIsFullyVisible);
result := (fAutoScrollState = ASS_FULLSCROLL) or ((fAutoScrollState = ASS_ENABLENOTSCROLL) and P_lastEventIsFullyVisible);
end;
{ procedure ThistoryBox.setAutoScroll(vAS : Boolean);


+ 45
- 60
RnQ/mainDlg.pas View File

@ -11,7 +11,7 @@ uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
StdCtrls, ExtCtrls, Menus, ActiveX, ActnList,
VirtualTrees, RDGlobal, RQMenuItem, RnQButtons, RnQDialogs,
pluginLib, RnQProtocol, System.Actions;
pluginLib, RnQProtocol, System.Actions, Vcl.Imaging.GIFImg;
{$I NoRTTI.inc}
@ -331,20 +331,19 @@ type
procedure rosterMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure rosterDblClick(Sender: TObject);
procedure rosterKeyUp(Sender: TObject; var Key: Word; Shift: TShiftState);
procedure rosterCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex;
var Result: Integer);
procedure rosterCompareNodes(Sender: TBaseVirtualTree; Node1, Node2: PVirtualNode; Column: TColumnIndex; var Result: Integer);
procedure rosterMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure rosterCollapsed(Sender: TBaseVirtualTree; Node: PVirtualNode);
procedure rosterCollapsing(Sender: TBaseVirtualTree; Node: PVirtualNode; var Allowed: Boolean);
procedure rosterDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;
Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
procedure rosterDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint;
Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
procedure rosterDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; Formats: TFormatArray;
Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);
procedure rosterFocusChanged(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex);
procedure menushowonlyimvisibleto1Click(Sender: TObject);
procedure rosterDrawNode(Sender: TBaseVirtualTree; const PaintInfo: TVTPaintInfo);
procedure rosterFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode;
OldColumn, NewColumn: TColumnIndex; var Allowed: Boolean);
procedure rosterFocusChanging(Sender: TBaseVirtualTree; OldNode, NewNode: PVirtualNode; OldColumn, NewColumn: TColumnIndex;
var Allowed: Boolean);
procedure mainmenureloadtheme1Click(Sender: TObject);
procedure mainmenureloadlang1Click(Sender: TObject);
procedure menuDrawItem(Sender: TObject; ACanvas: TCanvas; ARect: TRect; State: TOwnerDrawState);
@ -361,8 +360,7 @@ type
procedure AReadautomessage1Update(Sender: TObject);
procedure rosterMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure rosterGetHintSize(Sender: TBaseVirtualTree; Node: PVirtualNode; Column: TColumnIndex; var R: TRect);
procedure rosterDrawHint(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect;
Column: TColumnIndex);
procedure rosterDrawHint(Sender: TBaseVirtualTree; HintCanvas: TCanvas; Node: PVirtualNode; R: TRect; Column: TColumnIndex);
procedure minBtnClick(Sender: TObject);
procedure tempvisiblelist2Click(Sender: TObject);
procedure AAutomessage1Update(Sender: TObject);
@ -411,8 +409,7 @@ type
procedure gmAMakeLocalUpdate(Sender: TObject);
procedure gmAMakeLocalExecute(Sender: TObject);
procedure cAAuthReqstUpdate(Sender: TObject);
procedure rosterMeasureItem(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode;
var NodeHeight: Integer);
procedure rosterMeasureItem(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; Node: PVirtualNode; var NodeHeight: Integer);
procedure PntBarPaint(Sender: TObject);
procedure mARequestCLUpdate(Sender: TObject);
procedure RQHelp1Click(Sender: TObject);
@ -572,8 +569,7 @@ begin
inherited CreateParams(Params);
Params.ExStyle := (Params.ExStyle and not WS_SYSMENU and (not WS_EX_WINDOWEDGE) and (not WS_EX_STATICEDGE) and
(not WS_EX_DLGMODALFRAME) and (not WS_EX_CLIENTEDGE));
Params.Style := (Params.Style and (not WS_CAPTION) and (not DS_MODALFRAME) and (not WS_DLGFRAME) and
(not WS_THICKFRAME));
Params.Style := (Params.Style and (not WS_CAPTION) and (not DS_MODALFRAME) and (not WS_DLGFRAME) and (not WS_THICKFRAME));
Params.Style := (Params.Style or WS_SYSMENU or WS_MAXIMIZEBOX or WS_MINIMIZEBOX and not WS_SIZEBOX);
finally
end;
@ -589,8 +585,7 @@ end;
procedure TRnQmain.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
begin
CanClose := TRUE;
CanClose := not quitconfirmation or (messageDlg(getTranslation('Really quit?'), mtConfirmation, [mbYes, mbNo],
0) = mrYes);
CanClose := not quitconfirmation or (messageDlg(getTranslation('Really quit?'), mtConfirmation, [mbYes, mbNo], 0) = mrYes);
// if canclose then quit;
end;
@ -1158,8 +1153,7 @@ begin
if Assigned(Account.AccProto) then
if not Account.AccProto.isOffline then
begin
if messageDlg(getTranslation('This is gonna disconnect you. Proceed?'), mtConfirmation, [mbYes, mbNo], 0) <> mrYes
then
if messageDlg(getTranslation('This is gonna disconnect you. Proceed?'), mtConfirmation, [mbYes, mbNo], 0) <> mrYes then
Exit;
Account.AccProto.disconnect;
end;
@ -1432,13 +1426,12 @@ begin
Exit;
id := roasterLib.focused.groupId;
with groups.a[groups.idxOf(id)] do
if messageDlg(getTranslation('Are you sure you want to delete the group "%s" ?', [name]), mtConfirmation,
[mbYes, mbNo], 0) = mrYes then
if messageDlg(getTranslation('Are you sure you want to delete the group "%s" ?', [name]), mtConfirmation, [mbYes, mbNo], 0) = mrYes
then
begin
if Account.AccProto.readList(LT_ROSTER).getCount(id) > 0 then
if messageDlg
(getTranslation
('This group (%s) is not empty! All contacts in it will be lost!\nAre you sure you want to continue?',
(getTranslation('This group (%s) is not empty! All contacts in it will be lost!\nAre you sure you want to continue?',
[name]), mtWarning, [mbYes, mbNo], 0) = mrNo then
Exit;
// place over the first instance of the group that contains a contact
@ -2015,9 +2008,9 @@ begin
end;
procedure TRnQmain.savePicMnuImgClick(Sender: TObject);
var fl, ext: String; img: TImage;
var fl, ext: String; img: TImageEx;
begin
img := (((Sender as TMenuItem).GetParentMenu as TPopupMenu).PopupComponent as TImage);
img := (((Sender as TMenuItem).GetParentMenu as TPopupMenu).PopupComponent as TImageEx);
if not(img = nil) then
begin
ext := '';
@ -2034,13 +2027,15 @@ begin
ext := 'ico';
6:
ext := 'tif';
7:
ext := 'webp';
end;
if (ext <> '') then
fl := openSavedlg(self, '', False, ext);
if not(fl = '') then
img.Picture.SaveToFile(fl);
if not(fl = '') and Assigned(img.ImageStream) then
img.ImageStream.SaveToFile(fl);
end;
end;
@ -2137,8 +2132,7 @@ begin
if clickedContact.group = 0 then
movetogroup1.caption := getTranslation('Move to group')
else
movetogroup1.caption := getTranslation('Move from %s to group',
[dupAmperstand(groups.id2name(clickedContact.group))]);
movetogroup1.caption := getTranslation('Move from %s to group', [dupAmperstand(groups.id2name(clickedContact.group))]);
Addtocontactlist1.visible := not movetogroup1.visible;
if movetogroup1.visible then
@ -2151,8 +2145,8 @@ begin
else
addGroupsToMenu(self, Addtocontactlist1, addcontactAction, TRUE);
Readautomessage1.visible := (clickedContact is TICQContact) and
(showHidden or clickedContact.fProto.isOnline and (CAPS_sm_ICQSERVERRELAY in TICQContact(clickedContact)
.capabilitiesSm) and (byte(TICQContact(clickedContact).status) in statusWithAutomsg));
(showHidden or clickedContact.fProto.isOnline and (CAPS_sm_ICQSERVERRELAY in TICQContact(clickedContact).capabilitiesSm) and
(byte(TICQContact(clickedContact).status) in statusWithAutomsg));
Openincomingfolder1.Hint := fileIncomePath(clickedContact);
Openincomingfolder1.visible := DirectoryExists(Openincomingfolder1.Hint);
@ -2506,13 +2500,11 @@ begin
mAChkInvisAll.Execute;
end;
if abs(now - CheckInvis.lastChkTime) > (CheckInvis.ChkInvisInterval + (TList(checkInvQ).Count / ChkInvisDiv)) * DTseconds
then
if abs(now - CheckInvis.lastChkTime) > (CheckInvis.ChkInvisInterval + (TList(checkInvQ).Count / ChkInvisDiv)) * DTseconds then
if Assigned(checkInvQ) and Assigned(Account.AccProto) and (Account.AccProto.isOnline) and not checkInvQ.empty then
begin
CheckInvis.lastChkTime := now;
while (TList(checkInvQ).Count > 0) and (not(checkInvQ.getAt(0)).isInvisible) and
(not checkInvQ.getAt(0).isOffline) do
while (TList(checkInvQ).Count > 0) and (not(checkInvQ.getAt(0)).isInvisible) and (not checkInvQ.getAt(0).isOffline) do
checkInvQ.delete(0);
if TList(checkInvQ).Count > 0 then
begin
@ -2578,8 +2570,7 @@ begin
if Assigned(statusIcon) and Assigned(statusIcon.trayIcon) then
statusIcon.trayIcon.update;
// each 24hours check for updates
if checkupdate.Enabled and (now - checkupdate.last > checkupdate.every) and not checkupdate.checking and not startingLock
then
if checkupdate.Enabled and (now - checkupdate.last > checkupdate.every) and not checkupdate.checking and not startingLock then
begin
checkupdate.autochecking := TRUE;
check4update;
@ -2625,8 +2616,7 @@ begin
// saveRetrieveQ;
end;
{$IFDEF RNQ_AVATARS}
if Assigned(reqAvatarsQ) and Account.AccProto.AvatarsSupport and Account.AccProto.isOnline and not reqAvatarsQ.empty
then
if Assigned(reqAvatarsQ) and Account.AccProto.AvatarsSupport and Account.AccProto.isOnline and not reqAvatarsQ.empty then
if try_load_avatar(TICQContact(reqAvatarsQ.getAt(0)), TICQContact(reqAvatarsQ.getAt(0)).ICQIcon.hash) then
reqAvatarsQ.delete(0)
else
@ -2635,8 +2625,7 @@ begin
reqAvatarsQ.delete(0);
end;
{$ENDIF RNQ_AVATARS}
if Assigned(reqXStatusQ) and not reqXStatusQ.empty and Assigned(Account.AccProto) and Account.AccProto.isOnline
then
if Assigned(reqXStatusQ) and not reqXStatusQ.empty and Assigned(Account.AccProto) and Account.AccProto.isOnline then
begin
TicqSession(Account.AccProto.ProtoElem).RequestXStatus(reqXStatusQ.getAt(0).uid);
reqXStatusQ.delete(0);
@ -2654,8 +2643,8 @@ begin
begin
Fcs := getFocus;
// Fcs := GetForegroundWindow;
if ((self.Floating and not childParent(Fcs, self.Handle)) or (not self.Floating and not childParent(Fcs,
chatFrm.Handle))) and not OpenedXStForm then
if ((self.Floating and not childParent(Fcs, self.Handle)) or (not self.Floating and not childParent(Fcs, chatFrm.Handle))) and
not OpenedXStForm then
inc(inactiveTime)
else
inactiveTime := 0;
@ -2776,8 +2765,8 @@ begin
inc(toReconnectTime, 50);
boundInt(toReconnectTime, 50, 600);
end;
if connectOnConnection and Account.AccProto.isOffline and not enteringICQpwd and
(lastStatusUserSet <> byte(SC_OFFLINE)) and connectionAvailable then
if connectOnConnection and Account.AccProto.isOffline and not enteringICQpwd and (lastStatusUserSet <> byte(SC_OFFLINE)) and connectionAvailable
then
setStatus(Account.AccProto, lastStatus, TRUE);
end;
if longdelayCount = 0 then
@ -2930,9 +2919,8 @@ begin
if (autoaway.autoexit) and (autoaway.triggered <> TR_NONE) then
exitFromAutoaway();
end
else if (autoaway.triggered = TR_NONE) and
not(Account.AccProto.getStatus in [byte(SC_AWAY), byte(SC_NA), byte(SC_DND)]) or (autoaway.triggered <> TR_NONE)
then
else if (autoaway.triggered = TR_NONE) and not(Account.AccProto.getStatus in [byte(SC_AWAY), byte(SC_NA), byte(SC_DND)]) or
(autoaway.triggered <> TR_NONE) then
begin
if autoaway.away and (autoaway.time >= autoaway.awayTime) and (autoaway.triggered = TR_NONE) then
begin
@ -3227,8 +3215,8 @@ begin
case what of
NODE_GROUP:
if (groups.name2id(edit.Text) < 0) or
(messageDlg(getTranslation('The name %s already exists. Do you want to keep it?', [edit.Text]),
mtConfirmation, [mbYes, mbNo], 0) = mrYes) then
(messageDlg(getTranslation('The name %s already exists. Do you want to keep it?', [edit.Text]), mtConfirmation,
[mbYes, mbNo], 0) = mrYes) then
begin
with groups.a[groups.idxOf(groupId)] do
begin
@ -3313,8 +3301,8 @@ begin
Allowed := n.kind <> NODE_DIV;
end;
procedure TRnQmain.rosterDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState;
Pt: TPoint; Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
procedure TRnQmain.rosterDragOver(Sender: TBaseVirtualTree; Source: TObject; Shift: TShiftState; State: TDragState; Pt: TPoint;
Mode: TDropMode; var Effect: Integer; var Accept: Boolean);
var dest, destGrp, destDiv, clickedGrp, clickedDiv: Tnode;
begin
Accept := False;
@ -3381,16 +3369,15 @@ begin
// clickedGrp:= groups.get(clickedGroup).;
// clickedDiv := clickedGrp.divisor;
Accept := // (clickedDiv=destDiv) and
((dest.kind = NODE_GROUP) and (clickedGroup <> destGrp.groupId)) or
((dest.kind = NODE_DIV) and (clickedDiv = destDiv))
((dest.kind = NODE_GROUP) and (clickedGroup <> destGrp.groupId)) or ((dest.kind = NODE_DIV) and (clickedDiv = destDiv))
end
// divisor must be the same, cannot cross divisors
// if (clickedGroup>0) or (clickedContact<>NIL) then
// accept:=(clickedDiv=destDiv) and (clickedGrp<>destGrp);
end;
procedure TRnQmain.rosterDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject;
Formats: TFormatArray; Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);
procedure TRnQmain.rosterDragDrop(Sender: TBaseVirtualTree; Source: TObject; DataObject: IDataObject; Formats: TFormatArray;
Shift: TShiftState; Pt: TPoint; var Effect: Integer; Mode: TDropMode);
var grpOrDiv, n: Tnode; o: Integer;
begin
if not Sender.equals(Source) then
@ -3678,8 +3665,7 @@ begin
// drawmenuitemR98(ACanvas, TMenuItem(sender).GetParentMenu, TMenuItem(sender), ARect, false, True, odSelected in State)
// else
{$ENDIF WIN98}
GPdrawmenuitemR7(ACanvas, TMenuItem(Sender).GetParentMenu, TMenuItem(Sender), ARect, False, TRUE,
odSelected in State);
GPdrawmenuitemR7(ACanvas, TMenuItem(Sender).GetParentMenu, TMenuItem(Sender), ARect, False, TRUE, odSelected in State);
end;
procedure TRnQmain.menuMeasureItem(Sender: TObject; ACanvas: TCanvas; var Width, Height: Integer);
@ -4276,8 +4262,7 @@ end;
procedure TRnQmain.cAAuthReqstUpdate(Sender: TObject);
begin
TAction(Sender).visible := Boolean(getShiftState() and (1 + 2)) or
(Assigned(clickedContact) and not clickedContact.CntIsLocal and not clickedContact.Authorized and
clickedContact.isInRoster
(Assigned(clickedContact) and not clickedContact.CntIsLocal and not clickedContact.Authorized and clickedContact.isInRoster
{$IFDEF UseNotSSI}
// and icq.useSSI
and (not(clickedContact.iProto.ProtoElem is TicqSession) or TicqSession(clickedContact.iProto.ProtoElem).useSSI)
@ -4333,8 +4318,8 @@ end;
procedure TRnQmain.cADeleteWHExecute(Sender: TObject);
begin
if Assigned(clickedContact) then
if messageDlg(getTranslation('Are you sure you want to delete %s from your list with his history?',
[clickedContact.displayed]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
if messageDlg(getTranslation('Are you sure you want to delete %s from your list with his history?', [clickedContact.displayed]
), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
removeFromRoster(clickedContact, TRUE);
end;


+ 97
- 84
RnQ/utilLib.pas View File

@ -33,6 +33,12 @@ type
procedure CNDrawitem(var Message: TWMDrawItem); message CN_DRAWITEM;
end;
TImageEx = class(TImage)
public
ImageStream: TMemoryStream;
destructor Destroy; override;
end;
function OnlFeature(const pr: TRnQProtocol; check: Boolean = True): Boolean;
// True if online
@ -43,8 +49,7 @@ function exitFromAutoaway(): Boolean;
procedure addTempVisibleFor(time: integer; c: TRnQContact);
function infoToStatus(const info: RawByteString): byte;
function infoToXStatus(const info: RawByteString): byte;
procedure drawHint(cnv: Tcanvas; kind: integer; groupid: integer; c: TRnQContact; var r: Trect;
calcOnly: Boolean = False);
procedure drawHint(cnv: Tcanvas; kind: integer; groupid: integer; c: TRnQContact; var r: Trect; calcOnly: Boolean = False);
// procedure drawNodeHint(cnv:Tcanvas; node:Pvirtualnode; var r:Trect);
function unexistant(const uin: TUID): Boolean;
function fileIncomePath(cnt: TRnQContact): String;
@ -103,8 +108,7 @@ function getXStatusMsgFor(c: TRnQContact): string;
procedure toggleOnlyOnline;
procedure toggleOnlyImVisibleTo;
procedure openURL(const pURL: String); OverLoad;
function enterPwdDlg(var pwd: String; const title: string = ''; maxLength: integer = 0;
AllowNull: Boolean = False): Boolean;
function enterPwdDlg(var pwd: String; const title: string = ''; maxLength: integer = 0; AllowNull: Boolean = False): Boolean;
function enterUinDlg(const proto: TRnQProtocol; var uin: TUID; const title: string = ''): Boolean;
function sendProtoMsg(var oe: Toevent): Boolean;
procedure SendEmail2Mail(const email: String);
@ -188,8 +192,8 @@ procedure LoadProxies(zp: TZipFile; var pProxys: Tarrproxy);
// procedure saveOutbox;
procedure loadOutInBox(zp: TZipFile);
// procedure saveRetrieveQ;
function openSaveDlg(parent: Tform; const Cptn: String; IsOpen: Boolean; const ext: string = '';
const extCptn: String = ''; const defFile: String = ''; MultiSelect: Boolean = False): string;
function openSaveDlg(parent: Tform; const Cptn: String; IsOpen: Boolean; const ext: string = ''; const extCptn: String = '';
const defFile: String = ''; MultiSelect: Boolean = False): string;
function str2sortby(const s: AnsiString): TsortBy;
procedure CheckBDays;
@ -686,8 +690,8 @@ begin
cfg := db2strU(contactsDB);
AddFile2Zip(dbFileName, cfg);
cfg := AnsiString('protocol=') + AnsiString(pr.ProtoName) + CRLF + AnsiString('account-id=') + pr.getMyInfo.UID2cmp +
CRLF + AnsiString('account-name=') + StrToUTF8(pr.getMyInfo.displayed)
cfg := AnsiString('protocol=') + AnsiString(pr.ProtoName) + CRLF + AnsiString('account-id=') + pr.getMyInfo.UID2cmp + CRLF +
AnsiString('account-name=') + StrToUTF8(pr.getMyInfo.displayed)
{$IFDEF UseNotSSI}
+ CRLF + AnsiString('use-ssi=') + yesno[useSSI2]
{$ELSE UseNotSSI}
@ -791,19 +795,16 @@ begin
cfg := cfg + 'proxy-name=' + StrToUTF8(pProxys[k].name) + CRLF
// + 'proxy='+yesno[pProxys[i].enabled]+CRLF
+ 'proxy-serv-host=' + AnsiString(pProxys[k].serv.host) + CRLF + 'proxy-serv-port=' +
IntToStrA(pProxys[k].serv.port) + CRLF + 'proxy-auth=' + yesno[pProxys[k].auth] + CRLF + 'proxy-user=' +
StrToUTF8(pProxys[k].user) + CRLF
+ 'proxy-serv-host=' + AnsiString(pProxys[k].serv.host) + CRLF + 'proxy-serv-port=' + IntToStrA(pProxys[k].serv.port) +
CRLF + 'proxy-auth=' + yesno[pProxys[k].auth] + CRLF + 'proxy-user=' + StrToUTF8(pProxys[k].user) + CRLF
// + 'proxy-pass=' +passCrypt(pProxys[k].pwd)+CRLF
+ 'proxy-pass64=' + Base64EncodeString(passCrypt(pProxys[k].pwd)) + CRLF + 'proxy-ntlm=' +
yesno[pProxys[k].NTLM] + CRLF + 'connection-ssl=' + yesno[pProxys[k].ssl] + CRLF + 'proxy-proto=' +
proxyproto2str[pProxys[k].proto] + CRLF
+ 'proxy-pass64=' + Base64EncodeString(passCrypt(pProxys[k].pwd)) + CRLF + 'proxy-ntlm=' + yesno[pProxys[k].NTLM] + CRLF +
'connection-ssl=' + yesno[pProxys[k].ssl] + CRLF + 'proxy-proto=' + proxyproto2str[pProxys[k].proto] + CRLF
{ for pp:=low(pp) to high(pp) do cfg:=cfg
+'proxy-'+proxyproto2str[pp]+'-host='+proxyes[i].addr[pp].host+CRLF
+'proxy-'+proxyproto2str[pp]+'-port='+proxyes[i].addr[pp].port+CRLF;
}
+ 'proxy-host=' + AnsiString(pProxys[k].addr.host) + CRLF + 'proxy-port=' +
IntToStrA(pProxys[k].addr.port) + CRLF;
+ 'proxy-host=' + AnsiString(pProxys[k].addr.host) + CRLF + 'proxy-port=' + IntToStrA(pProxys[k].addr.port) + CRLF;
cfg := cfg + '------------------' + CRLF;
end;
AddFile2Zip(proxiesFileName, cfg);
@ -1205,17 +1206,24 @@ begin
inherited;
end;
destructor TImageEx.Destroy;
begin
if Assigned(ImageStream) then
ImageStream.Free;
inherited;
end;
function viewTextWindow(title, body: string; image: RawByteString): Tform;
var form: Tform;
memo: Tmemo;
img: TImage;
img: TImageEx;
scroll: TScrollBox;
PIn, POut: Pointer;
RnQPicStream: TMemoryStream;
OutSize: Cardinal;
ff: TPAFormat;
png: TPNGObject;
tif: TWICImage;
winimg: TWICImage;
bmp: TBitmap;
gif: TGIFImage;
rnqbmp: TRnQBitmap;
@ -1326,7 +1334,7 @@ begin
POut := RnQPicStream.Memory;
Base64Decode(PIn^, length(imgtag), POut^);
img := TImage.Create(scroll);
img := TImageEx.Create(scroll);
img.parent := scroll;
img.AutoSize := True;
img.Center := False;
@ -1336,6 +1344,8 @@ begin
img.OnMouseMove := RnQmain.imgMouseMove;
img.name := 'image' + IntToStr(j);
img.PopupMenu := RnQmain.imgmenu;
img.ImageStream := TMemoryStream.Create;
img.ImageStream.LoadFromStream(RnQPicStream);
ff := DetectFileFormatStream(RnQPicStream);
RnQPicStream.Seek(0, soBeginning);
@ -1374,6 +1384,8 @@ begin
if Assigned(bmp) then
img.Picture.Bitmap.Assign(bmp);
bmp.Free;
end;
pagetab.Caption := 'JPEG';
img.Tag := 2;
@ -1387,14 +1399,16 @@ begin
img.TRANSPARENT := True;
pagetab.Caption := 'GIF';
img.Tag := 3;
gif.Free;
end;
PA_FORMAT_PNG:
begin
png := TPNGImage.Create;
png.LoadFromStream(RnQPicStream);
img.Picture.Bitmap.Assign(png);
img.Picture.Assign(png);
pagetab.Caption := 'PNG';
img.Tag := 4;
png.Free;
end;
PA_FORMAT_ICO:
begin
@ -1405,11 +1419,21 @@ begin
end;
PA_FORMAT_TIF:
begin
tif := TWICImage.Create;
tif.LoadFromStream(RnQPicStream);
img.Picture.Bitmap.Assign(tif);
winimg := TWICImage.Create;
winimg.LoadFromStream(RnQPicStream);
img.Picture.Assign(winimg);
pagetab.Caption := 'TIFF';
img.Tag := 6;
winimg.Free;
end;
PA_FORMAT_WEBP:
begin
winimg := TWICImage.Create;
winimg.LoadFromStream(RnQPicStream);
img.Picture.Assign(winimg);
pagetab.Caption := 'WEBP';
img.Tag := 7;
winimg.Free;
end;
PA_FORMAT_UNK:
begin
@ -1418,6 +1442,7 @@ begin
end;
end;
end;
imgList.Free;
FreeAndNil(RnQPicStream);
end;
@ -1450,8 +1475,8 @@ begin
theme.pic2ico(RQteFormIcon, ev.pic, result.Icon);
end; // viewHeventWindow
function openSaveDlg(parent: Tform; const Cptn: String; IsOpen: Boolean; const ext: String = '';
const extCptn: String = ''; const defFile: String = ''; MultiSelect: Boolean = False): string;
function openSaveDlg(parent: Tform; const Cptn: String; IsOpen: Boolean; const ext: String = ''; const extCptn: String = '';
const defFile: String = ''; MultiSelect: Boolean = False): string;
var Filtr: String; fn: String; hndl: THandle;
// defDir : String;
begin
@ -1478,8 +1503,7 @@ end; // opendlg
function str2html(const s: string): string;
begin
result := template(s, ['&', '&amp;', '"', '&quot;', '<', '&lt;', '>', '&gt;', CRLF, '<br>', #13, '<br>', #10,
'<br>']);
result := template(s, ['&', '&amp;', '"', '&quot;', '<', '&lt;', '>', '&gt;', CRLF, '<br>', #13, '<br>', #10, '<br>']);
end; // str2html
function strFromHTML(const s: string): string;
@ -1935,9 +1959,9 @@ var wnd: TselectCntsFrm;
begin
if not Assigned(dest) then
exit;
wnd := TselectCntsFrm.doAll2(RnQmain, getTranslation('To %s', [dest.displayed]),
getTranslation('Send selected contacts'), dest.fProto, notInlist.clone.Add(dest.fProto.readList(LT_ROSTER)),
RnQmain.sendContactsAction, [sco_multi, sco_groups, sco_predefined], @wnd);
wnd := TselectCntsFrm.doAll2(RnQmain, getTranslation('To %s', [dest.displayed]), getTranslation('Send selected contacts'),
dest.fProto, notInlist.clone.Add(dest.fProto.readList(LT_ROSTER)), RnQmain.sendContactsAction,
[sco_multi, sco_groups, sco_predefined], @wnd);
// Theme.getIco2(PIC_CONTACTS, wnd.icon);
theme.pic2ico(RQteFormIcon, PIC_CONTACTS, wnd.Icon);
wnd.extra := Tincapsulate.aString(dest.uid);
@ -2089,8 +2113,7 @@ begin
fl := oe.flags or IF_UTF8_TEXT;
end;
{$ENDIF ~DB_ENABLED}
ev := Thevent.new(EK_MSG, oe.whom.fProto.getMyInfo, oe.timeSent, vBin{$IFDEF DB_ENABLED}, vStr{$ENDIF DB_ENABLED},
fl, oe.id);
ev := Thevent.new(EK_MSG, oe.whom.fProto.getMyInfo, oe.timeSent, vBin{$IFDEF DB_ENABLED}, vStr{$ENDIF DB_ENABLED}, fl, oe.id);
ev.fIsMyEvent := True;
if logpref.writehistory and (BE_save in behaviour[ev.kind].trig) and (oe.flags and IF_not_save_hist = 0) then
writeHistorySafely(ev, oe.whom);
@ -2154,8 +2177,7 @@ begin
until not result;
end; // enterUinDlg
function enterPwdDlg(var pwd: String; const title: string = ''; maxLength: integer = 0;
AllowNull: Boolean = False): Boolean;
function enterPwdDlg(var pwd: String; const title: string = ''; maxLength: integer = 0; AllowNull: Boolean = False): Boolean;
var frm: pwdDlg.TmsgFrm;
begin
frm := pwdDlg.TmsgFrm.Create(application);
@ -2189,8 +2211,8 @@ begin
if oldPwd = newPwd then
exit;
if not ICQ.isOffline then
if messageDlg(getTranslation('You have to be offline for this operation!\nDisconnect?'), mtConfirmation,
[mbYes, mbNo], 0) = mrNo then
if messageDlg(getTranslation('You have to be offline for this operation!\nDisconnect?'), mtConfirmation, [mbYes, mbNo], 0) = mrNo
then
exit
else
ICQ.disconnect;
@ -2376,11 +2398,11 @@ begin
else
h := 0;
result := template(s, ['%awaysince%', formatDatetime(timeformat.automsg, imAwaySince), '%awaysince-gmt%',
formatDatetime(timeformat.automsg, imAwaySince - GMToffset), '%elapsedhours%', IntToStr(trunc(h)),
'%elapsedminutes%', IntToStr(trunc(frac(h) * 60)), '%h%', IntToStr(hourof(now)), '%m%', IntToStr(minuteof(now)),
'%s%', IntToStr(secondof(now)), '%D%', IntToStr(dayof(now)), '%M%', IntToStr(monthof(now)), '%Y%',
IntToStr(yearof(now)), '%hh%', IntToStr(hourof(now), 2), '%mm%', IntToStr(minuteof(now), 2), '%ss%',
IntToStr(secondof(now), 2), '%DD%', IntToStr(dayof(now), 2), '%MM%', IntToStr(monthof(now), 2),
formatDatetime(timeformat.automsg, imAwaySince - GMToffset), '%elapsedhours%', IntToStr(trunc(h)), '%elapsedminutes%',
IntToStr(trunc(frac(h) * 60)), '%h%', IntToStr(hourof(now)), '%m%', IntToStr(minuteof(now)), '%s%', IntToStr(secondof(now)),
'%D%', IntToStr(dayof(now)), '%M%', IntToStr(monthof(now)), '%Y%', IntToStr(yearof(now)), '%hh%', IntToStr(hourof(now), 2),
'%mm%', IntToStr(minuteof(now), 2), '%ss%', IntToStr(secondof(now), 2), '%DD%', IntToStr(dayof(now), 2), '%MM%',
IntToStr(monthof(now), 2),
{$IFDEF RNQ_PLAYER}
'%track%', uSimplePlayer.RnQPlayer.getPlayingTitle,
{$ENDIF RNQ_PLAYER}
@ -2407,8 +2429,8 @@ begin
s1 := getTranslation(Str_unk);
s2 := s1;
end;
result := template(result, ['%you%', c.displayed, '%nick%', c.nick, '%first%', c.first, '%last%', c.last,
'%status%', getTranslation(c.fProto.Statuses[c.getStatus].Cptn), '%ip%', s1, '%proto%', s2]);
result := template(result, ['%you%', c.displayed, '%nick%', c.nick, '%first%', c.first, '%last%', c.last, '%status%',
getTranslation(c.fProto.Statuses[c.getStatus].Cptn), '%ip%', s1, '%proto%', s2]);
end
else
result := template(result, ['%you%', '', '%nick%', '', '%first%', '', '%last%', '', '%ip%', getTranslation(Str_unk),
@ -2465,8 +2487,7 @@ var
// if isAbort(ps) then exit;
vs := IntToStr(v) + ' ' + getTranslation('Build') + ' ' + IntToStr(build) + ifThen(preview, ' PREVIEW');
ps := ifThen(PREVIEWversion, CRLF + getTranslation('Your version is a "preview"!'), '');
if messageDlg
(getTranslation('There''s a new version available! version %s%s\nDo you want to download the new version?',
if messageDlg(getTranslation('There''s a new version available! version %s%s\nDo you want to download the new version?',
[vs, ps]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
openURL(url)
end; // found
@ -2500,8 +2521,7 @@ begin
if PREVIEWversion and ((v > RnQBuild) or (previewv > RnQBuildCustom)) then
begin
result := True;
if messageDlg(getTranslation('You are running OLD TEST BUILD!\nRun anyway?'), mtWarning, [mbYes, mbNo], 0) <> mrYes
then
if messageDlg(getTranslation('You are running OLD TEST BUILD!\nRun anyway?'), mtWarning, [mbYes, mbNo], 0) <> mrYes then
openURL(rnqSite)
else
begin
@ -2719,8 +2739,7 @@ begin
msgDlg(getTranslation('SPAM FILTERED FROM %s \n BY WORD %s', [c.displayed + ' (' + c.uid + ')', wrd]), False,
mtInformation, c.uid)
else
msgDlg(getTranslation('SPAM FILTERED FROM %s', [c.displayed + ' (' + c.uid + ')']), False,
mtInformation, c.uid);
msgDlg(getTranslation('SPAM FILTERED FROM %s', [c.displayed + ' (' + c.uid + ')']), False, mtInformation, c.uid);
exit;
end;
result := enableIgnoreList and ignoreList.exists(c);
@ -2937,8 +2956,7 @@ begin
// TRAY
if (ev0.kind = EK_CONTACTS) and chatFrm.isVisible and (ev0.who = chatFrm.thisChat.who) then
TselectCntsFrm.doAll2(RnQmain, getTranslation('from %s', [ev0.who.displayed]),
getTranslation('Add selected contacts'), vProto, ev0.cl.clone, RnQmain.addContactsAction,
[sco_multi], @wnd)
getTranslation('Add selected contacts'), vProto, ev0.cl.clone, RnQmain.addContactsAction, [sco_multi], @wnd)
else if BE_tray in behaviour[ev0.kind].trig then
eventQ.Add(ev0.clone);
// TIP
@ -2976,8 +2994,7 @@ begin
if ev.who.antispam.Tryes = spamfilter.BotTryesCount then
begin
inc(ev.who.antispam.Tryes);
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[3]), '%uin%',
ev.who.uid));
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[3]), '%uin%', ev.who.uid));
exit;
end
else if ev.who.antispam.Tryes > spamfilter.BotTryesCount then
@ -3017,13 +3034,13 @@ begin
begin
inc(ev.who.antispam.Tryes);
if spamfilter.UseBotFromFile and (length(spamfilter.quests) > 0) then
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[5]),
'%attempt%', IntToStr(spamfilter.BotTryesCount + 1 - ev.who.antispam.Tryes)) + CRLF +
getTranslation(AntiSpamMsgs[6]) + CRLF + s)
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[5]), '%attempt%',
IntToStr(spamfilter.BotTryesCount + 1 - ev.who.antispam.Tryes)) + CRLF + getTranslation(AntiSpamMsgs[6])
+ CRLF + s)
else
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[5]),
'%attempt%', IntToStr(spamfilter.BotTryesCount + 1 - ev.who.antispam.Tryes)) + CRLF +
getTranslation(AntiSpamMsgs[4]) + CRLF + s);
Proto_Outbox_add(OE_msg, ev.who, SpamBotMsgFlags, AnsiReplaceStr(getTranslation(AntiSpamMsgs[5]), '%attempt%',
IntToStr(spamfilter.BotTryesCount + 1 - ev.who.antispam.Tryes)) + CRLF + getTranslation(AntiSpamMsgs[4]) +
CRLF + s);
exit;
end;
end;
@ -3033,8 +3050,8 @@ begin
// prevent annoying fast oncoming/offgoing sequences
if minOnOff then
if (ev.kind = EK_oncoming) and (now - ev.who.lastTimeSeenOnline < minOnOffTime * DTseconds) or
(ev.kind = EK_offgoing) and (now - TCE(ev.who.data^).lastOncoming < minOnOffTime * DTseconds) then
if (ev.kind = EK_oncoming) and (now - ev.who.lastTimeSeenOnline < minOnOffTime * DTseconds) or (ev.kind = EK_offgoing) and
(now - TCE(ev.who.data^).lastOncoming < minOnOffTime * DTseconds) then
exit;
result := True;
@ -3050,8 +3067,8 @@ begin
ev.fpos := -1;
SkipEvent := False;
if DsblEvnt4ClsdGrp and (ev.kind in [EK_oncoming, EK_offgoing, EK_statuschange, EK_automsgreq, EK_automsg,
EK_typingBeg, EK_typingFin, EK_XstatusMsg, EK_Xstatusreq]) then
if DsblEvnt4ClsdGrp and (ev.kind in [EK_oncoming, EK_offgoing, EK_statuschange, EK_automsgreq, EK_automsg, EK_typingBeg,
EK_typingFin, EK_XstatusMsg, EK_Xstatusreq]) then
begin
// gr := ev.who.group;
gr := groups.get(ev.who.group);
@ -3090,8 +3107,8 @@ begin
end;
// TIP
if tipsAllowed and not BossMode.isBossKeyOn and (BE_tip in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0)
and not vProto.getStatusDisable.tips and not SkipEvent then
if tipsAllowed and not BossMode.isBossKeyOn and (BE_tip in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0) and
not vProto.getStatusDisable.tips and not SkipEvent then
if ev.flags and IF_no_matter = 0 then
try
// TipAdd(ev);
@ -3106,8 +3123,8 @@ begin
{$ENDIF Use_Baloons}
// TRAY
if (ev.kind = EK_CONTACTS) and chatFrm.isVisible and (ev.who = chatFrm.thisChat.who) then
TselectCntsFrm.doAll2(RnQmain, getTranslation('from %s', [ev.who.displayed]),
getTranslation('Add selected contacts'), vProto, ev.cl.clone, RnQmain.addContactsAction, [sco_multi], @wnd)
TselectCntsFrm.doAll2(RnQmain, getTranslation('from %s', [ev.who.displayed]), getTranslation('Add selected contacts'), vProto,
ev.cl.clone, RnQmain.addContactsAction, [sco_multi], @wnd)
else if (BE_tray in behaviour[ev.kind].trig) and not SkipEvent then
// if ev.flags and IF_no_matter = 0 then
eventQ.Add(ev.clone);
@ -3385,8 +3402,8 @@ begin
// DeleteFile(userPath + historyPath + c.UID);
if (grp > 0) and (TRnQCList(c.fProto.readList(LT_ROSTER)).getCount(grp) = 0) then
if messageDlg(getTranslation('This group (%s) is empty! Do you want to delete it?', [groups.id2name(grp)]),
mtConfirmation, [mbYes, mbNo], 0) = mrYes then
if messageDlg(getTranslation('This group (%s) is empty! Do you want to delete it?', [groups.id2name(grp)]), mtConfirmation,
[mbYes, mbNo], 0) = mrYes then
roasterLib.removeGroup(grp);
c.group := 0;
end; // removeFromRoster
@ -3438,8 +3455,7 @@ begin
EK_ADDEDYOU:
if ev.who.isInList(LT_ROSTER) then
msgDlg(getTranslation('%s added you to his/her contact list.', [ev.who.displayed]), False, mtInformation)
else if messageDlg
(getTranslation('%s added you to his/her contact list.\nDo you want to add him/her to your contact list?',
else if messageDlg(getTranslation('%s added you to his/her contact list.\nDo you want to add him/her to your contact list?',
[ev.who.displayed]), mtConfirmation, [mbYes, mbNo], 0) = mrYes then
addToRoster((ev.who));
EK_AUTHREQ:
@ -3472,9 +3488,8 @@ begin
// end;
end;
EK_CONTACTS:
TselectCntsFrm.doAll2(RnQmain, getTranslation('from %s', [ev.who.displayed]),
getTranslation('Add selected contacts'), ev.who.fProto, ev.cl.clone, RnQmain.addContactsAction,
[sco_multi, sco_selected], @wnd)
TselectCntsFrm.doAll2(RnQmain, getTranslation('from %s', [ev.who.displayed]), getTranslation('Add selected contacts'),
ev.who.fProto, ev.cl.clone, RnQmain.addContactsAction, [sco_multi, sco_selected], @wnd)
end;
try
// FreeAndNil(ev);
@ -3948,8 +3963,7 @@ begin
n := length(availableUsers);
for i := 0 to n - 2 do
for j := i + 1 to n - 1 do
swap4(availableUsers[i], availableUsers[j], sizeof(availableUsers[i]),
availableUsers[i].uin > availableUsers[j].uin);
swap4(availableUsers[i], availableUsers[j], sizeof(availableUsers[i]), availableUsers[i].uin > availableUsers[j].uin);
end; // refreshAvailableUsers
procedure assignImgPic(img: TImage; picName: String);
@ -4077,8 +4091,8 @@ end; // toggleMainfrmBorder
function unexistant(const uin: TUID): Boolean;
begin
result := not(Account.AccProto.getMyInfo.equals(uin)) and not Account.AccProto.readList(LT_ROSTER)
.exists(Account.AccProto, uin) and not notInlist.exists(Account.AccProto, uin)
result := not(Account.AccProto.getMyInfo.equals(uin)) and not Account.AccProto.readList(LT_ROSTER).exists(Account.AccProto, uin)
and not notInlist.exists(Account.AccProto, uin)
end; // unexistant
function findInAvailableUsers(const uin: TUID): integer;
@ -4100,8 +4114,7 @@ begin
SetWindowRgn(hnd, 0, True)
end;
procedure drawHint(cnv: Tcanvas; kind: integer; groupid: integer; c: TRnQContact; var r: Trect;
calcOnly: Boolean = False);
procedure drawHint(cnv: Tcanvas; kind: integer; groupid: integer; c: TRnQContact; var r: Trect; calcOnly: Boolean = False);
const border = 5; roundsize = 16; maxWidth = 300;
var
// n:Tnode;
@ -4585,12 +4598,12 @@ begin
case ev.kind of
EK_MSG, EK_AUTHREQ:
if (be_BALLOON in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0) and
not Account.AccProto.getStatusDisable.tips then
if (be_BALLOON in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0) and not Account.AccProto.getStatusDisable.tips
then
statusIcon.showballoon(counter, s, ev.who.displayed + ' ' + getTranslation(tipevent2str[ev.kind]), bitinfo);
EK_offgoing, EK_oncoming, EK_typingFin, EK_typingBeg:
if (be_BALLOON in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0) and
not Account.AccProto.getStatusDisable.tips then
if (be_BALLOON in behaviour[ev.kind].trig) and (ev.flags and IF_offline = 0) and not Account.AccProto.getStatusDisable.tips
then
statusIcon.showballoon(counter, ev.who.displayed, getTranslation(tipevent2str[ev.kind]), bitinfo);
end;
end;


+ 4
- 0
clear_all.bat View File

@ -0,0 +1,4 @@
cd "%cd%\for.RnQ"
cmd /C clear.bat
cd ..\RnQ
cmd /C clear.bat

+ 2187
- 0
for.RnQ/RTL/Bitmap32.pas View File

@ -0,0 +1,2187 @@
unit Bitmap32;
interface
uses
Windows, Classes, SysUtils, Messages, Controls, Graphics;
type
TColor32 = type Longword;
PColor32 = ^TColor32;
TColor32Array = array [0..0] of TColor32;
PColor32Array = ^TColor32Array;
TPalette32 = array [Byte] of TColor32;
PPalette32 = ^TPalette32;
TColor32Component = (ccBlue, ccGreen, ccRed, ccAlpha);
TColor32Components = set of TColor32Component;
PColor32Entry = ^TColor32Entry;
TColor32Entry = packed record
case Integer of
0: (B, G, R, A: Byte);
1: (ARGB: TColor32);
2: (Planes: array[0..3] of Byte);
3: (Components: array[TColor32Component] of Byte);
end;
TScaleMode = (smNormal, smStretch, smScale, smResize);
TBitmapAlign = (baTopLeft, baCenter);
TSpriteOrigin = (soImage, soBitmap);
const
{$WRITEABLECONST OFF}
clBlack32 : TColor32 = $FF000000;
clDimGray32 : TColor32 = $FF3F3F3F;
clGray32 : TColor32 = $FF7F7F7F;
clLightGray32 : TColor32 = $FFBFBFBF;
clWhite32 : TColor32 = $FFFFFFFF;
clMaroon32 : TColor32 = $FF7F0000;
clGreen32 : TColor32 = $FF007F00;
clOlive32 : TColor32 = $FF7F7F00;
clNavy32 : TColor32 = $FF00007F;
clPurple32 : TColor32 = $FF7F007F;
clTeal32 : TColor32 = $FF007F7F;
clRed32 : TColor32 = $FFFF0000;
clLime32 : TColor32 = $FF00FF00;
clYellow32 : TColor32 = $FFFFFF00;
clBlue32 : TColor32 = $FF0000FF;
clFuchsia32 : TColor32 = $FFFF00FF;
clAqua32 : TColor32 = $FF00FFFF;
clTrWhite32 : TColor32 = $7FFFFFFF;
clTrBlack32 : TColor32 = $7F000000;
clTrRed32 : TColor32 = $7FFF0000;
clTrGreen32 : TColor32 = $7F00FF00;
clTrBlue32 : TColor32 = $7F0000FF;
function Color32(WinColor: TColor): TColor32; overload;
function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32;
function WinColor(Color32: TColor32): TColor;
function RedComponent(Color32: TColor32): Integer;
function GreenComponent(Color32: TColor32): Integer;
function BlueComponent(Color32: TColor32): Integer;
function AlphaComponent(Color32: TColor32): Integer;
function Intensity(Color32: TColor32): Integer;
function SetAlpha(Color32: TColor32; NewAlpha: Integer): TColor32;
function HSLtoRGB(H, S, L: Single): TColor32;
procedure RGBtoHSL(RGB: TColor32; var H, S, L : Single);
function ColorMix(C1, C2: TColor32; W1, W2: Integer): TColor32;
function ColorAdd(C1, C2: TColor32): TColor32;
function ColorSub(C1, C2: TColor32): TColor32;
function ColorModulate(C1, C2: TColor32): TColor32;
function ColorMax(C1, C2: TColor32): TColor32;
function ColorMin(C1, C2: TColor32): TColor32;
type
TThreadPersistent = class(TPersistent)
private
FLock: TRTLCriticalSection;
FLockCount: Integer;
FUpdateCount: Integer;
FOnChange: TNotifyEvent;
public
constructor Create; virtual;
destructor Destroy; override;
procedure Changed(Sender: TObject); virtual;
procedure BeginUpdate;
procedure EndUpdate;
procedure Lock;
procedure Unlock;
property LockCount: Integer read FLockCount;
property UpdateCount: Integer read FUpdateCount;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
TFont32 = class(TFont)
private
FEscapement: Integer;
procedure SetEscapement(const Value: Integer);
published
property Escapement: Integer read FEscapement write SetEscapement;
end;
TBitmap32 = class(TThreadPersistent)
private
FAutoAlphaMult: Boolean;
FBitmapInfo: TBitmapInfo;
FBitmapInfoHeader: TBitmapInfoHeader;
FBits: PColor32Array;
FFont: TFont32;
FHandle: THandle;
FHeight: Integer;
FHDC: HDC;
FMasterAlpha: Byte;
FOuterColor: TColor32;
FSmoothResize: Boolean;
FTransparent: Boolean;
FTransparentColor: TColor32;
FWidth: Integer;
FUseAlpha: Boolean;
function GetPixel(X, Y: Integer): TColor32;
function GetPixelS(X, Y: Integer): TColor32;
function GetPixelPtr(X, Y: Integer): PColor32;
function GetScanLine(Y: Integer): PColor32;
procedure SetAutoAlphaMult(const Value: Boolean);
procedure SetFont(Value: TFont32);
procedure SetMasterAlpha(const Value: Byte);
procedure SetHeight(Value: Integer);
procedure SetPixel(X, Y: Integer; Value: TColor32);
procedure SetPixelS(X, Y: Integer; Value: TColor32);
procedure SetSmoothResize(Value: Boolean);
procedure SetTransparent(const Value: Boolean);
procedure SetTransparentColor(const Value: TColor32);
procedure SetUseAlpha(const Value: Boolean);
procedure SetWidth(Value: Integer);
protected
FontHandle: HFont;
function ClipLine(var X0, Y0, X1, Y1: Integer): Boolean;
function ClipLineF(var X0, Y0, X1, Y1: Single; MinX, MaxX, MinY, MaxY: Single): Boolean;
procedure FontChanged(Sender: TObject);
procedure SET_T(Ptr: PColor32; A, C: Integer);
procedure SET_T256(X, Y: Integer; C: Integer);
procedure SET_TS256(X, Y: Integer; C: Integer);
procedure ReadData(Stream: TStream); virtual;
procedure WriteData(Stream: TStream); virtual;
procedure DefineProperties(Filer: TFiler); override;
public
constructor Create; override;
destructor Destroy; override;
procedure Assign(Source: TPersistent); override;
procedure AssignTo(Dst: TPersistent); override;
procedure SetSize(NewWidth, NewHeight: Integer); overload; virtual;
procedure SetSize(Source: TBitmap32); overload; virtual;
procedure Resize(NewWidth, NewHeight: Integer); virtual;
function Empty: Boolean;
procedure Clear; overload;
procedure Clear(FillColor: TColor32); overload;
procedure LoadFromStream(Stream: TStream);
procedure SaveToStream(Stream: TStream);
procedure LoadFromFile(const FileName: string);
procedure SaveToFile(const FileName: string);
procedure PreMultAlpha;
procedure ResetAlpha;
procedure DrawOpaque(hDst: HDC); overload;
procedure DrawOpaque(hDst: HDC; X, Y: Integer); overload; // BitBlt to hDst
procedure DrawOpaque(hDst: HDC; const Dst: TRect); overload;
procedure DrawOpaque(hDst: HDC; const Dst, Src: TRect); overload;
procedure DrawTransparent(hDst: HDC); overload;
procedure DrawTransparent(hDst: HDC; X, Y: Integer); overload;
procedure DrawTransparent(hDst: HDC; const Dst: TRect); overload;
procedure DrawTransparent(hDst: HDC; const Dst, Src: TRect); overload;
procedure DrawBlend(hDst: HDC); overload;
procedure DrawBlend(hDst: HDC; X, Y: Integer); overload;
procedure DrawBlend(hDst: HDC; const Dst: TRect); overload;
procedure DrawBlend(hDst: HDC; const Dst, Src: TRect); overload;
procedure Draw(hDst: HDC); overload;
procedure Draw(hDst: HDC; X, Y: Integer); overload;
procedure Draw(hDst: HDC; const Dst: TRect); overload;
procedure Draw(hDst: HDC; const Dst, Src: TRect); overload;
procedure SetPixelT(X, Y: Integer; Value: TColor32); overload;
procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload;
procedure SetPixelTS(X, Y: Integer; Value: TColor32);
procedure SetPixelF(X, Y: Single; Value: TColor32);
procedure SetPixelFS(X, Y: Single; Value: TColor32);
procedure DrawHorzLine(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineS(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineT(X1, Y, X2: Integer; Value: TColor32);
procedure DrawHorzLineTS(X1, Y, X2: Integer; Value: TColor32);
procedure DrawVertLine(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineS(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineT(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawVertLineTS(X, Y1, Y2: Integer; Value: TColor32);
procedure DrawLine(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineT(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineA(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineAS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure DrawLineF(X1, Y1, X2, Y2: Single; Value: TColor32);
procedure DrawLineFS(X1, Y1, X2, Y2: Single; Value: TColor32);
procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);
procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);
procedure UpdateFont;
procedure TextOut(X, Y: Integer; const Text: string); overload;
procedure TextOut(X, Y: Integer; const ClipRect: TRect; const Text: string); overload;
procedure TextOut(ClipRect: TRect; const Flags: Cardinal; const Text: string); overload;
function TextExtent(const Text: string): TSize;
function TextHeight(const Text: string): Integer;
function TextWidth(const Text: string): Integer;
procedure ColorToGrayscale(ColorSrc: TBitmap32 = nil);
procedure AlphaToGrayscale(AlphaSrc: TBitmap32 = nil);
procedure IntensityToAlpha(IntensitySrc: TBitmap32 = nil);
procedure Invert(Src: TBitmap32 = nil);
property Handle: HDC read FHDC;
property Bits: PColor32Array read FBits; // use this array for direct access
property ScanLine[Y: Integer]: PColor32 read GetScanLine;
property Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default;
property PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS;
property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;
property Height: Integer read FHeight write SetHeight;
property Width: Integer read FWidth write SetWidth;
published
property AutoAlphaMult: Boolean read FAutoAlphaMult write SetAutoAlphaMult;
property Font: TFont32 read FFont write SetFont;
property MasterAlpha: Byte read FMasterAlpha write SetMasterAlpha;
property OuterColor: TColor32 read FOuterColor write FOuterColor default $00000000;
property SmoothResize: Boolean read FSmoothResize write SetSmoothResize;
property Transparent: Boolean read FTransparent write SetTransparent;
property TransparentColor: TColor32 read FTransparentColor write SetTransparentColor;
property UseAlpha: Boolean read FUseAlpha write SetUseAlpha;
property OnChange: TNotifyEvent read FOnChange write FOnChange;
end;
PColorEntry = ^TColorEntry;
TColorEntry = record
Name: string[31];
Color: TColor32;
end;
var
GAMMA_TABLE: array [Byte] of Byte;
procedure SetGamma(Gamma: Single = 0.7);
implementation
uses Math, TypInfo, Clipbrd;
const
_R : TColor32 = $00FF0000;
_G : TColor32 = $0000FF00;
_B : TColor32 = $000000FF;
_RGB : TColor32 = $00FFFFFF;
var
Bitmap32CounterLock: TRTLCriticalSection;
StockFont: HFONT;
function Clamp(Value: Integer): TColor32;
begin
if Value < 0 then Result := 0
else if Value > 255 then Result := 255
else Result := Value;
end;
procedure FillLongword(var X; Count: Integer; Value: Longword);
var
I: Integer;
P: PIntegerArray;
begin
P := PIntegerArray(@X);
for I := Count - 1 downto 0 do
P[I] := Integer(Value);
end;
procedure Swap(var A, B: Integer);
var
T: Integer;
begin
T := A;
A := B;
B := T;
end;
procedure TestSwap(var A, B: Integer);
var
T: Integer;
begin
if B < A then
begin
T := A;
A := B;
B := T;
end;
end;
function TestClip(var A, B: Integer; const Size: Integer): Boolean;
begin
TestSwap(A, B);
if A < 0 then
A := 0;
if B >= Size then
B := Size - 1;
Result := B >= A;
end;
type
TGraphicAccess = class(TGraphic);
function ColorSwap(WinColor: TColor): TColor32; register; assembler;
var
WCEn: TColor32Entry absolute WinColor;
REn : TColor32Entry absolute Result;
begin
Result := WCEn.ARGB;
REn.A := $FF;
REn.R := WCEn.B;
REn.B := WCEn.R;
end;
function Color32(WinColor: TColor): TColor32; overload;
begin
WinColor := ColorToRGB(WinColor);
Result := ColorSwap(WinColor);
end;
function Color32(R, G, B: Byte; A: Byte = $FF): TColor32; overload;
begin
Result := A shl 24 + R shl 16 + G shl 8 + B;
end;
function Color32(Index: Byte; var Palette: TPalette32): TColor32; overload;
begin
Result := Palette[Index];
end;
function Gray32(Intensity: Byte; Alpha: Byte = $FF): TColor32;
begin
Result := TColor32(Alpha) shl 24 + TColor32(Intensity) shl 16 +
TColor32(Intensity) shl 8 + TColor32(Intensity);
end;
function WinColor(Color32: TColor32): TColor;
begin
Result := (Color32 and _R shr 16) or (Color32 and _G) or
(Color32 and _B shl 16);
end;
function RedComponent(Color32: TColor32): Integer;
begin
Result := Color32 and _R shr 16;
end;
function GreenComponent(Color32: TColor32): Integer;
begin
Result := Color32 and _G shr 8;
end;
function BlueComponent(Color32: TColor32): Integer;
begin
Result := Color32 and _B;
end;
function AlphaComponent(Color32: TColor32): Integer;
begin
Result := Color32 shr 24;
end;
function Intensity(Color32: TColor32): Integer;
begin
Result := ((Color32 and _R shr 16) * 54 + (Color32 and _G shr 8) * 182 +
(Color32 and _B) * 19) shr 8;