Change the color of a disabled TEdit

Problem/Question/Abstract:

How can I change the color of a disabled (Edit1.Enabled := false;) control? I do not want the normal grey color.

Answer:

Two options: Place the control on a panel and disable the panel instead of the control. This way the color stays to whatever you set it. Or make a descendent and take over the painting when it is disabled. Here is an example:

unit PBExEdit;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls;

type
TPBExEdit = class(Tedit)
private
{ Private declarations }
FDisabledColor: TColor;
FDisabledTextColor: TColor;
procedure WMPaint(var msg: TWMPaint); message WM_PAINT;
procedure WMEraseBkGnd(var msg: TWMEraseBkGnd); message WM_ERASEBKGND;
procedure SetDisabledColor(const Value: TColor); virtual;
procedure SetDisabledTextColor(const Value: TColor); virtual;
protected
{ Protected declarations }
public
{ Public declarations }
constructor Create(aOwner: TComponent); override;
published
{ Published declarations }
property DisabledTextColor: TColor read FDisabledTextColor write
SetDisabledTextColor
default clGrayText;
property DisabledColor: TColor read FDisabledColor write SetDisabledColor default
clWindow;
end;

procedure Register;

implementation

procedure Register;
begin
RegisterComponents('PBGoodies', [TPBExEdit]);
end;

constructor TPBExEdit.Create(aOwner: TComponent);
begin
inherited;
FDisabledColor := clWindow;
FDisabledTextColor := clGrayText;
end;

procedure TPBExEdit.SetDisabledColor(const Value: TColor);
begin
if FDisabledColor <> Value then
begin
FDisabledColor := Value;
if not Enabled then
Invalidate;
end;
end;

procedure TPBExEdit.SetDisabledTextColor(const Value: TColor);
begin
if FDisabledTextColor <> Value then
begin
FDisabledTextColor := Value;
if not Enabled then
Invalidate;
end;
end;

procedure TPBExEdit.WMEraseBkGnd(var msg: TWMEraseBkGnd);
var
canvas: TCanvas;
begin
if Enabled then
inherited
else
begin
canvas := TCanvas.Create;
try
canvas.Handle := msg.DC;
SaveDC(msg.DC);
try
canvas.Brush.Color := FDisabledColor;
canvas.Brush.Style := bsSolid;
canvas.Fillrect(clientrect);
msg.result := 1;
finally
RestoreDC(msg.DC, -1);
end;
finally
canvas.free
end;
end;
end;

procedure TPBExEdit.WMPaint(var msg: TWMPaint);
var
canvas: TCanvas;
ps: TPaintStruct;
callEndPaint: Boolean;
begin
if Enabled then
inherited
else
begin
callEndPaint := False;
canvas := TCanvas.Create;
try
if msg.DC <> 0 then
begin
canvas.Handle := msg.DC;
ps.fErase := true;
end
else
begin
BeginPaint(handle, ps);
callEndPaint := true;
canvas.handle := ps.hdc;
end;
if ps.fErase then
Perform(WM_ERASEBKGND, canvas.handle, 0);
SaveDC(canvas.handle);
try
canvas.Brush.Style := bsClear;
canvas.Font := Font;
canvas.Font.Color := FDisabledTextColor;
canvas.TextOut(1, 1, Text);
finally
RestoreDC(canvas.handle, -1);
end;
finally
if callEndPaint then
EndPaint(handle, ps);
canvas.free
end;
end;
end;

end.

Calling a C++ DLL which exports a class

Problem/Question/Abstract:

As I stated in an earlier article, it's possible to get an object-reference out from a DLL. This technique is known under the name DLL+. But how about the DLL is written in c++?

Answer:

First of all, you have to translate the header-file (should be delivered with the DLL), which is like an interface-section in ObjectPascal. Headers in c usually contain all sorts of definitions which are relevant outside the
module. In our c++ example it looks like:

/*FILE: income.h */
class CIncome
{
public:
virtual double __stdcall GetIncome( double aNetto ) = 0 ;
virtual void   __stdcall SetRate( int aPercent, int  aYear ) = 0 ;
virtual void   __stdcall FreeObject() = 0 ;
} ;

