paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-08-20 11:39:23 +02:00
Code Issues Packages Projects Releases Wiki Activity

Make CreatePixmapIndirect work for Win32. Work done by Markus Luedin.

Browse Source 
git-svn-id: trunk@3262 -
This commit is contained in:
lazarus 2002-08-29 16:22:02 +00:00
parent 2c26b55194
commit ebf7b9a916
1 changed files with 115 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

193
lcl/interfaces/win32/win32winapi.inc
View File

@ -425,26 +425,24 @@ End;
------------------------------------------------------------------------------} ------------------------------------------------------------------------------}
Function TWin32Object.CreatePixmapIndirect(Const Data: Pointer; Const TransColor: LongInt): HBITMAP; Function TWin32Object.CreatePixmapIndirect(Const Data: Pointer; Const TransColor: LongInt): HBITMAP;
Type Type
PBitData = ^TBitData; PColorMap = ^TColorMap;
TBitData = Array[0..1] Of Byte;
TColorMap = Record TColorMap = Record
Alias: String; Alias: String;
Color: Integer; Color: DWORD;
End; End;
PColorArray = ^TColorArray;
TColorArray = Array[0..1] Of TColorMap;
PPixmapArray = ^TPixmapArray; PPixmapArray = ^TPixmapArray;
TPixmapArray = Array[0..1000] Of PChar; TPixmapArray = Array[0..1000] Of PChar;
Var Var
AliasLen: Cardinal; AliasLen : Cardinal;
AList: TList; AList : TList;
ColorArray: PColorArray; ColorCount : Integer;
ColorCount: Integer; hdcBitmap : HDC;
DC: HDC; hbmBitmap : HBITMAP ;
Height, Width: Integer; Height, Width : Integer;
OldObject: HGDIOBJ; OldObject : HGDIOBJ;
PixmapArray: PPixmapArray; PixmapArray : PPixmapArray;
PixmapInfo: TStringList; Info : String;
PixmapInfo : TStringList;
Const Const
DC_SCREEN = 0; DC_SCREEN = 0;
@ -457,18 +455,15 @@ Const
Assert(False, 'Trace:NormalizeString - Start'); Assert(False, 'Trace:NormalizeString - Start');
Str := Replace(Str, keyTab, ' ', True); Str := Replace(Str, keyTab, ' ', True);
S := ''; S := '';
While True Do Begin
While True Do
Begin
Str := Replace(Str, ' ', ' ', True); Str := Replace(Str, ' ', ' ', True);
If Str = S Then If Str = S Then Break;
Break;
S := Str; S := Str;
End; End;
Assert(False, 'Trace:NormalizeString - Exit'); Assert(False, 'Trace:NormalizeString - Exit');
End; End;
Function StrToInt(Const Str: String): Integer; Function StrToInt(Const Str: String): DWORD;
Var Var
S: String; S: String;
Begin Begin
@ -478,66 +473,83 @@ Const
Assert(False, 'Trace:StrToInt - Exit'); Assert(False, 'Trace:StrToInt - Exit');
End; End;
Function CreateColorMap: PColorArray; procedure CreateColorMap;
Var Var
Elem: String; Elem: String;
I: Integer; I: Integer;
Idx: Cardinal; Idx: Cardinal;
ColorMap: TColorMap; ColorMap: PColorMap;
Begin Begin
Assert(False, 'Trace:CreateColorMap - Start'); Assert(False, 'Trace:CreateColorMap - Start');
If ColorCount = 0 Then If ColorCount = 0 Then Begin
Begin
Assert(False, 'Trace:CreateColorMap - Color count was not retrieved; can''t create color map'); Assert(False, 'Trace:CreateColorMap - Color count was not retrieved; can''t create color map');
AList := Nil; AList := Nil;
Result := Nil;
Exit; Exit;
End; End;
AList := TList.Create; AList := TList.Create;
For I := 1 To ColorCount Do For I := 1 To ColorCount Do Begin
Begin
Try Try
Elem := String(PixmapArray^[I]); Elem := String(PixmapArray^[I]);
Idx := Length(Elem) - 7;
With ColorMap Do
Begin
Alias := Copy(Elem, 1, AliasLen);
If Copy(Elem, Length(Elem) - 5, 4) <> 'None' Then
Color := StrToInt('$' + Copy(Elem, Idx, Length(Elem) - Idx - 1))
Else
Color := TransColor;
Assert(False, Format('Trace:CreateColorMap - color-map entry info --> item: %D, data: %S, alias: %S, color:0x%X', [I, String(PixmapArray^[I]), Alias, Color]));
End;
AList.Add(@ColorMap);
Except
On E: Exception Do
Assert(False, Format('Trace:CreateColorMap - Could not create color-map entry --> %S', [E.Message]));
End;
End;
TList(Result) := AList; While Pos(Elem[Length(Elem)],'",')>0 do Elem:=Copy(Elem,1,Length(Elem)-1);
Idx := Length(Elem)-5;
New(ColorMap);
ColorMap^.Alias := Copy(Elem, 1, AliasLen);
If Copy(Elem, Length(Elem)-3, 4) <> 'None' Then begin
ColorMap^.Color :=StrToInt('$'+Copy(Elem,Idx,6));
ColorMap^.Color :=RGB(StrToInt('$'+Copy(Elem,Idx,2)),StrToInt('$'+Copy(Elem,Idx+2,2)),StrToInt('$'+Copy(Elem,Idx+4,2)));
end
Else
ColorMap^.Color := TransColor;
Assert(False, Format('Trace:CreateColorMap - color-map entry info --> item: %D, data: %S, alias: %S, color:0x%X', [I, String(PixmapArray^[I]), ColorMap^.Alias, ColorMap^.Color]));
AList.Add(ColorMap);
Except
On E: Exception Do Assert(False, Format('Trace:CreateColorMap - Could not create color-map entry --> %S', [E.Message]));
End;
End;
Assert(False, 'Trace:CreateColorMap - Exit'); Assert(False, 'Trace:CreateColorMap - Exit');
End; End;
Procedure DestroyColorMap(ColorMap: PColorArray); Procedure DestroyColorMap;
var
ColorMap : PColorMap;
Begin Begin
Assert(False, 'Trace:DestroyColorMap - Start'); Assert(False, 'Trace:DestroyColorMap - Start');
If ColorMap <> Nil Then While AList.Count>0 do begin
ColorMap := Nil; ColorMap:=PColorMap(AList.Items[0]);
Dispose(ColorMap);
If AList <> Nil Then AList.Delete(0);
Begin end;
If AList <> Nil Then Begin
AList.Free; AList.Free;
AList := Nil; AList := Nil;
End; End;
Assert(False, 'Trace:DestroyColorMap - Exit'); Assert(False, 'Trace:DestroyColorMap - Exit');
End; End;
function GetColorFromAlias(Alias:String):DWORD;
var
i : Integer;
begin
result:=0;
i :=0;
if AList.Count>0 then begin
repeat
if (TColorMap(AList.Items[i]^).Alias=Alias) then begin
result:=TColorMap(AList.Items[i]^).Color;
break;
end;
Inc(i);
until (i>=ColorCount);
end;
end;
Procedure DoDrawBitmap; Procedure DoDrawBitmap;
Var Var
CX, CY: Cardinal; CX,CY : Cardinal;
Line,Alias : String;
Begin Begin
Assert(False, 'Trace:DoDrawBitmap - Start'); Assert(False, 'Trace:DoDrawBitmap - Start');
@ -547,34 +559,51 @@ Const
Exit; Exit;
End; End;
Assert(False, 'Trace:DoDrawBitmap - TODO: Draw the bitmap'); for CY:=0 to Height-1 do begin
Line:=String(PixmapArray^[1+ColorCount+CY]);
While Pos(Line[Length(Line)],'",')>0 do Line:=Copy(Line,1,Length(Line)-1);
for CX:=0 to Width-1 do begin
Alias:=Copy(Line,1+CX*AliasLen,AliasLen);
Windows.SetPixel(hdcBitmap,CX,CY,GetColorFromAlias(Alias));
end;
end;
Assert(False, 'Trace:DoDrawBitmap - Exit'); Assert(False, 'Trace:DoDrawBitmap - Exit');
End; End;
Begin
Assert(False, 'Trace:TWin32Object.CreatePixmapIndirect - Start');
{Height := 0; Begin
Assert(False, 'Trace:TWin32Object. - Start');
Height := 0;
Width := 0; Width := 0;
ColorCount := 0; ColorCount := 0;
AliasLen := 0; AliasLen := 0;
Result := HBITMAP(Nil); Result := HBITMAP(Nil);
PixmapArray := PPixmapArray(Data); PixmapArray := PPixmapArray(Data);
NormalizeString(String(PixmapArray^[0])); Info := String(PixmapArray^[0]);
PixmapInfo := Split(String(PixmapArray^[0]), ' ', 3, False); PixmapInfo := TStringList.Create;;
If PixmapInfo.Count = 6 Then
Assert(False, 'Trace:TODO: TWin32Object.CreatePixmapIndirect - Get Pixmaps with six sections working'); NormalizeString(Info);
//My own Split:
while Pos(' ',Info)>0 do begin
PixmapInfo.Add(Copy(Info,1,Pos(' ',Info)-1)); //Add first String to list
Delete(Info,1,Pos(' ',Info)); //Delete String + Space
end;
if Length(Info)>0 then PixmapInfo.Add(Info); //Add last String;
// I don't know where this Split is defines, but it does something weired
// PixmapInfo := Split(String(PixmapArray^[0]), ' ', 3, False);
If PixmapInfo.Count = 6 Then Assert(False, 'Trace:TODO: TWin32Object.CreatePixmapIndirect - Get Pixmaps with six sections working');
Try Try
Width := StrToInt(PixmapInfo[0]); Width := StrToInt(PixmapInfo[0]); Assert(False, Format('Trace: Pixmap width --> %D', [Width]));
Assert(False, Format('Trace: Pixmap width --> %D', [Width])); Height := StrToInt(PixmapInfo[1]); Assert(False, Format('Trace: Pixmap height --> %D', [Height]));
Height := StrToInt(PixmapInfo[1]); ColorCount := StrToInt(PixmapInfo[2]); Assert(False, Format('Trace: number of colors --> %D', [ColorCount]));
Assert(False, Format('Trace: Pixmap height --> %D', [Height]));
ColorCount := StrToInt(PixmapInfo[2]); While Pos(PixmapInfo[3][Length(PixmapInfo[3])],'",')>0 do
Assert(False, Format('Trace: number of colors --> %D', [ColorCount])); PixmapInfo[3]:=Copy(PixmapInfo[3],1,Length(PixMapInfo[3])-1);
If PixmapInfo[3][Length(PixmapInfo[3])] = '"' Then
PixmapInfo[3] := Copy(PixmapInfo[3], 1, Length(PixMapInfo[3]) - 1);
AliasLen := StrToInt(PixmapInfo[3]); AliasLen := StrToInt(PixmapInfo[3]);
Assert(False, Format('Trace: characters per pixel --> %D', [AliasLen])); Assert(False, Format('Trace: characters per pixel --> %D', [AliasLen]));
Assert(False, Format('Trace:TWin32Object.CreatePixmapIndirect - Pixmap info: Width - %D; Height - %D; Number of Colors - %D; Characters per pixel - %D; Transparent color - 0x%X', [Width, Height, ColorCount, AliasLen, TransColor])); Assert(False, Format('Trace:TWin32Object.CreatePixmapIndirect - Pixmap info: Width - %D; Height - %D; Number of Colors - %D; Characters per pixel - %D; Transparent color - 0x%X', [Width, Height, ColorCount, AliasLen, TransColor]));
Except Except
@ -584,23 +613,20 @@ Begin
End; End;
End; End;
// Temp values If (Width <> 0) And (Height <> 0) Then Begin
//Width := 100; hdcBitmap := CreateCompatibleDC(DC_SCREEN);
//Height := 100; hbmBitmap := CreateBitmap(Width,Height,1,24,nil);
DC := CreateCompatibleDC(DC_SCREEN); OldObject := SelectObject(hdcBitmap, hbmBitmap);
If (Width <> 0) And (Height <> 0) Then CreateColorMap;
Result := CreateCompatibleBitmap(DC, Width, Height);
OldObject := SelectObject(DC, Result);
//GetMem(PixmapArray, (Width + ColorCount) * SizeOf(PChar));
ColorArray := CreateColorMap;
DoDrawBitmap; DoDrawBitmap;
DestroyColorMap(ColorArray); DestroyColorMap;
//FreeMem(PixmapArray); end;
PixmapInfo.Free; PixmapInfo.Free;
PixmapInfo := Nil; PixmapInfo := Nil;
PixmapArray := Nil; PixmapArray := Nil;
SelectObject(DC, OldObject); DeleteDC(hdcBitmap);
DeleteDC(DC);} result:=hbmBitmap;
Assert(False, 'Trace:TWin32Object.CreatePixmapIndirect - Exit'); Assert(False, 'Trace:TWin32Object.CreatePixmapIndirect - Exit');
End; End;
@ -2263,6 +2289,9 @@ end;
{ ============================================================================= { =============================================================================
$Log$ $Log$
Revision 1.16 2002/08/29 16:22:02 lazarus
Make CreatePixmapIndirect work for Win32. Work done by Markus Luedin.
Revision 1.15 2002/08/28 09:40:52 lazarus Revision 1.15 2002/08/28 09:40:52 lazarus
MG: reduced paint messages and DC getting/releasing MG: reduced paint messages and DC getting/releasing