From 58b24b35ec012e408407c9bca7510d4bbf64ad55 Mon Sep 17 00:00:00 2001 From: Andreas Schneider Date: Fri, 1 May 2015 12:48:35 +0200 Subject: [PATCH] * Fixed compilation with FPC 3.1.1 and Lazarus 1.5 --- Client/CentrED.lpr | 2 +- Client/GUI/AeroGlass.pas | 444 ++++++++++++++++++------------------- Client/GUI/VirtualList.pas | 8 +- Client/UfrmMain.lfm | 132 ++++++----- Client/UfrmMain.pas | 270 ++++++++++------------ UCacheManager.pas | 4 +- 6 files changed, 408 insertions(+), 452 deletions(-) diff --git a/Client/CentrED.lpr b/Client/CentrED.lpr index b39a3fe..9caeae6 100644 --- a/Client/CentrED.lpr +++ b/Client/CentrED.lpr @@ -36,7 +36,7 @@ uses Forms, Dialogs, Windows, UdmNetwork, UResourceManager; {$R CentrED.res} -{$R CentrED.manifest.rc} +//{$R CentrED.manifest.rc} function GetApplicationName: String; begin diff --git a/Client/GUI/AeroGlass.pas b/Client/GUI/AeroGlass.pas index f7a413a..f8f653a 100644 --- a/Client/GUI/AeroGlass.pas +++ b/Client/GUI/AeroGlass.pas @@ -1,222 +1,222 @@ -unit AeroGlass; - -{$mode delphi} -//{$mode objfpc}{$H+} - -interface - -uses - //Windows, Forms, Graphics; - // os - Windows, UxTheme, ShellAPI, Win32Proc, Win32Extra, - // rtl - Classes, SysUtils, - // lcl - Forms, Controls, Graphics, Themes;//, LCLProc, LCLType; - -type - _MARGINS = packed record - cxLeftWidth : Integer; - cxRightWidth : Integer; - cyTopHeight : Integer; - cyBottomHeight : Integer; - end; - - PMargins = ^_MARGINS; - TMargins = _MARGINS; - - DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall; - DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall; - SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall; - -const - WS_EX_LAYERED = $80000; - LWA_COLORKEY = 1; - -procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia); -procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia); -function WindowsAeroGlassCompatible: Boolean; - -function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP; -procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString); - - -implementation - -// ============================================================================= -// == Преобразование формы в AeroGlass -// ============================================================================= - -function WindowsAeroGlassCompatible: Boolean; -var - osVinfo: TOSVERSIONINFO; -begin - ZeroMemory(@osVinfo, SizeOf(osVinfo)); - OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO); - if ( - (GetVersionEx(osVInfo) = True) and - (osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and - (osVinfo.dwMajorVersion >= 6) - ) - then Result:=True - else Result:=False; -end; - -procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia); -var - hDwmDLL: Cardinal; - fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc; - fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc; - fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc; - bCmpEnable: Boolean; - mgn: TMargins; -begin - { Continue if Windows version is compatible } - if WindowsAeroGlassCompatible then begin - { Continue if 'dwmapi' library is loaded } - hDwmDLL := LoadLibrary('dwmapi.dll'); - if hDwmDLL <> 0 then begin - { Get values } - @fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled'); - @fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea'); - @fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes'); - { Continue if values are <> nil } - if ( - (@fDwmIsCompositionEnabled <> nil) and - (@fDwmExtendFrameIntoClientArea <> nil) and - (@fSetLayeredWindowAttributesFunc <> nil) - ) - then begin - { Continue if composition is enabled } - fDwmIsCompositionEnabled(@bCmpEnable); - if bCmpEnable = True then begin - { Set Form Color same as cBlurColorKey } - frm.Color := cBlurColorKey; - { ... } - SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED); - { ... } - fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY); - { Set margins } - ZeroMemory(@mgn, SizeOf(mgn)); - mgn.cxLeftWidth := tmpMargins.cxLeftWidth; - mgn.cxRightWidth := tmpMargins.cxRightWidth; - mgn.cyTopHeight := tmpMargins.cyTopHeight; - mgn.cyBottomHeight := tmpMargins.cyBottomHeight; - { Extend Form } - fDwmExtendFrameIntoClientArea(frm.Handle,@mgn); - end; - end; - { Free loaded 'dwmapi' library } - FreeLibrary(hDWMDLL); - end; - end; -end; - -procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia); -var - tmpMargins: TMargins; -begin - { If all margins are -1 the whole form will be aero glass} - tmpMargins.cxLeftWidth := 8; - tmpMargins.cxRightWidth := 8; - tmpMargins.cyBottomHeight := 25; - tmpMargins.cyTopHeight := 4; - { FormName ; Margins ; TransparentColor } - GlassFormEx(frm, tmpMargins, cBlurColorKey); -end; - -// ============================================================================= -// == Вывод текста и изображений на форме AeroGlass -// ============================================================================= - -function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP; -var - bi: BITMAPINFO; -begin - ZeroMemory(@bi, sizeof(BITMAPINFO)); - with bi.bmiHeader do - begin - biSize := sizeof(BITMAPINFOHEADER); - biWidth := W; - biHeight := -H; - biCompression := BI_RGB; - biBitCount := 32; - biPlanes := 1; - biXPelsPerMeter := 0; - biYPelsPerMeter := 0; - biClrUsed := 0; - biClrImportant := 0; - end; - Result := CreateDIBSection(DC, bi, DIB_RGB_COLORS, BitmapBits, 0, 0); -end; - -type - TDTTOpts = record - dwSize: Longword; - dwFlags: Longword; - crText: Longword; - crBorder: Longword; - crShadow: Longword; - eTextShadowType: Integer; - ptShadowOffset: TPoint; - iBorderSize: Integer; - iFontPropId: Integer; - iColorPropId: Integer; - iStateId: Integer; - fApplyOverlay: Integer; - iGlowSize: Integer; - pfnDrawTextCallback: Pointer; - lParam: Integer; - end; - -var - hTheme: THandle; - -procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString); -var - tr: trect; - txtOptions: TDTTOPTS; - hBmp: HBITMAP; - hBmpDC: HDC; - hFnt: HFont; - p: pointer; - ts: SIZE; -begin - hTheme := OpenThemeData(wnd, 'window'); - - hBmpDC := CreateCompatibleDC(0); - - hFnt := CreateFont(-MulDiv(10, GetDeviceCaps(hBmpDC, LOGPIXELSY), 72), 0, 0, 0, FW_BOLD {FW_NORMAL}, 0, 0, 0, - DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'arial'); - - SelectObject(hBmpDC, hFnt); - - GetTextExtentPointW(hBmpDC, PWideChar(txt), length(txt), ts); - - SetRect(tr, 0, 0, ts.cx + 5, ts.cy + 5); - - hBmp := CreateBitmap32(hBmpDC, tr.Right, tr.Bottom, p); - SelectObject(hBmpDC, hBmp); - - ZeroMemory(@txtOptions, sizeof(TDTTOPTS)); - txtOptions.dwSize := sizeof(TDTTOPTS); - txtOptions.dwFlags := DTT_COMPOSITED or DTT_GLOWSIZE or DTT_TEXTCOLOR; - txtOptions.iGlowSize := 5; - txtOptions.crText := $00FF0000; - - DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, @tr, @txtOptions); - - BitBlt(dc, x, y, tr.Right, tr.Bottom, hBmpDC, 0, 0, SRCCOPY); - - DeleteObject(hBmpDC); - DeleteObject(hBmp); - DeleteObject(hFnt); - - CloseThemeData(hTheme); -end; - - - - - -end. +unit AeroGlass; + +{$mode delphi} +//{$mode objfpc}{$H+} + +interface + +uses + //Windows, Forms, Graphics; + // os + Windows, UxTheme, ShellAPI, Win32Proc, Win32Extra, + // rtl + Classes, SysUtils, + // lcl + Forms, Controls, Graphics, Themes;//, LCLProc, LCLType; + +type + _MARGINS = packed record + cxLeftWidth : Integer; + cxRightWidth : Integer; + cyTopHeight : Integer; + cyBottomHeight : Integer; + end; + + PMargins = ^_MARGINS; + TMargins = _MARGINS; + + DwmIsCompositionEnabledFunc = function(pfEnabled: PBoolean): HRESULT; stdcall; + DwmExtendFrameIntoClientAreaFunc = function(destWnd: HWND; const pMarInset: PMargins): HRESULT; stdcall; + SetLayeredWindowAttributesFunc = function(destWnd: HWND; cKey: TColor; bAlpha: Byte; dwFlags: DWord): BOOL; stdcall; + +const + WS_EX_LAYERED = $80000; + LWA_COLORKEY = 1; + +procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia); +procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia); +function WindowsAeroGlassCompatible: Boolean; + +function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP; +procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString); + + +implementation + +// ============================================================================= +// == Преобразование формы в AeroGlass +// ============================================================================= + +function WindowsAeroGlassCompatible: Boolean; +var + osVinfo: TOSVERSIONINFO; +begin + ZeroMemory(@osVinfo, SizeOf(osVinfo)); + OsVinfo.dwOSVersionInfoSize := SizeOf(TOSVERSIONINFO); + if ( + (GetVersionEx(osVInfo) = True) and + (osVinfo.dwPlatformId = VER_PLATFORM_WIN32_NT) and + (osVinfo.dwMajorVersion >= 6) + ) + then Result:=True + else Result:=False; +end; + +procedure GlassFormEx(frm: TForm; tmpMargins: TMargins; cBlurColorKey: TColor = clFuchsia); +var + hDwmDLL: Cardinal; + fDwmIsCompositionEnabled: DwmIsCompositionEnabledFunc; + fDwmExtendFrameIntoClientArea: DwmExtendFrameIntoClientAreaFunc; + fSetLayeredWindowAttributesFunc: SetLayeredWindowAttributesFunc; + bCmpEnable: Boolean; + mgn: TMargins; +begin + { Continue if Windows version is compatible } + if WindowsAeroGlassCompatible then begin + { Continue if 'dwmapi' library is loaded } + hDwmDLL := LoadLibrary('dwmapi.dll'); + if hDwmDLL <> 0 then begin + { Get values } + @fDwmIsCompositionEnabled := GetProcAddress(hDwmDLL, 'DwmIsCompositionEnabled'); + @fDwmExtendFrameIntoClientArea := GetProcAddress(hDwmDLL, 'DwmExtendFrameIntoClientArea'); + @fSetLayeredWindowAttributesFunc := GetProcAddress(GetModulehandle(user32), 'SetLayeredWindowAttributes'); + { Continue if values are <> nil } + if ( + (@fDwmIsCompositionEnabled <> nil) and + (@fDwmExtendFrameIntoClientArea <> nil) and + (@fSetLayeredWindowAttributesFunc <> nil) + ) + then begin + { Continue if composition is enabled } + fDwmIsCompositionEnabled(@bCmpEnable); + if bCmpEnable = True then begin + { Set Form Color same as cBlurColorKey } + frm.Color := cBlurColorKey; + { ... } + SetWindowLong(frm.Handle, GWL_EXSTYLE, GetWindowLong(frm.Handle, GWL_EXSTYLE) or WS_EX_LAYERED); + { ... } + fSetLayeredWindowAttributesFunc(frm.Handle, cBlurColorKey, 0, LWA_COLORKEY); + { Set margins } + ZeroMemory(@mgn, SizeOf(mgn)); + mgn.cxLeftWidth := tmpMargins.cxLeftWidth; + mgn.cxRightWidth := tmpMargins.cxRightWidth; + mgn.cyTopHeight := tmpMargins.cyTopHeight; + mgn.cyBottomHeight := tmpMargins.cyBottomHeight; + { Extend Form } + fDwmExtendFrameIntoClientArea(frm.Handle,@mgn); + end; + end; + { Free loaded 'dwmapi' library } + FreeLibrary(hDWMDLL); + end; + end; +end; + +procedure GlassForm(frm: TForm; cBlurColorKey: TColor = clFuchsia); +var + tmpMargins: TMargins; +begin + { If all margins are -1 the whole form will be aero glass} + tmpMargins.cxLeftWidth := 8; + tmpMargins.cxRightWidth := 8; + tmpMargins.cyBottomHeight := 25; + tmpMargins.cyTopHeight := 4; + { FormName ; Margins ; TransparentColor } + GlassFormEx(frm, tmpMargins, cBlurColorKey); +end; + +// ============================================================================= +// == Вывод текста и изображений на форме AeroGlass +// ============================================================================= + +function CreateBitmap32(DC: HDC; W, H: Integer; var BitmapBits: Pointer): HBITMAP; +var + bi: BITMAPINFO; +begin + ZeroMemory(@bi, sizeof(BITMAPINFO)); + with bi.bmiHeader do + begin + biSize := sizeof(BITMAPINFOHEADER); + biWidth := W; + biHeight := -H; + biCompression := BI_RGB; + biBitCount := 32; + biPlanes := 1; + biXPelsPerMeter := 0; + biYPelsPerMeter := 0; + biClrUsed := 0; + biClrImportant := 0; + end; + Result := CreateDIBSection(DC, bi, DIB_RGB_COLORS, BitmapBits, 0, 0); +end; + +type + TDTTOpts = record + dwSize: Longword; + dwFlags: Longword; + crText: Longword; + crBorder: Longword; + crShadow: Longword; + eTextShadowType: Integer; + ptShadowOffset: TPoint; + iBorderSize: Integer; + iFontPropId: Integer; + iColorPropId: Integer; + iStateId: Integer; + fApplyOverlay: Integer; + iGlowSize: Integer; + pfnDrawTextCallback: Pointer; + lParam: Integer; + end; + +var + hTheme: THandle; + +procedure DrawAlphaText(wnd: hwnd; DC: HDC; x,y: integer; txt: WideString); +var + tr: trect; + txtOptions: TDTTOPTS; + hBmp: HBITMAP; + hBmpDC: HDC; + hFnt: HFont; + p: pointer; + ts: SIZE; +begin + hTheme := OpenThemeData(wnd, 'window'); + + hBmpDC := CreateCompatibleDC(0); + + hFnt := CreateFont(-MulDiv(10, GetDeviceCaps(hBmpDC, LOGPIXELSY), 72), 0, 0, 0, FW_BOLD {FW_NORMAL}, 0, 0, 0, + DEFAULT_CHARSET, OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY, DEFAULT_PITCH, 'arial'); + + SelectObject(hBmpDC, hFnt); + + GetTextExtentPointW(hBmpDC, PWideChar(txt), length(txt), ts); + + SetRect(tr, 0, 0, ts.cx + 5, ts.cy + 5); + + hBmp := CreateBitmap32(hBmpDC, tr.Right, tr.Bottom, p); + SelectObject(hBmpDC, hBmp); + + ZeroMemory(@txtOptions, sizeof(TDTTOPTS)); + txtOptions.dwSize := sizeof(TDTTOPTS); + txtOptions.dwFlags := DTT_COMPOSITED or DTT_GLOWSIZE or DTT_TEXTCOLOR; + txtOptions.iGlowSize := 5; + txtOptions.crText := $00FF0000; + + DrawThemeTextEx(hTheme, hBmpDC, 0, 0, PWideChar(txt), length(txt), DT_SINGLELINE or DT_vCENTER, @tr, @txtOptions); + + BitBlt(dc, x, y, tr.Right, tr.Bottom, hBmpDC, 0, 0, SRCCOPY); + + DeleteObject(hBmpDC); + DeleteObject(hBmp); + DeleteObject(hFnt); + + CloseThemeData(hTheme); +end; + + + + + +end. diff --git a/Client/GUI/VirtualList.pas b/Client/GUI/VirtualList.pas index 511c89d..6504b67 100644 --- a/Client/GUI/VirtualList.pas +++ b/Client/GUI/VirtualList.pas @@ -28,6 +28,8 @@ type Selected: Boolean; end; + { TVirtualList } + TVirtualList = class(TVirtualDrawTree) private @@ -75,7 +77,7 @@ type procedure HandleMouseDblClick(var Message: TLMMouse; const HitInfo: THitInfo); override; procedure HandleMouseDown(var Message: TLMMouse; var HitInfo: THitInfo); override; - procedure HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo); override; + procedure HandleMouseUp(Keys: PtrUInt; const HitInfo: THitInfo); override; property SelectedCount: Dword read FSelectionCount; property TilesCount: Dword read FTilesCount; @@ -690,10 +692,10 @@ begin end; -procedure TVirtualList.HandleMouseUp(var Message: TLMMouse; const HitInfo: THitInfo); +procedure TVirtualList.HandleMouseUp(Keys: PtrUInt; const HitInfo: THitInfo); begin //Logger.Send([lcClient, lcDebug], 'TVirtualTree.HandleMouseUp %s', ['Start']); - inherited HandleMouseUp(Message, HitInfo); + inherited HandleMouseUp(Keys, HitInfo); end; //---------------------------------------------------------------------------------------------------------------------- diff --git a/Client/UfrmMain.lfm b/Client/UfrmMain.lfm index 0ece062..b7a77b0 100644 --- a/Client/UfrmMain.lfm +++ b/Client/UfrmMain.lfm @@ -1,10 +1,10 @@ object frmMain: TfrmMain - Left = 294 + Left = 290 Height = 680 Top = 123 Width = 982 Caption = 'UO CentrED+' - ClientHeight = 660 + ClientHeight = 659 ClientWidth = 982 Constraints.MinHeight = 680 Constraints.MinWidth = 980 @@ -18,24 +18,23 @@ object frmMain: TfrmMain OnShow = FormShow OnWindowStateChange = FormWindowStateChange SessionProperties = 'acFlat.Checked;acLightlevel.Tag;acNoDraw.Checked;acStatics.Checked;acTerrain.Checked;acWalkable.Checked;cbStatics.Checked;cbTerrain.Checked;Height;Left;mnuAutoHideGroupList.Checked;mnuAutoHideGroupList.Tag;mnuAutoHideRandomList.Checked;mnuAutoHideRandomList.Tag;mnuAutoShowFilterWindow.Checked;mnuCompactHueSettings.Checked;mnuFlatShowHeight.Checked;mnuMiscTileListCentre.Checked;mnuMiscTileListClip.Checked;mnuMiscTileListDrawInfo.Checked;mnuMiscTileListLarge.Checked;mnuMiscTileListMidle.Checked;mnuMiscTileListSmall.Checked;mnuMiscTileListStretch.Checked;mnuMiscTileListTable.Checked;mnuSecurityQuestion.Checked;mnuShowAnimations.Checked;mnuShowBlocks.Checked;mnuShowBridges.Checked;mnuShowFoliage.Checked;mnuShowGrid.Checked;mnuShowLightSource.Checked;mnuShowNoDrawTiles.Checked;mnuShowRoofs.Checked;mnuShowSurfaces.Checked;mnuShowWalls.Checked;mnuShowWater.Checked;mnuTileListCentre.Checked;mnuTileListClip.Checked;mnuTileListDrawInfo.Checked;mnuTileListLarge.Checked;mnuTileListMidle.Checked;mnuTileListSmall.Checked;mnuTileListStretch.Checked;mnuTileListTable.Checked;mnuWhiteBackground.Checked;mnuWindowedMode.Checked;mnuWindowedMode.Tag;pcLeft.TabIndex;spGroupList.Top;spTileList.Top;Tag;Top;Width;WindowState;mnuMiscTileListDrawInfo.Enabled;mnuTileListDrawInfo.Enabled' - LCLVersion = '0.9.30.2' + LCLVersion = '1.5' WindowState = wsMaximized object pcLeft: TPageControl Cursor = crArrow Left = 0 - Height = 660 + Height = 659 Top = 0 Width = 224 ActivePage = tsTiles Align = alLeft TabIndex = 0 TabOrder = 0 - OnChange = pcLeftChange OnResize = pcLeftResize object tsTiles: TTabSheet Caption = ' Тайлы ' - ClientHeight = 634 - ClientWidth = 216 + ClientHeight = 632 + ClientWidth = 220 object vdtTiles: TVirtualDrawTree Tag = -1 AnchorSideLeft.Control = tsTiles @@ -47,8 +46,8 @@ object frmMain: TfrmMain Left = 0 Height = 64 Hint = '-' - Top = 295 - Width = 213 + Top = 293 + Width = 217 Anchors = [akTop, akLeft, akRight, akBottom] BorderSpacing.Top = 1 BorderSpacing.Right = 3 @@ -193,7 +192,7 @@ object frmMain: TfrmMain Left = 0 Height = 5 Top = 290 - Width = 216 + Width = 220 Align = alNone Anchors = [akTop, akLeft, akRight] OnMoved = spTileListMoved @@ -204,10 +203,10 @@ object frmMain: TfrmMain AnchorSideLeft.Side = asrBottom AnchorSideTop.Control = tsTiles Cursor = crArrow - Left = 79 - Height = 14 + Left = 92 + Height = 13 Top = 0 - Width = 85 + Width = 97 BorderSpacing.Left = 16 Caption = 'Фильтр / Поиск:' ParentColor = False @@ -220,15 +219,15 @@ object frmMain: TfrmMain AnchorSideBottom.Control = tsTiles Cursor = crArrow Left = 0 - Height = 339 + Height = 337 Top = 295 - Width = 216 + Width = 220 Align = alBottom Anchors = [akTop, akLeft, akRight, akBottom] BidiMode = bdRightToLeft Caption = 'Набор случайных тайлов' - ClientHeight = 321 - ClientWidth = 212 + ClientHeight = 323 + ClientWidth = 218 Constraints.MinHeight = 1 ParentBidiMode = False ParentColor = False @@ -279,7 +278,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnAddRandomClick ShowCaption = False ShowHint = True @@ -333,7 +331,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnDeleteRandomClick ShowCaption = False ShowHint = True @@ -388,7 +385,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnClearRandomClick ShowCaption = False ShowHint = True @@ -399,10 +395,10 @@ object frmMain: TfrmMain AnchorSideTop.Control = cbRandomPreset AnchorSideRight.Control = btnRandomPresetDelete Cursor = crArrow - Left = 162 + Left = 168 Height = 22 Hint = 'Сохранить набор' - Top = 296 + Top = 294 Width = 22 Anchors = [akTop, akRight] BorderSpacing.Right = 4 @@ -442,7 +438,6 @@ object frmMain: TfrmMain 4DFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B4FFFC5894BFFC476 3BFF000000000000000000000000000000000000000000000000 } - NumGlyphs = 0 OnClick = btnRandomPresetSaveClick ShowCaption = False ShowHint = True @@ -454,10 +449,10 @@ object frmMain: TfrmMain AnchorSideRight.Control = vdtRandom AnchorSideRight.Side = asrBottom Cursor = crArrow - Left = 188 + Left = 194 Height = 22 Hint = 'Удалить набор' - Top = 296 + Top = 294 Width = 22 Anchors = [akTop, akRight] Glyph.Data = { @@ -496,7 +491,6 @@ object frmMain: TfrmMain 0000C88B4DFFC88C4FFFC88C4FFFC88C4FFFC88C4FFFC88D4FFFC98C4FFFC78B 4FFFC5894BFFC4763BFF00000000000000000000000000000000 } - NumGlyphs = 0 OnClick = btnRandomPresetDeleteClick ShowCaption = False ShowHint = True @@ -513,9 +507,9 @@ object frmMain: TfrmMain AnchorSideBottom.Control = cbRandomPreset Cursor = 63 Left = 2 - Height = 272 + Height = 270 Top = 20 - Width = 208 + Width = 214 Anchors = [akTop, akLeft, akRight, akBottom] BorderSpacing.Left = 2 BorderSpacing.Top = 2 @@ -628,7 +622,7 @@ object frmMain: TfrmMain ScrollBarOptions.ScrollBars = ssVertical TabOrder = 0 TreeOptions.AutoOptions = [toAutoDropExpand, toAutoScroll, toAutoScrollOnExpand, toAutoTristateTracking, toAutoDeleteMovedNodes] - TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning] + TreeOptions.MiscOptions = [toFullRepaintOnResize, toInitOnSave, toToggleOnDblClick, toWheelPanning] TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowDropmark, toThemeAware, toUseBlendedImages, toStaticBackground] TreeOptions.SelectionOptions = [toFullRowSelect] OnClick = vdtRandomClick @@ -647,13 +641,13 @@ object frmMain: TfrmMain AnchorSideBottom.Side = asrBottom Cursor = crArrow Left = 2 - Height = 21 - Top = 296 - Width = 156 + Height = 25 + Top = 294 + Width = 162 Anchors = [akLeft, akRight, akBottom] BorderSpacing.Right = 4 BorderSpacing.Bottom = 4 - ItemHeight = 13 + ItemHeight = 0 OnChange = cbRandomPresetChange ParentBidiMode = False Sorted = True @@ -666,9 +660,9 @@ object frmMain: TfrmMain AnchorSideTop.Control = cbTerrain Cursor = crArrow Left = 4 - Height = 19 + Height = 24 Top = 18 - Width = 62 + Width = 76 BorderSpacing.Top = 16 Caption = 'Статика' OnChange = cbStaticsChange @@ -679,9 +673,9 @@ object frmMain: TfrmMain AnchorSideTop.Control = tsTiles Cursor = crArrow Left = 4 - Height = 19 + Height = 24 Top = 2 - Width = 59 + Width = 72 BorderSpacing.Left = 4 BorderSpacing.Top = 2 Caption = 'Рельеф' @@ -695,10 +689,10 @@ object frmMain: TfrmMain AnchorSideRight.Control = tsTiles AnchorSideRight.Side = asrBottom Cursor = crIBeam - Left = 79 - Height = 21 - Top = 14 - Width = 121 + Left = 92 + Height = 19 + Top = 13 + Width = 112 Anchors = [akTop, akLeft, akRight] BorderSpacing.Right = 16 OnEditingDone = edFilterEditingDone @@ -711,8 +705,8 @@ object frmMain: TfrmMain Cursor = crVSplit Left = 0 Height = 5 - Top = 289 - Width = 216 + Top = 287 + Width = 220 Align = alNone Anchors = [akLeft, akRight, akBottom] OnMoved = spGroupListMoved @@ -723,8 +717,8 @@ object frmMain: TfrmMain AnchorSideRight.Side = asrBottom AnchorSideBottom.Control = vdtTiles AnchorSideBottom.Side = asrBottom - Left = 97 - Height = 21 + Left = 101 + Height = 19 Hint = 'Append S or T to restrict the search to Statics or Terrain.' Top = 330 Width = 96 @@ -748,9 +742,9 @@ object frmMain: TfrmMain AnchorSideBottom.Control = spGroupList Cursor = crArrow Left = 0 - Height = 251 - Top = 38 - Width = 213 + Height = 244 + Top = 43 + Width = 217 Anchors = [akTop, akLeft, akRight, akBottom] BorderSpacing.Top = 1 BorderSpacing.Right = 3 @@ -777,7 +771,7 @@ object frmMain: TfrmMain SelectionCurveRadius = 8 TabOrder = 8 TextMargin = 0 - TreeOptions.MiscOptions = [toAcceptOLEDrop, toFullRepaintOnResize, toToggleOnDblClick, toWheelPanning] + TreeOptions.MiscOptions = [toFullRepaintOnResize, toToggleOnDblClick, toWheelPanning] TreeOptions.PaintOptions = [toHideFocusRect, toShowButtons, toShowRoot, toShowTreeLines] TreeOptions.SelectionOptions = [toFullRowSelect, toMultiSelect] TreeOptions.StringOptions = [] @@ -796,9 +790,8 @@ object frmMain: TfrmMain end object tsNavigation: TTabSheet Caption = 'Навигация' - ClientHeight = 634 - ClientWidth = 216 - OnContextPopup = tsNavigationContextPopup + ClientHeight = 632 + ClientWidth = 220 object gbGoTo: TGroupBox AnchorSideLeft.Control = tsNavigation AnchorSideTop.Control = btnDeleteLocation @@ -816,8 +809,8 @@ object frmMain: TfrmMain BidiMode = bdRightToLeft BorderSpacing.Bottom = 4 Caption = 'Быстрый переход' - ClientHeight = 34 - ClientWidth = 212 + ClientHeight = 38 + ClientWidth = 214 ParentBidiMode = False ParentColor = False TabOrder = 1 @@ -946,7 +939,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnAddLocationClick ShowCaption = False ShowHint = True @@ -1000,7 +992,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnDeleteLocationClick ShowCaption = False ShowHint = True @@ -1054,7 +1045,6 @@ object frmMain: TfrmMain FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFF FF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00FFFFFF00 } - NumGlyphs = 0 OnClick = btnClearLocationsClick ShowCaption = False ShowHint = True @@ -1239,6 +1229,7 @@ object frmMain: TfrmMain object tbSeparator1: TToolButton Cursor = crArrow Left = 24 + Height = 22 Top = 2 Width = 4 Style = tbsDivider @@ -1373,6 +1364,7 @@ object frmMain: TfrmMain object tbSeparator3: TToolButton Cursor = crArrow Left = 124 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator3' @@ -1391,6 +1383,7 @@ object frmMain: TfrmMain object tbSeparator4: TToolButton Cursor = crArrow Left = 583 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator4' @@ -1415,6 +1408,7 @@ object frmMain: TfrmMain object tbSeparator5: TToolButton Cursor = crArrow Left = 645 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator5' @@ -1472,6 +1466,7 @@ object frmMain: TfrmMain object tbSeparator2: TToolButton Cursor = crArrow Left = 293 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator2' @@ -1524,6 +1519,7 @@ object frmMain: TfrmMain object tbSeparator6: TToolButton Cursor = crArrow Left = 197 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator2' @@ -1533,6 +1529,7 @@ object frmMain: TfrmMain object tbSeparator7: TToolButton Cursor = crArrow Left = 51 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator2' @@ -1541,6 +1538,7 @@ object frmMain: TfrmMain object tbSeparator8: TToolButton Cursor = crArrow Left = 521 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator2' @@ -1549,6 +1547,7 @@ object frmMain: TfrmMain object tbSeparator9: TToolButton Cursor = crArrow Left = 343 + Height = 22 Top = 2 Width = 4 Caption = 'tbSeparator2' @@ -1564,7 +1563,7 @@ object frmMain: TfrmMain Cursor = crArrow Left = 224 Height = 20 - Top = 495 + Top = 494 Width = 758 Anchors = [akLeft, akRight, akBottom] BevelInner = bvRaised @@ -1577,7 +1576,7 @@ object frmMain: TfrmMain Left = 10 Height = 16 Top = 2 - Width = 95 + Width = 106 Align = alLeft BorderSpacing.Left = 8 Caption = 'Чат и Сообщения' @@ -1907,7 +1906,7 @@ object frmMain: TfrmMain AnchorSideBottom.Side = asrBottom Left = 224 Height = 140 - Top = 520 + Top = 519 Width = 758 Anchors = [akTop, akLeft, akRight, akBottom] BevelOuter = bvNone @@ -1918,7 +1917,7 @@ object frmMain: TfrmMain object vstChat: TVirtualStringTree Cursor = 63 Left = 0 - Height = 119 + Height = 121 Top = 0 Width = 758 Align = alClient @@ -1948,7 +1947,7 @@ object frmMain: TfrmMain item Position = 2 Text = 'Сообщение' - Width = 604 + Width = 606 end> Header.DefaultHeight = 17 Header.MainColumn = 2 @@ -1967,8 +1966,8 @@ object frmMain: TfrmMain object edChat: TEdit Cursor = crIBeam Left = 0 - Height = 21 - Top = 119 + Height = 19 + Top = 121 Width = 758 Align = alBottom Anchors = [akLeft, akRight] @@ -1982,7 +1981,7 @@ object frmMain: TfrmMain Cursor = crVSplit Left = 222 Height = 5 - Top = 515 + Top = 514 Width = 760 Align = alCustom Anchors = [akLeft, akRight, akBottom] @@ -2001,11 +2000,10 @@ object frmMain: TfrmMain AnchorSideRight.Side = asrBottom AnchorSideBottom.Control = pnlChatHeader Left = 224 - Height = 471 + Height = 470 Top = 24 Width = 758 Anchors = [akTop, akLeft, akRight, akBottom] - OnClick = oglGameWindowClick OnDblClick = oglGameWindowDblClick OnKeyDown = oglGameWindowKeyDown OnMouseDown = oglGameWindowMouseDown diff --git a/Client/UfrmMain.pas b/Client/UfrmMain.pas index 9f1a7de..aa89861 100644 --- a/Client/UfrmMain.pas +++ b/Client/UfrmMain.pas @@ -469,7 +469,6 @@ type procedure acUndoExecute(Sender: TObject); procedure acVirtualLayerExecute(Sender: TObject); procedure acWalkableExecute(Sender: TObject); - procedure acGridExecute(Sender: TObject); procedure ApplicationProperties1Idle(Sender: TObject; var Done: Boolean); procedure ApplicationProperties1ShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo); @@ -504,8 +503,6 @@ type procedure mnuAccountControlClick(Sender: TObject); procedure mnuAutoHideGroupListClick(Sender: TObject); procedure mnuAutoHideRandomListClick(Sender: TObject); - procedure mnuAutoShowFilterWindowClick(Sender: TObject); - procedure mnuCompactHueSettingsClick(Sender: TObject); procedure mnuDisconnectClick(Sender: TObject); procedure mnuDocsClick(Sender: TObject); procedure mnuEng2ComClick(Sender: TObject); @@ -528,7 +525,6 @@ type procedure mnuSetLanguageClick(Sender: TObject); procedure mnuShowAnimationsClick(Sender: TObject); procedure mnuShowBlocksClick(Sender: TObject); - procedure mnuShowBridgesClick(Sender: TObject); procedure mnuShowGridClick(Sender: TObject); procedure mnuShowLightSourceClick(Sender: TObject); procedure mnuShowNoDrawTilesClick(Sender: TObject); @@ -539,7 +535,6 @@ type procedure mnuWhiteBackgroundClick(Sender: TObject); procedure mnuWindowedModeClick(Sender: TObject); procedure mnuZoomClick(Sender: TObject); - procedure oglGameWindowClick(Sender: TObject); procedure oglGameWindowDblClick(Sender: TObject); procedure oglGameWindowKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); @@ -558,7 +553,6 @@ type procedure pbRadarMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer); procedure pbRadarPaint(Sender: TObject); - procedure pcLeftChange(Sender: TObject); procedure pcLeftResize(Sender: TObject); procedure pmGrabTileInfoPopup(Sender: TObject); procedure DropedownMenusClose(Sender: TObject); @@ -573,8 +567,6 @@ type procedure tmMovementTimer(Sender: TObject); procedure tmSelectNodeTimer(Sender: TObject); procedure tmSettingsCloseTimer(Sender: TObject); - procedure tsNavigationContextPopup(Sender: TObject; MousePos: TPoint; - var Handled: Boolean); procedure tvGroupFreeNode(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure tvGroupsChange(Sender: TBaseVirtualTree; Node: PVirtualNode); procedure tvGroupsDrawText(Sender: TBaseVirtualTree; TargetCanvas: TCanvas; @@ -1073,11 +1065,6 @@ begin RebuildScreenBuffer; end; -procedure TfrmMain.mnuShowBridgesClick(Sender: TObject); -begin - -end; - procedure TfrmMain.mnuShutdownClick(Sender: TObject); begin dmNetwork.Send(TQuitServerPacket.Create('')); @@ -1164,11 +1151,6 @@ begin RebuildScreenBuffer; end; -procedure TfrmMain.oglGameWindowClick(Sender: TObject); -begin - -end; - procedure TfrmMain.oglGameWindowDblClick(Sender: TObject); begin if (acSelect.Checked) and (CurrentTile <> nil) then @@ -1299,7 +1281,7 @@ var blockInfo: PBlockInfo; targetRect: TRect; offsetX, offsetY: Integer; - tile: TWorldItem; + item: TWorldItem; tileX, tileY, newX, newY: Word; targetBlocks: TBlockInfoList; //а в чем разница с targetTiles: TWorldItemList; ? targetTile: TWorldItem; @@ -1357,11 +1339,11 @@ begin Logger.Send([lcClient, lcDebug], 'Virtual tiles', FVirtualTiles.Count); for i := 0 to FVirtualTiles.Count - 1 do begin - tile := FVirtualTiles[i]; - if tile is TGhostTile then + item := FVirtualTiles[i]; + if item is TGhostTile then begin - dmNetwork.Send(TInsertStaticPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID, TGhostTile(tile).Hue)); - FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(tile))); + dmNetwork.Send(TInsertStaticPacket.Create(item.X, item.Y, item.Z, item.TileID, TGhostTile(item).Hue)); + FUndoList^.Add(TDeleteStaticPacket.Create(TGhostTile(item))); end; end; end else if (SelectedTile <> targetTile) or targetTile.CanBeEdited then @@ -1395,7 +1377,7 @@ begin end; end; - if acMove.Checked then //***** Move tile *****// + if acMove.Checked then //***** Move item *****// begin offsetX := frmMoveSettings.GetOffsetX; offsetY := frmMoveSettings.GetOffsetY; @@ -1423,81 +1405,81 @@ begin begin if frmMoveSettings.cbLand.Checked and (((offsetY > 0) or (offsetX > 0)) and not ((offsetY > 0) and (offsetX < 0))) then tileY := abs(i - targetBlocks.Count + 1) else tileY := i; - tile := targetBlocks.Items[tileY]^.Item; + item := targetBlocks.Items[tileY]^.Item; - if (frmMoveSettings.cbItem.Checked) and (tile is TStaticItem) then begin - newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1); - newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1); - FUndoList^.Add(TMoveStaticPacket.Create(newX, newY, tile.Z, tile.TileID, TStaticItem(tile).Hue, tile.X, tile.Y)); - dmNetwork.Send(TMoveStaticPacket.Create(TStaticItem(tile), newX, newY)); + if (frmMoveSettings.cbItem.Checked) and (item is TStaticItem) then begin + newX := EnsureRange(item.X + offsetX, 0, FLandscape.CellWidth - 1); + newY := EnsureRange(item.Y + offsetY, 0, FLandscape.CellHeight - 1); + FUndoList^.Add(TMoveStaticPacket.Create(newX, newY, item.Z, item.TileID, TStaticItem(item).Hue, item.X, item.Y)); + dmNetwork.Send(TMoveStaticPacket.Create(TStaticItem(item), newX, newY)); end; - if (frmMoveSettings.cbLand.Checked) and (tile is TMapCell) then begin - newX := EnsureRange(tile.X + offsetX, 0, FLandscape.CellWidth - 1); - newY := EnsureRange(tile.Y + offsetY, 0, FLandscape.CellHeight - 1); + if (frmMoveSettings.cbLand.Checked) and (item is TMapCell) then begin + newX := EnsureRange(item.X + offsetX, 0, FLandscape.CellWidth - 1); + newY := EnsureRange(item.Y + offsetY, 0, FLandscape.CellHeight - 1); map := FLandscape.MapCell[newX, newY]; // Это не очень хорошо, для оптимизации следует ввести специальный пакет TMoveMapPacket - FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z, tile.TileID)); + FUndoList^.Add(TDrawMapPacket.Create(item.X, item.Y, item.Z, item.TileID)); FUndoList^.Add(TDrawMapPacket.Create(newX, newY, map.RawZ, map.TileID)); - dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z, $0001)); - dmNetwork.Send(TDrawMapPacket.Create(newX, newY, tile.Z, tile.TileID)); + dmNetwork.Send(TDrawMapPacket.Create(item.X, item.Y, z, $0001)); + dmNetwork.Send(TDrawMapPacket.Create(newX, newY, item.Z, item.TileID)); end; end; - end else if acElevate.Checked then //***** Elevate tile *****// + end else if acElevate.Checked then //***** Elevate item *****// begin for i := 0 to targetBlocks.Count - 1 do begin - tile := targetBlocks.Items[i]^.Item; + item := targetBlocks.Items[i]^.Item; z := frmElevateSettings.seZ.Value; if frmElevateSettings.rbRaise.Checked then - z := EnsureRange(tile.Z + z, -128, 127) + z := EnsureRange(item.Z + z, -128, 127) else if frmElevateSettings.rbLower.Checked then - z := EnsureRange(tile.Z - z, -128, 127); + z := EnsureRange(item.Z - z, -128, 127); - if tile is TMapCell then + if item is TMapCell then begin if frmElevateSettings.cbRandomHeight.Checked then Inc(z, Random(frmElevateSettings.seRandomHeight.Value)); - FUndoList^.Add(TDrawMapPacket.Create(tile.X, tile.Y, tile.Z, - tile.TileID)); - dmNetwork.Send(TDrawMapPacket.Create(tile.X, tile.Y, z, - tile.TileID)); + FUndoList^.Add(TDrawMapPacket.Create(item.X, item.Y, item.Z, + item.TileID)); + dmNetwork.Send(TDrawMapPacket.Create(item.X, item.Y, z, + item.TileID)); end else begin - FUndoList^.Add(TElevateStaticPacket.Create(tile.X, tile.Y, - z, tile.TileID, TStaticItem(tile).Hue, tile.Z)); - dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(tile), z)); + FUndoList^.Add(TElevateStaticPacket.Create(item.X, item.Y, + z, item.TileID, TStaticItem(item).Hue, item.Z)); + dmNetwork.Send(TElevateStaticPacket.Create(TStaticItem(item), z)); end; end; - end else if acDelete.Checked then //***** Delete tile *****// + end else if acDelete.Checked then //***** Delete item *****// begin Logger.Send([lcClient, lcDebug], 'targetBlocks.Count', targetBlocks.Count); for i := 0 to targetBlocks.Count - 1 do begin - tile := targetBlocks.Items[i]^.Item; - if tile is TStaticItem then + item := targetBlocks.Items[i]^.Item; + if item is TStaticItem then begin - FUndoList^.Add(TInsertStaticPacket.Create(tile.X, tile.Y, - tile.Z, tile.TileID, TStaticItem(tile).Hue)); - dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(tile))); + FUndoList^.Add(TInsertStaticPacket.Create(item.X, item.Y, + item.Z, item.TileID, TStaticItem(item).Hue)); + dmNetwork.Send(TDeleteStaticPacket.Create(TStaticItem(item))); end; end; - end else if acHue.Checked then //***** Hue tile *****// + end else if acHue.Checked then //***** Hue item *****// begin for i := 0 to targetBlocks.Count - 1 do begin blockInfo := targetBlocks.Items[i]; - tile := blockInfo^.Item; + item := blockInfo^.Item; - if blockInfo^.HueOverride and (tile is TStaticItem) then + if blockInfo^.HueOverride and (item is TStaticItem) then begin - if TStaticItem(tile).Hue <> blockInfo^.Hue then + if TStaticItem(item).Hue <> blockInfo^.Hue then begin - FUndoList^.Add(THueStaticPacket.Create(tile.X, tile.Y, tile.Z, - tile.TileID, blockInfo^.Hue, TStaticItem(tile).Hue)); - dmNetwork.Send(THueStaticPacket.Create(TStaticItem(tile), + FUndoList^.Add(THueStaticPacket.Create(item.X, item.Y, item.Z, + item.TileID, blockInfo^.Hue, TStaticItem(item).Hue)); + dmNetwork.Send(THueStaticPacket.Create(TStaticItem(item), blockInfo^.Hue)); end; end; @@ -1823,7 +1805,7 @@ procedure TfrmMain.btnRandomPresetSaveClick(Sender: TObject); var presetName: string; i: Integer; - preset, tile: TDOMElement; + presetElement, tileElement: TDOMElement; children: TDOMNodeList; tileNode: PVirtualItem; tileInfo: PTileInfo; @@ -1831,31 +1813,31 @@ begin presetName := cbRandomPreset.Text; if InputQuery(lbDlgSaveRandPrsCaption, lbDlgSaveRandPrs, presetName) then begin - preset := FindRandomPreset(presetName); - if preset = nil then + presetElement := FindRandomPreset(presetName); + if presetElement = nil then begin - preset := FRandomPresetsDoc.CreateElement('Preset'); - preset.AttribStrings['Name'] := UTF8ToCP1251(presetName); - FRandomPresetsDoc.DocumentElement.AppendChild(preset); - cbRandomPreset.Items.AddObject(presetName, preset); + presetElement := FRandomPresetsDoc.CreateElement('PresetElement'); + presetElement.AttribStrings['Name'] := UTF8ToCP1251(presetName); + FRandomPresetsDoc.DocumentElement.AppendChild(presetElement); + cbRandomPreset.Items.AddObject(presetName, presetElement); end else begin - children := preset.ChildNodes; + children := presetElement.ChildNodes; for i := children.Count - 1 downto 0 do - preset.RemoveChild(children[i]); + presetElement.RemoveChild(children[i]); end; tileNode := vdlRandom.GetFirst; while tileNode <> nil do begin tileInfo := vdlRandom.GetNodeData(tileNode); - tile := FRandomPresetsDoc.CreateElement('Tile'); - tile.AttribStrings['ID'] := IntToStr(tileInfo^.ID); - preset.AppendChild(tile); + tileElement := FRandomPresetsDoc.CreateElement('TileElement'); + tileElement.AttribStrings['ID'] := IntToStr(tileInfo^.ID); + presetElement.AppendChild(tileElement); tileNode := vdlRandom.GetNext(tileNode); end; - cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(preset); + cbRandomPreset.ItemIndex := cbRandomPreset.Items.IndexOfObject(presetElement); SaveRandomPresets; end; @@ -1863,7 +1845,7 @@ end; procedure TfrmMain.cbRandomPresetChange(Sender: TObject); var - preset, tile: TDOMElement; + presetElement, tileElement: TDOMElement; tiles: TDOMNodeList; tileNode: PVirtualItem; tileInfo: PTileInfo; @@ -1872,13 +1854,13 @@ begin if cbRandomPreset.ItemIndex > -1 then begin vdlRandom.Clear; - preset := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]); - tiles := preset.ChildNodes; + presetElement := TDOMElement(cbRandomPreset.Items.Objects[cbRandomPreset.ItemIndex]); + tiles := presetElement.ChildNodes; for i := 0 to tiles.Count - 1 do begin - tile := TDOMElement(tiles[i]); - if (tile.NodeName = 'Tile') and - TryStrToInt(tile.AttribStrings['ID'], id) and + tileElement := TDOMElement(tiles[i]); + if (tileElement.NodeName = 'TileElement') and + TryStrToInt(tileElement.AttribStrings['ID'], id) and (id < FLandscape.MaxStaticID + $4000) then begin tileNode := vdlRandom.AddItem(nil); @@ -2054,11 +2036,6 @@ begin FRepaintNeeded := True; end; -procedure TfrmMain.acGridExecute(Sender: TObject); -begin - -end; - procedure TfrmMain.acDrawExecute(Sender: TObject); begin acDraw.Checked := True; @@ -2852,16 +2829,6 @@ begin spTileListMoved(Sender); end; -procedure TfrmMain.mnuAutoShowFilterWindowClick(Sender: TObject); -begin - -end; - -procedure TfrmMain.mnuCompactHueSettingsClick(Sender: TObject); -begin - -end; - procedure TfrmMain.spGroupListMoved(Sender: TObject); var anchor: integer; @@ -3032,11 +2999,6 @@ begin pbRadar.Canvas.Line(posX-scrW-1, posY+scrH+1, posX-scrW-1, posY-scrH-1); end; -procedure TfrmMain.pcLeftChange(Sender: TObject); -begin - -end; - procedure TfrmMain.pmGrabTileInfoPopup(Sender: TObject); var isStatic: Boolean; @@ -3085,12 +3047,6 @@ begin tbFlat.Down := acFlat.Checked; end; -procedure TfrmMain.tsNavigationContextPopup(Sender: TObject; MousePos: TPoint; - var Handled: Boolean); -begin - -end; - procedure TfrmMain.FormMouseMove(Sender: TObject; Shift: TShiftState; X,Y: Integer); begin if Sender is TWinControl then @@ -5613,7 +5569,7 @@ var z, b, t, a, e, value: Integer; uu, ur, ll, ul, dl, dr : Word; valueF : Single; - tile: TBrushTile; + brushTile: TBrushTile; // Создание миниатюр id : Integer; destColor, hue : Word; @@ -5681,7 +5637,7 @@ begin FBrushList.Brush[b]^.ECount := 0; while tNode <> nil do begin s := LowerCase(tNode.NodeName); - if (s = 'tile') or (s = 'land') then + if (s = 'brushTile') or (s = 'land') then inc(FBrushList.Brush[b]^.Count) else if (s = 'edge') then inc(FBrushList.Brush[b]^.ECount); @@ -5703,37 +5659,37 @@ begin while tNode <> nil do begin s := LowerCase(tNode.NodeName); - if (s = 'tile') or (s = 'land') then begin + if (s = 'brushTile') or (s = 'land') then begin //Logger.Send([lcInfo], 'Brush: %d - Land: %d / %d', [b+1, t+1, FBrushList.Brush[b]^.Count]); - tile.ID := $FFFF; - tile.Chance := 1.0; + brushTile.ID := $FFFF; + brushTile.Chance := 1.0; for a := tNode.Attributes.Length - 1 downto 0 do begin attribute := LowerCase(tNode.Attributes[a].NodeName); if attribute = 'id' then begin if TryStrToInt(tNode.Attributes[a].NodeValue, value) - then tile.ID := value; + then brushTile.ID := value; end else if attribute = 'chance' then begin if TryStrToFloat(tNode.Attributes[a].NodeValue, valueF) - then tile.Chance := valueF; + then brushTile.Chance := valueF; end; end; - tile.Mask := $0F; - tile.Brush1 := FBrushList.Brush[b]; - tile.Brush2 := FBrushList.Brush[b]; + brushTile.Mask := $0F; + brushTile.Brush1 := FBrushList.Brush[b]; + brushTile.Brush2 := FBrushList.Brush[b]; // Тестирование... - if LoadListError(tile.ID = $FFFF, + if LoadListError(brushTile.ID = $FFFF, fPath, Format(GetParseErText('blTagTileAttrID'), [FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - if LoadListError(tile.ID > $3FFF, - fPath, Format(GetParseErText('blTagTileAttrIDOutOfRange'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID])) + if LoadListError(brushTile.ID > $3FFF, + fPath, Format(GetParseErText('blTagTileAttrIDOutOfRange'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - if LoadListError(FBrushList.Tiles[tile.ID].ID = tile.ID, - fPath, Format(GetParseErText('blTagTileRedeclaration'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID])) + if LoadListError(FBrushList.Tiles[brushTile.ID].ID = brushTile.ID, + fPath, Format(GetParseErText('blTagTileRedeclaration'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - FBrushList.Tiles[tile.ID] := tile; - FBrushList.Brush[b]^.BTile[t] := @FBrushList.Tiles[tile.ID]; + FBrushList.Tiles[brushTile.ID] := brushTile; + FBrushList.Brush[b]^.BTile[t] := @FBrushList.Tiles[brushTile.ID]; inc(t); end else if (s = 'edge') then begin //Logger.Send([lcInfo], 'Brush: %d - Edge: %d / %d', [b+1, e+1, FBrushList.Brush[b]^.ECount]); @@ -5762,7 +5718,7 @@ begin FBrushList.Brush[b]^.BEdges[e]^.CountDR := 0; while eNode <> nil do begin s := LowerCase(eNode.NodeName); - if (s = 'tile') or (s = 'land') then begin + if (s = 'brushTile') or (s = 'land') then begin attribute := ''; for a := eNode.Attributes.Length - 1 downto 0 do begin attribute := LowerCase(eNode.Attributes[a].NodeName); @@ -5779,7 +5735,7 @@ begin end; if LoadListError((attribute<>'type') or ((s<>'uu')and(s<>'ur')and(s<>'ll')and(s<>'ul')and(s<>'dl')and(s<>'dr')), - fPath, Format(GetParseErText('blTagTile2AttrType'), [tile.ID, tile.ID, FBrushList.Brush[b]^.BEdges[e]^.ID, FBrushList.Brush[b]^.ID])) + fPath, Format(GetParseErText('blTagTile2AttrType'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.BEdges[e]^.ID, FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; end; eNode := eNode.NextSibling; @@ -5795,57 +5751,57 @@ begin eNode := tNode.FirstChild; while eNode <> nil do begin s := LowerCase(eNode.NodeName); - if (s = 'tile') or (s = 'land') then begin + if (s = 'brushTile') or (s = 'land') then begin //Logger.Send([lcInfo], 'Brush: %d - Edge: %d - Land: %d / %d', [b+1, e+1, uu+ur+ll+ul+dl+dr+1, FBrushList.Brush[b]^.BEdges[e]^.CountUU+FBrushList.Brush[b]^.BEdges[e]^.CountUR+FBrushList.Brush[b]^.BEdges[e]^.CountLL+FBrushList.Brush[b]^.BEdges[e]^.CountUL+FBrushList.Brush[b]^.BEdges[e]^.CountDL+FBrushList.Brush[b]^.BEdges[e]^.CountDR]); - tile.ID := $FFFF; - tile.Chance := 1.0; + brushTile.ID := $FFFF; + brushTile.Chance := 1.0; for a := eNode.Attributes.Length - 1 downto 0 do begin attribute := LowerCase(eNode.Attributes[a].NodeName); if attribute = 'type' then begin s := LowerCase(CP1251ToUTF8(eNode.Attributes[a].NodeValue)); - if s = 'uu' then tile.Mask := $03 - else if s = 'ur' then tile.Mask := $07 - else if s = 'll' then tile.Mask := $09 - else if s = 'ul' then tile.Mask := $0B - else if s = 'dl' then tile.Mask := $0D - else if s = 'dr' then tile.Mask := $0E; + if s = 'uu' then brushTile.Mask := $03 + else if s = 'ur' then brushTile.Mask := $07 + else if s = 'll' then brushTile.Mask := $09 + else if s = 'ul' then brushTile.Mask := $0B + else if s = 'dl' then brushTile.Mask := $0D + else if s = 'dr' then brushTile.Mask := $0E; end else if attribute = 'id' then begin if TryStrToInt(eNode.Attributes[a].NodeValue, value) - then tile.ID := value; + then brushTile.ID := value; end else if attribute = 'chance' then begin if TryStrToFloat(eNode.Attributes[a].NodeValue, valueF) - then tile.Chance := valueF; + then brushTile.Chance := valueF; end; end; // Тестирование... - if LoadListError(tile.ID = $FFFF, + if LoadListError(brushTile.ID = $FFFF, fPath, Format(GetParseErText('blTagTile2AttrID'), [FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - if LoadListError(tile.ID > $3FFF, - fPath, Format(GetParseErText('blTagTile2AttrIDOutOfRange'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID])) + if LoadListError(brushTile.ID > $3FFF, + fPath, Format(GetParseErText('blTagTile2AttrIDOutOfRange'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - if LoadListError(FBrushList.Tiles[tile.ID].ID = tile.ID, - fPath, Format(GetParseErText('blTagTile2Redeclaration'), [tile.ID, tile.ID, FBrushList.Brush[b]^.ID])) + if LoadListError(FBrushList.Tiles[brushTile.ID].ID = brushTile.ID, + fPath, Format(GetParseErText('blTagTile2Redeclaration'), [brushTile.ID, brushTile.ID, FBrushList.Brush[b]^.ID])) then begin LoadBrushTilesList; Exit; end; - tile.Brush1 := FBrushList.Brush[b]; - tile.Brush2 := nil; - FBrushList.Tiles[tile.ID] := tile; - if tile.Mask = $03 then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileUU[uu] := @FBrushList.Tiles[tile.ID]; inc(uu); - end else if tile.Mask = $07 then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileUR[ur] := @FBrushList.Tiles[tile.ID]; inc(ur); - end else if tile.Mask = $09 then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileLL[ll] := @FBrushList.Tiles[tile.ID]; inc(ll); - end else if tile.Mask = $0B then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileUL[ul] := @FBrushList.Tiles[tile.ID]; inc(ul); - end else if tile.Mask = $0D then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileDL[dl] := @FBrushList.Tiles[tile.ID]; inc(dl); - end else if tile.Mask = $0E then begin - FBrushList.Brush[b]^.BEdges[e]^.BTileDR[dr] := @FBrushList.Tiles[tile.ID]; inc(dr); + brushTile.Brush1 := FBrushList.Brush[b]; + brushTile.Brush2 := nil; + FBrushList.Tiles[brushTile.ID] := brushTile; + if brushTile.Mask = $03 then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileUU[uu] := @FBrushList.Tiles[brushTile.ID]; inc(uu); + end else if brushTile.Mask = $07 then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileUR[ur] := @FBrushList.Tiles[brushTile.ID]; inc(ur); + end else if brushTile.Mask = $09 then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileLL[ll] := @FBrushList.Tiles[brushTile.ID]; inc(ll); + end else if brushTile.Mask = $0B then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileUL[ul] := @FBrushList.Tiles[brushTile.ID]; inc(ul); + end else if brushTile.Mask = $0D then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileDL[dl] := @FBrushList.Tiles[brushTile.ID]; inc(dl); + end else if brushTile.Mask = $0E then begin + FBrushList.Brush[b]^.BEdges[e]^.BTileDR[dr] := @FBrushList.Tiles[brushTile.ID]; inc(dr); end; - FBrushList.Tiles[tile.ID].ID := FBrushList.Brush[b]^.BEdges[e]^.ID; // Временно запоминаем ID перехода (позже востанавливаем ID тайла) + FBrushList.Tiles[brushTile.ID].ID := FBrushList.Brush[b]^.BEdges[e]^.ID; // Временно запоминаем ID перехода (позже востанавливаем ID тайла) end; eNode := eNode.NextSibling; end; diff --git a/UCacheManager.pas b/UCacheManager.pas index 54bfd15..3a619f3 100644 --- a/UCacheManager.pas +++ b/UCacheManager.pas @@ -43,7 +43,7 @@ type { TCacheManager } generic TCacheManager = class - type public + public type { Types } TRemoveObjectEvent = procedure(AObject: T) of object; @@ -53,7 +53,7 @@ type Obj: T; Next: PCacheEntry; end; - var protected + protected { Members } FSize: Integer; FFirst: PCacheEntry;