Then you translate it to an Abstract Class in a unit of her own:

//FILE: income.pas
interface
type
IIncome = class
public
function GetIncome(const aNetto: double): double;
virtual; stdcall; abstract;
procedure SetRate(const aPercent: Integer; aYear: integer);
virtual; stdcall; abstract;
procedure FreeObject; virtual; stdcall; abstract;
end;

In the c++ dll, there is a procedure FreeObject this is necessary because of differences in memory management between C++ and ObjectPascal:

void __stdcall FreeObject()
{
delete this ;
}

When you call the DLL written in C or C++, you have to use the stdcall or cdecl convention. Otherwise, you
will end up in violation troubles and from time to time the application may crash. By the way the DLL, you are calling, should be on the search path;).

So these conventions pass parameters from right to left. With this convention, the caller (that's Delphi)has to remove the parameters from the stack when the call returns.

At least the DLL-call is simple:

incomeRef: IIncome; //member of the reference

function CreateIncome: IIncome;
stdcall; external('income_c.dll');

procedure TfrmIncome.FormCreate(Sender: TObject);
begin
incomeRef := createIncome;
end;

procedure TfrmIncome.btncplusClick(Sender: TObject);
var
cIncome: Double;
begin
// this is the c++ dll+ call ;)
incomeRef.SetRate(strToInt(edtZins.text),
strToInt(edtJahre.text));
cIncome := incomeRef.GetIncome(StrToFloat(edtBetrag.Text));
edtBetrag.text := Format('%f', [cIncome]);
end;


Component Download: http://max.kleiner.com/download/cpluscall.ziphttp://max.kleiner.com/download/cpluscall.zip

Wait until a TForm is actually painted on screen

Problem/Question/Abstract:

How can I wait until the form is actually painted on screen, before starting the processing so that I can be sure that any exceptions are displayed after the form is painted. I've considered a short timer in the OnCreate. Is there a better way (i.e. catching a Windows message)?

Answer:

Use an custom message:

const
  UM_AFTERSHOW = WM_USER + 1001;

type
  TMyForm = class(TForm)
    procedure FormShow(Sender: TObject);
  private
    procedure UMAfterShow(var Msg: TMessage); message UM_AFTERSHOW;
  end;

implementation

procedure TMyForm.FormShow(Sender: TObject);
begin
  PostMessage(Self.Handle, UM_AFTERSHOW, 0, 0);
end;

procedure TMyForm.UMAfterShow(var Msg: TMessage);
begin
  {your code here}
end;

How to write a custom TAction to control the visibility of a TStatusBar

Problem/Question/Abstract:

I am trying to write a custom action that will set the visible property of a TStatusBar on and off. I assigned this action to a menu item and when I select this menu item at runtime the status bar is hidden. The problem is that the menu item (connected to the action) is disabled, so I can't view the statusbar again. I think that it's a matter of how the TMenuActionLink behaves (the action controls the enabled property of the menu ). I tried to set the enabled property in the action to true , but no avail. The menu is still disabled. Is there any way to do this?

Answer:

I think that the best solution would be to write an action, which will have a StatusBar property and, in case this property was assigned, set the statusbar's visibility in the overridden Execute method. Here's an example:

{ ... }
TMyAction = class(TAction)
protected
  FStatusBar: TStatusBar;
  procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  procedure SetStatusBar(AValue: TStatusBar);
public
  constructor Create(AOwner: TComponent); override;
  function Execute: Boolean; override;
published
  property StatusBar: TStatusBar read FStatusBar write SetStatusBar;
end;

{ ... }

constructor TMyAction.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  DisableIfNoHandler := false;
  FStatusBar := nil;
  Caption := 'Turn On/ Off Status Bar';
end;

function TMyAction.Execute: Boolean;
begin
  Result := inherited Execute;
  if Assigned(FStatusBar) then
  begin
    FStatusBar.Visible := not FStatusBar.Visible;
    Checked := FStatusBar.Visible;
  end;
end;

procedure TMyAction.Notification(AComponent: TComponent; Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if (Operation = opRemove) and (AComponent = StatusBar) then
    StatusBar := nil;
end;

procedure TMyAction.SetStatusBar(AValue: TStatusBar);
begin
  if FStatusBar <> AValue then
  begin
    FStatusBar := AValue;
    if Assigned(FStatusBar) then
    begin
      FStatusBar.FreeNotification(Self);
      Checked := FStatusBar.Visible;
    end
    else
      Checked := false;
  end;
end;

TMediaPlayer: What track am I on?

Problem/Question/Abstract:

TMediaPlayer: What track am I on?

Answer:

Although writing multimedia applications using Delphi is a three-step process (click, drag and drop!), some people still ask how to find out what track is currently playing on the CD player. Just get that info, just drop a TMediaPlayer component on the form, with all the properties correctly set and bound to the CD player. Also, add "MMSystem" to the uses clause in the calling form. To complete, create a TTimer and put the code below in its OnTimer event:

var
  Trk, Min, Sec: word;
begin
  with MediaPlayer1 do
  begin
    Trk := MCI_TMSF_TRACK(Position);
    Min := MCI_TMSF_MINUTE(Position);
    Sec := MCI_TMSF_SECOND(Position);
    Label1.Caption := Format('%.2d', [Trk]);
    Label2.Caption := Format('%.2d:%.2d', [Min, Sec]);
  end;
end;

How to create a brush using CreateBrushIndirect

Problem/Question/Abstract:

How to create a brush using CreateBrushIndirect

Answer:

procedure TForm1.Button1Click(Sender: TObject);
var
  Region: HRGN;
  LogBrush: TLogBrush;
  NewBrush: hBrush;
begin
  with LogBrush do
  begin
    lbStyle := BS_HATCHED;
    lbColor := clBlue;
    lbHatch := HS_CROSS
  end;
  NewBrush := CreateBrushIndirect(LogBrush);
  Region := CreateEllipticRgnIndirect(PaintBox1.BoundsRect);
  FillRgn(PaintBox1.Canvas.Handle, Region, NewBrush);
  DeleteObject(NewBrush);
  DeleteObject(Region)
end;

SQL Server Security Setting

Problem/Question/Abstract:

How I can Set SQL Server Security in SQL Server Authentication without windows Authentication.

Answer:

You must install new sql server and set authentication in mix mode or SQL Server and Windows authentication.

In Sql Manager, Add New Group and add New SQL Server and set connection type to SQL Server Authentication with checking check box (Always Prompt).

In Security/Login Section you should set BUILTIN/Adminstrator to Access Deny.

Every Users with windows authentication should had appropriate access with Deny Access.

Every Users with Funcional access such as creating, droping,... tables should had SQL Server Authentication with appropriate Password.

Sa should SQL Authentication wih appropriate password.

Change the color of the tabs on a PageControl

Problem/Question/Abstract:

How do I change the color of the tabs on a PageControl?

Answer:

The example below uses the OnDrawCell event to change the colour of the active Tab and of the Font used:

procedure TForm1.TabControl1DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  s: string;
  r: TRect;
begin
  s := form1.TabControl1.Tabs.Strings[tabindex];
  r := Rect;
  with Control.Canvas do
  begin
    if Active then
    begin
      Brush.Color := clinfoBK;
      Font.Color := clBlue;
    end;
    Windows.FillRect(Handle, r, Brush.Handle);
    OffsetRect(r, 0, 1);
    DrawText(Handle, PChar(s), Length(s), r, DT_CENTER or DT_SINGLELINE or
      DT_VCENTER);
  end;
end;

How to create a pie chart

Problem/Question/Abstract:

Can anyone point me in the direction of an code snippet for drawing a pie/ circle given the following definition:

procedure Pie(ACanvas: TCanvas; ACenter: TPoint; ARadius: Integer; AStartDeg, AEndDeg: Float);

which draws a pie as a section of a circle starting at AStartDeg dregrees (0 being straight up - or whatever) and ending at AEndDeg (360 beging straight up - or whatever) using ACanvas default drawing parameters (brush and pen).

Answer:

The TCanvas.Pie can be used to get what you want - with a little trig. The following has 0 degrees being to the right (as in trig classes) witha positive angle in the counterclockwise direction (as in trig classes):

uses
  Math; {DegToRad}

procedure DrawPieSlice(const Canvas: TCanvas; const Center: TPoint;
  const Radius: Integer; const StartDegrees, StopDegrees: Double);
const
  Offset = 0; {to make 0 degrees start to the right}
var
  X1, X2, X3, X4: Integer;
  Y1, Y2, Y3, Y4: Integer;
begin
  X1 := Center.X - Radius;
  Y1 := Center.Y - Radius;
  X2 := Center.X + Radius;
  Y2 := Center.Y + Radius;
  {negative signs on "Y" values to correct for "flip" from normal math defintion for "Y" dimension}
  X3 := Center.X + Round(Radius * COS(DegToRad(Offset + StartDegrees)));
  Y3 := Center.y - Round(Radius * SIN(DegToRad(Offset + StartDegrees)));
  X4 := Center.X + Round(Radius * COS(DegToRad(Offset + StopDegrees)));
  Y4 := Center.y - Round(Radius * SIN(DegToRad(Offset + StopDegrees)));
  Canvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Center: TPoint;
  Bitmap: TBitmap;
  Radius: Integer;
begin
  Assert(Image1.Width = Image1.Height); {Assume square for now}
  Bitmap := TBitmap.Create;
  try
    Bitmap.Width := Image1.Width;
    Bitmap.Height := Image1.Height;
    Bitmap.PixelFormat := pf24bit;
    Bitmap.Canvas.Brush.Color := clRed;
    Bitmap.Canvas.Pen.Color := clBlue;
    Center := Point(Bitmap.Width div 2, Bitmap.Height div 2);
    Radius := Bitmap.Width div 2;
    DrawPieSlice(Bitmap.Canvas, Center, Radius, 0, 30);
    DrawPieSlice(Bitmap.Canvas, Center, Radius, 90, 120);
    Image1.Picture.Graphic := Bitmap;
  finally
    Bitmap.Free;
  end;
end;

How to control the volume of an audio card without disturbing the balance

Problem/Question/Abstract:

I can easily adjust the left and right channels independently on an audio card using the mixer API. My question is: How do I have one trackbar set the overall volume without disturbing the current balance between channels? Or how do I use two trackbars, but "lock" them together? Basically I need to directly manipulate one channel, but have the other one follow while keeping the relative relationship between the two channels the same.

Answer:

Here is the method I use. It uses a mixer component though, but I believe the code should make sense.


procedure setVolume(percent: real);
var
  value: integer;
  balance: real;
  highChannel, lowChannel: byte;
begin
  if percent > 1 then
    percent := 1;
  if percent < 0 then
    percent := 0;
  value := high(word) - round(percent * high(word));
  if value > high(word) then
    value := high(word);
  if value < 0 then
    value := 0;
  aMixer.outputs[0].inputs[0].volume.beginUpdate;
  if (aMixer.outputs[0].inputs[0].Volume.position[0] = 0) and
    (aMixer.outputs[0].inputs[0].Volume.position[1] = 0) then
  begin
    {Both are muted, get old balance}
    if oldBalance = 10 then
      {oldBalance is set to 10 on program start (dummy value)}
    begin
      balance := 1;
      highChannel := 0;
      lowChannel := 1
    end
    else
    begin
      if oldBalance < 0 then
      begin
        highChannel := 0;
        lowChannel := 1;
        balance := oldBalance * -1
      end
      else
      begin
        highChannel := 1;
        lowChannel := 0;
        balance := oldBalance
      end
    end
  end
  else
  begin
    if aMixer.outputs[0].inputs[0].Volume.position[0] >
      aMixer.outputs[0].inputs[0].Volume.position[1] then
    begin
      highChannel := 0;
      lowChannel := 1
    end
    else
    begin
      highChannel := 1;
      lowChannel := 0
    end;
    balance := aMixer.outputs[0].inputs[0].Volume.position[lowChannel] /
      aMixer.outputs[0].inputs[0].Volume.position[highChannel]
  end;
  aMixer.outputs[0].inputs[0].Volume.position[highChannel] := value;
  aMixer.outputs[0].inputs[0].Volume.position[lowChannel] := round(value * balance);
  if value > 0 then
  begin
    oldBalance := balance;
    if highChannel = 0 then
      oldBalance := oldBalance * -1
  end;
  aMixer.outputs[0].inputs[0].volume.endUpdate
end;

Check if the current printer is ready to print in color

Problem/Question/Abstract:

How can I find out whether the current printer is ready to print in colour, rather than just capable of printing in colour?

Answer:

Solve 1:

This works for some but not all printers, depending on the driver capabilities:

{ ... }
var
  Dev, Drv, Prt: array[0..255] of Char;
  DM1: PDeviceMode;
  DM2: PDeviceMode;
  Sz: Integer;
  DevM: THandle;
begin
  Printer.PrinterIndex := -1;
  Printer.GetPrinter(Dev, Drv, Prt, DevM);
  DM1 := nil;
  DM2 := nil;
  Sz := DocumentProperties(0, 0, Dev, DM1^, DM2^, 0);
  GetMem(DM1, Sz);
  DocumentProperties(0, 0, Dev, DM1^, DM2^, DM_OUT_BUFFER);
  if DM1^.dmColor > 1 then
    Label1.Caption := Dev + ': Color'
  else
    Label1.Caption := Dev + ': Black and White';
  if DM1^.dmFields and DM_Color <> 0 then
    Label2.Caption := 'Printer supports color printing'
  else
    Label2.Caption := 'Printer does not support color printing';
  FreeMem(DM1);
end;


Solve 2:

function IsColorPrinter: bool;
var
  Device: array[0..MAX_PATH] of char;
  Driver: array[0..MAX_PATH] of char;
  Port: array[0..MAX_PATH] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  result := False;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
  begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then
    begin
      if ((pDMode^.dmFields and dm_Color) = dm_Color) then
      begin
        result := True;
      end;
      GlobalUnlock(hDMode);
    end;
  end;
end;

function SetPrinterColorMode(InColor: bool): bool;
var
  Device: array[0..MAX_PATH] of char;
  Driver: array[0..MAX_PATH] of char;
  Port: array[0..MAX_PATH] of char;
  hDMode: THandle;
  PDMode: PDEVMODE;
begin
  result := False;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(Device, Driver, Port, hDMode);
  if hDMode <> 0 then
  begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then
    begin
      if (pDMode^.dmFields and dm_Color) = dm_Color then
      begin
        if (InColor) then
        begin
          pDMode^.dmColor := DMCOLOR_COLOR;
        end
        else
        begin
          pDMode^.dmColor := DMCOLOR_MONOCHROME;
        end;
        result := True;
      end;
      GlobalUnlock(hDMode);
      Printer.PrinterIndex := Printer.PrinterIndex;
    end;
  end;
end;


Solve 3:

It is usually better to use DeviceCapabilities to examine what the printer supports. Unfortunately this will only work on Win2K and XP, not on older platforms.

uses
  printers, winspool;

function PrinterSupportsColor: Boolean;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  Result := WinSpool.DeviceCapabilities(Device, Port, DC_COLORDEVICE, nil, nil) <> 0;
end;

Bold nodes in standard TTreeview component

Problem/Question/Abstract:

How make a some nodes in standard TTreeview component as bold?

Answer:

Me frequently ask as I in SMReport Explorer form realized selection by the bold font some nodes.

Today I have decided to describe this very simple way (but very useful). It does not require an override of any custom drawing methods/events, creating a new component etc. It's a real standard way.

The standard Windows Treeview control have a few state flags (TVIS_BOLD and TVIS_CUT in our example), due to which it's possible to reach wished.

At first, let's write the procedure SetNodeState:

procedure SetNodeState(node: TTreeNode; Flags: Integer);
var
  tvi: TTVItem;
begin
  FillChar(tvi, SizeOf(tvi), 0);
  tvi.hItem := node.ItemID;
  tvi.Mask := TVIF_STATE;
  tvi.StateMask := TVIS_BOLD or TVIS_CUT;
  tvi.State := Flags;
  TreeView_SetItem(node.Handle, tvi);
end;

And now we can set a wished flags:

SetNodeState(node, TVIS_BOLD) - to set the node as Bold
SetNodeState(node, TVIS_CUT) - to set the node as Cutted
SetNodeState(node, TVIS_BOLD or TVIS_CUT) - to set the node as Bold and Cutted
SetNodeState(node, 0) - to set a node as normal

How to do syntax highlighting in a TRichEdit

Problem/Question/Abstract:

How to do syntax highlighting in a TRichEdit

Answer:

{Content of the TRichEdit for example:

This is a test to show how to find the @ character in a rich text.
The @ character occurs twice in the text.
}

procedure MarkFirstWord(RE: TRichEdit; TheWord: string; Color: TColor; Style:
  TFontStyles);
var
  i, CharPos, noChars: Integer;
begin
  CharPos := 0;
  noChars := 0;
  for i := 0 to Pred(RE.Lines.Count) do
    noChars := noChars + Length(RE.Lines[i]);
  CharPos := RE.FindText(TheWord, CharPos, noChars, [stWholeWord]);
  RE.SelStart := CharPos;
  RE.SelLength := Length(TheWord);
  RE.SelAttributes.Color := Color;
  RE.SelAttributes.Style := Style;
  RE.SelLength := 0;
end;

procedure MarkAllWords(RE: TRichEdit; TheWord: string; Color: TColor; Style:
  TFontStyles);
var
  i, CharPos, CharPos2, noChars: Integer;
begin
  CharPos := 0;
  noChars := 0;
  for i := 0 to Pred(RE.Lines.Count) do
    noChars := noChars + Length(RE.Lines[i]);
  repeat
    CharPos2 := RE.FindText(TheWord, CharPos, noChars, [stWholeWord]);
    CharPos := CharPos2 + 1;
    RE.SelStart := CharPos2;
    RE.SelLength := Length(TheWord);
    RE.SelAttributes.Color := Color;
    RE.SelAttributes.Style := Style;
  until
    charpos = 0;
  RE.SelLength := 0;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  {Will mark only the first occurance of '@' in Red}
  MarkFirstWord(RichEdit1, '@', clRed, [fsBold]);
  {Will mark all occurances of @ in Teal and italic}
  MarkAllWords(RichEdit1, '@', clTeal, [fsItalic, fsBold]);
end;

Implement forms that are modal only towards their owner form

Problem/Question/Abstract:

I have a form of which any number of instances can be created and used at once. From each of these forms the user can open another form. This form must however be modal to its creator (the first form), but not to the rest of the application.

Answer:

Create the modal form with the calling form as Owner, not with pplication as owner. In the modal form override the CreateParams method as

{ ... }
inherited;
params.WndParent := (Owner as TForm).handle;

Add a public class function to the modal form:

class function ShowForm(aOwner: TForm): TModalform;

implemented as

class function TModalForm.ShowForm(aOwner: TForm): TModalForm;
begin
  Result := TModalForm.Create(aOwner);
  aOwner.Enabled := False;
  Result.Show;
end;

Use this method to create instances of the form instead of calling the constructor directly. We also need a handler for OnClose that does

Action := caFree;
(Owner as TForm).Enabled := true;

If you do need to communicate back a modal result to the caller you will need to add a public event to the pseudomodal form to which the caller can attach a handler. This event would then be called from the OnClose event handler, passing the modalresult. Note that any buttons that should close the form with a modalresult need to explicitely call the Close method, since the modal message loop is not used that will not happen on its own.