LZScene

1
//
2
// This unit is part of the GLScene Engine https://github.com/glscene
3
//
4
{
5
   Material Preview frame.
6
}
7
// There was problems with GLSceneViewer and TFrame (ïðè ïåðåäà÷å handle to buffer),
8
// so now is using MemoryViewer
9

10
unit FRMaterialPreview;
11

12
interface
13

14
{$I GLScene.inc}
15

16
uses 
17
  lresources,
18
  Classes, 
19
  Forms, 
20
  StdCtrls, 
21
  Controls, 
22
  ExtCtrls,
23
  Graphics,
24
  GLScene, 
25
  GLObjects, 
26
  GLTexture, 
27
  GLHUDObjects, 
28
  GLTeapot,
29
  GLGeomObjects, 
30
  GLColor, 
31
  GLCoordinates,
32
  GLCrossPlatform, 
33
  GLMaterial,
34
  GLgraphics, 
35
  LCLIntf;
36

37

38
type
39

40
  TRMaterialPreview = class(TFrame)
41
    GLMemoryViewer1: TGLMemoryViewer;
42
    GLScene1: TGLScene;
43
    CBObject: TComboBox;
44
    Camera: TGLCamera;
45
    Cube: TGLCube;
46
    imgFull: TImage;
47
    Sphere: TGLSphere;
48
    LightSource: TGLLightSource;
49
    CBBackground: TComboBox;
50
    BackGroundSprite: TGLHUDSprite;
51
    Cone: TGLCone;
52
    Teapot: TGLTeapot;
53
    Timer1: TTimer;
54
    World: TGLDummyCube;
55
    Light: TGLDummyCube;
56
    FireSphere: TGLSphere;
57
    GLMaterialLibrary: TGLMaterialLibrary;
58
    procedure CBObjectChange(Sender: TObject);
59
    procedure CBBackgroundChange(Sender: TObject);
60
    procedure imgFullMouseDown(Sender: TObject; Button: TMouseButton;
61
      Shift: TShiftState; X, Y: Integer);
62
    procedure imgFullMouseMove(Sender: TObject; Shift: TShiftState; X,
63
      Y: Integer);
64
    procedure imgFullMouseWheel(Sender: TObject; Shift: TShiftState;
65
      WheelDelta: Integer; MousePos: TPoint; var Handled: Boolean);
66
    procedure imgFullResize(Sender: TObject);
67
    procedure Timer1Timer(Sender: TObject);
68

69
  private
70
    function GetMaterial: TGLMaterial;
71
    procedure SetMaterial(const Value: TGLMaterial);
72
     
73
  public
74
    Procedure Render;
75
     
76
    constructor Create(AOwner : TComponent); override;
77
    destructor Destroy; override;
78
    property Material : TGLMaterial read GetMaterial write SetMaterial;
79

80
  end;
81

82
// ------------------------------------------------------------------
83
// ------------------------------------------------------------------
84
// ------------------------------------------------------------------
85
implementation
86
// ------------------------------------------------------------------
87
// ------------------------------------------------------------------
88
// ------------------------------------------------------------------
89

90
var
91
  MX, MY: Integer;
92

93
constructor TRMaterialPreview.Create(AOwner : TComponent);
94
begin
95
   inherited;
96
   BackGroundSprite.Position.X := imgFull.Width div 2;
97
   BackGroundSprite.Position.Y := imgFull.Height div 2;
98
   BackGroundSprite.Width := imgFull.Width;
99
   BackGroundSprite.Height := imgFull.Height;
100

101
   CBObject.ItemIndex:=0;     CBObjectChange(Self);
102
   CBBackground.ItemIndex:=0; CBBackgroundChange(Self);
103
end;
104

105
destructor TRMaterialPreview.Destroy;
106
begin
107
  inherited;
108
end;
109

110
procedure TRMaterialPreview.CBObjectChange(Sender: TObject);
111
var
112
   i : Integer;
113
begin
114
   i:=CBObject.ItemIndex;
115
   Cube.Visible   := I = 0;
116
   Sphere.Visible := I = 1;
117
   Cone.Visible   := I = 2;
118
   Teapot.Visible := I = 3;
119
end;
120

121
procedure TRMaterialPreview.CBBackgroundChange(Sender: TObject);
122
var
123
   bgColor : TColor;
124
begin
125
   case CBBackground.ItemIndex of
126
      1 : bgColor:=clWhite;
127
      2 : bgColor:=clBlack;
128
      3 : bgColor:=clBlue;
129
      4 : bgColor:=clRed;
130
      5 : bgColor:=clGreen;
131
   else
132
      bgColor:=clNone;
133
   end;
134
   with BackGroundSprite.Material do begin
135
      Texture.Disabled:=(bgColor<>clNone);
136
      FrontProperties.Diffuse.Color:=ConvertWinColor(bgColor);
137
   end;
138
end;
139

140
procedure TRMaterialPreview.imgFullMouseDown(Sender: TObject;
141
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
142
begin
143
  MX := X;
144
  MY := Y;
145
end;
146

147
procedure TRMaterialPreview.imgFullMouseMove(Sender: TObject;
148
  Shift: TShiftState; X, Y: Integer);
149
begin
150
  if (ssRight in Shift) and (ssLeft in Shift) then
151
    Camera.AdjustDistanceToTarget(1 - 0.01 * (MY - Y))
152
  else
153
  if (ssRight in Shift) or (ssLeft in Shift) then
154
    Camera.MoveAroundTarget(Y - MY, X - MX);
155

156
  MX := X;
157
  MY := Y;
158
end;
159

160
procedure TRMaterialPreview.imgFullMouseWheel(Sender: TObject;
161
  Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint;
162
  var Handled: Boolean);
163
begin
164
    Camera.AdjustDistanceToTarget(1 - 0.1 * (Abs(WheelDelta) / WheelDelta));
165
end;
166

167
procedure TRMaterialPreview.imgFullResize(Sender: TObject);
168
begin
169
  GLMemoryViewer1.Height:= imgFull.Height;
170
  GLMemoryViewer1.Width:= imgFull.Width;
171
end;
172

173
procedure TRMaterialPreview.Timer1Timer(Sender: TObject);
174
Var
175
  BitMap : TBitmap;
176
  Image  : TGLBitmap32;
177
  fWidth, fHeight:Integer;
178

179
begin
180
  GLMemoryViewer1.Render;
181
  Image := GLMemoryViewer1.Buffer.CreateSnapShot;
182
  Bitmap := Image.Create32BitsBitmap;
183
  try
184
    imgFull.Canvas.Brush.Color := clBlack;
185
    imgFull.Canvas.FillRect(imgFull.Canvas.ClipRect);
186
    fWidth :=imgFull.Width;
187
    fHeight:= imgFull.Height;
188
    imgFull.Canvas.StretchDraw(Rect(0, 0, fWidth, fHeight), Bitmap);{}
189
  finally
190
    Bitmap.Free;
191
    Image.Free;
192
  end;
193
end;
194

195
function TRMaterialPreview.GetMaterial: TGLMaterial;
196
begin
197
  Result := GLMaterialLibrary.Materials[0].Material;
198
end;
199

200
procedure TRMaterialPreview.SetMaterial(const Value: TGLMaterial);
201
begin
202
  GLMaterialLibrary.Materials[0].Material.Assign(Value);
203
end;
204

205
Procedure TRMaterialPreview.Render;
206
begin
207
  Timer1.OnTimer(self);
208
end;
209

210
// ------------------------------------------------------------------
211
// ------------------------------------------------------------------
212
// ------------------------------------------------------------------
213
initialization
214
// ------------------------------------------------------------------
215
// ------------------------------------------------------------------
216
// ------------------------------------------------------------------
217

218
  {$i FRMaterialPreview.lrs}
219

220
end.
221

222

223

224