Related
i have report in TStringGrid and need that when press space key, change bg color of selected horizontal line cells.
how can do that
TSelColor = class
public
Color: TColor;
constructor Create(const aColor: TColor);
end;
TForm1 = class(TForm)
StringGrid1: TStringGrid;
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure StringGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
private
{ Private declarations }
public
kPressed: boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var
yourColor: TColor;
begin
yourColor:= clRed;
if gdFixed in State then
TStringGrid(Sender).Canvas.Brush.Color:= clBtnFace
else if gdSelected in State then
begin
TStringGrid(Sender).Canvas.Brush.Color:= clAqua;
if kPressed and not (TStringGrid(Sender).Objects[ACol, ARow] is TSelColor) then
TStringGrid(Sender).Objects[ACol, ARow]:= TSelColor.Create(yourColor)
else if kPressed and (TStringGrid(Sender).Objects[ACol, ARow] is TSelColor) then
TStringGrid(Sender).Objects[ACol, ARow]:= nil;
end
else
begin
TStringGrid(Sender).Canvas.Brush.Color:= clWindow;
if TStringGrid(Sender).Objects[ACol, ARow] is TSelColor then
TStringGrid(Sender).Canvas.Brush.Color:= TSelColor(TStringGrid(Sender).Objects[ACol, ARow]).Color;
end;
TStringGrid(Sender).Canvas.FillRect(Rect);
TStringGrid(Sender).Canvas.TextOut(Rect.Left + 2, Rect.Top + 2, TStringGrid(Sender).Cells[ACol, ARow]);
end;
procedure TForm1.StringGrid1KeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if Key = 32 then
begin
kPressed:= true;
StringGrid1.Repaint;
kPressed:= false;
end;
end;
{ TSelColor }
constructor TSelColor.Create(const aColor: TColor);
begin
inherited Create;
Color:= aColor;
end;
StringGrid1
DefaultDrawning [false]
Options.goRowSelect [true]
I am trying to retrieve accessible information from a standard VCL TEdit control. The get_accName() and Get_accDescription() methods return empty strings, but get_accValue() returns the text value entered into the TEdit.
I am just starting to try to understand the MSAA and I'm a bit lost at this point.
Does my TEdit need to have additional published properties that would be exposed to the MSA? If so would that necessitate creating a new component that descends from TEdit and adds the additional published properties such as "AccessibleName", "AccessibleDescription", etc... ?
Also, note, I have looked at the VTVirtualTrees component which is supposed to be accessible, but the MS Active Accessibility Object Inspector still does not see the AccessibleName published property even on that control.
At this point I am at a loss and would be grateful for any advice or help in this matter.
...
interface
uses
Winapi.Windows,
Winapi.Messages,
System.SysUtils,
System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.ComCtrls,
Vcl.ExtCtrls,
oleacc;
const
WM_GETOBJECT = $003D; // Windows MSAA message identifier
OBJID_NATIVEOM = $FFFFFFF0;
type
TForm1 = class(TForm)
lblFirstName: TLabel;
edFirstName: TEdit;
panel1: TPanel;
btnGetAccInfo: TButton;
accInfoOutput: TEdit;
procedure btnGetAccInfoClick(Sender: TObject);
procedure edFirstNameChange(Sender: TObject);
private
{ Private declarations }
FFocusedAccessibleObj: IAccessible;
FvtChild: Variant;
FAccProperties: TStringList;
FAccName: string;
FAccDesc: string;
FAccValue: string;
procedure DoGetAccessibleObjectFromPoint(aPoint: TPoint);
public
{ Public declarations }
procedure BeforeDestruction; override;
property AccName: string read FAccName;
property AccDescription: string read FAccName;
property AccValue: string read FAccName;
end;
var
Form1: TForm1;
const
cCRLF = #13#10;
implementation
{$R *.dfm}
function AccessibleObjectFromPoint(ptScreen: TPoint;
out ppacc: IAccessible;
out pvarChildt: Variant): HRESULT; stdcall; external 'oleacc.dll' ;
{------------------------------------------------------------------------------}
procedure TForm1.BeforeDestruction;
begin
VarClear(FvtChild);
FFocusedAccessibleObj := nil;
end;
{------------------------------------------------------------------------------}
procedure TForm1.DoGetAccessibleObjectFromPoint(aPoint: TPoint);
var
pt: TPoint;
bsName: WideString;
bsDesc: WideString;
bsValue: WideString;
begin
if (SUCCEEDED(AccessibleObjectFromPoint(aPoint, FFocusedAccessibleObj, FvtChild))) then
try
// get_accName returns an empty string
bsName := '';
FFocusedAccessibleObj.get_accName(FvtChild, bsName);
FAccName := bsName;
FAccProperties.Add('Acc Name: ' + FAccName + ' | ' + cCRLF);
// Get_accDescription returns an empty string
bsDesc := '';
FFocusedAccessibleObj.Get_accDescription(FvtChild, bsDesc);
FAccDesc := bsDesc;
FAccProperties.Add('Acc Description: ' + FAccDesc + ' | ' + cCRLF);
// this works
bsValue := '';
FFocusedAccessibleObj.get_accValue(FvtChild, bsValue);
FAccValue := bsValue;
FAccProperties.Add('Acc Value: ' + FAccValue + cCRLF);
finally
VarClear(FvtChild);
FFocusedAccessibleObj := nil ;
end;
end;
{------------------------------------------------------------------------------}
procedure TForm1.btnGetAccInfoClick(Sender: TObject);
begin
FAccProperties := TStringList.Create;
DoGetAccessibleObjectFromPoint(edFirstName.ClientOrigin);
accInfoOutput.Text := FAccProperties.Text;
end;
end.
The VCL itself does not natively implement any support for MSAA. Windows provides default implementations for standard UI controls, which many standard VCL components wrap. If you need more MSAA support than Windows provides, you will have to implement the IAccessible interface yourself, and then have your control respond to the WM_GETOBJECT message so it can return a pointer to an instance of your implementation.
Update: For example, one way to add MSAA to an existing TEdit (if you do not want to derive your own component) might look something like this:
uses
..., oleacc;
type
TMyAccessibleEdit = class(TInterfacedObject, IAccessible)
private
fEdit: TEdit;
fDefAcc: IAccessible;
public
constructor Create(aEdit: TEdit; aDefAcc: IAccessible);
function QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
function GetTypeInfoCount(out Count: Integer): HResult; stdcall;
function GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
function GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
function Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; out pidTopic: Integer): HResult; stdcall;
function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
end;
constructor TMyAccessibleEdit.Create(aEdit: TEdit; aDefAcc: IAccessible);
begin
inherited Create;
fEdit := aEdit;
fDefAcc := aDefAcc;
end;
function TMyAccessibleEdit.QueryInterface(const IID: TGUID; out Obj): HResult; virtual; stdcall;
begin
if IID = IID_IAccessible then
Result := inherited QueryInterface(IID, Obj)
else
Result := fDefAcc.QueryInterface(IID, Obj);
end;
function TMyAccessibleEdit.GetTypeInfoCount(out Count: Integer): HResult; stdcall;
begin
Result := fDefAcc.GetTypeInfoCount(Count);
end;
function TMyAccessibleEdit.GetTypeInfo(Index, LocaleID: Integer; out TypeInfo): HResult; stdcall;
begin
Result := fDefAcc.GetTypeInfo(Index, LocaleID, TypeInfo);
end;
function TMyAccessibleEdit.GetIDsOfNames(const IID: TGUID; Names: Pointer; NameCount, LocaleID: Integer; DispIDs: Pointer): HResult; stdcall;
begin
Result := fDefAcc.GetIDsOfNames(IID, Names, NameCount, LocaleID, DispIDs);
end;
function TMyAccessibleEdit.Invoke(DispID: Integer; const IID: TGUID; LocaleID: Integer; Flags: Word; var Params; VarResult, ExcepInfo, ArgErr: Pointer): HResult; stdcall;
begin
Result := fDefAcc.Invoke(DispID, IID, LocaleID, Flags, Params, VarResult, ExcepInfo, ArgErr);
end;
function TMyAccessibleEdit.Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
begin
Result := fDefAcc.Get_accParent(ppdispParent);
end;
function TMyAccessibleEdit.Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
begin
Result := fDefAcc.Get_accChildCount(pcountChildren);
end;
function TMyAccessibleEdit.Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
begin
Result := fDefAcc.Get_accChild(varChild, ppdispChild);
end;
function TMyAccessibleEdit.Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accName(varChild, pszName);
if (Result = S_OK) and (pszName <> '') then Exit;
if Integer(varChild) = CHILDID_SELF then begin
pszName := fEdit.Name;
Result := S_OK;
end else
Result := S_FALSE;
end;
function TMyAccessibleEdit.Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accValue(varChild, pszValue);
end;
function TMyAccessibleEdit.Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accDescription(varChild, pszDescription);
if (Result = S_OK) and (pszDescription <> '') then Exit;
if Integer(varChild) = CHILDID_SELF then begin
pszDescription := fEdit.Hint;
Result := S_OK;
end else
Result := S_FALSE;
end;
function TMyAccessibleEdit.Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.Get_accRole(varChild, pvarRole);
end;
function TMyAccessibleEdit.Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.Get_accState(varChild, pvarState);
end;
function TMyAccessibleEdit.Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accHelp(varChild, pszHelp);
end;
function TMyAccessibleEdit.Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant; out pidTopic: Integer): HResult; stdcall;
begin
Result := fDefAcc.Get_accHelpTopic(pszHelpFile, varChild, pidTopic);
end;
function TMyAccessibleEdit.Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accKeyboardShortcut(varChild, pszKeyboardShortcut);
end;
function TMyAccessibleEdit.Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.Get_accFocus(pvarChild);
end;
function TMyAccessibleEdit.Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.Get_accSelection(pvarChildren);
end;
function TMyAccessibleEdit.Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
begin
Result := fDefAcc.Get_accDefaultAction(varChild, pszDefaultAction);
end;
function TMyAccessibleEdit.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.accSelect(flagsSelect, varChild);
end;
function TMyAccessibleEdit.accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer; out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.accLocation(pxLeft, pyTop, pcxWidth, pcyHeight, varChild);
end;
function TMyAccessibleEdit.accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.accNavigate(navDir, varStart, pvarEndUpAt);
end;
function TMyAccessibleEdit.accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.accHitTest(xLeft, yTop, pvarChild);
end;
function TMyAccessibleEdit.accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
begin
Result := fDefAcc.accDoDefaultAction(varChild);
end;
function TMyAccessibleEdit.Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
begin
Result := fDefAcc.Set_accName(varChild, pszName);
end;
function TMyAccessibleEdit.Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
begin
Result := fDefAcc.Set_accValue(varChild, pszValue);
end;
type
TMyForm = class(TForm)
procedure FormCreate(Sender: TObject);
...
private
DefEditWndProc: TWndMethod;
procedure EditWndProc(var Message: TMessage);
...
end;
procedure TMyForm.FormCreate(Sender: TObject);
begin
DefEditWndProc := Edit1.WindowProc;
Edit1.WindowProc := EditWndProc;
end;
procedure TMyForm.EditWndProc(var Message: TMessage);
var
DefAcc, MyAcc: IAccessible;
Ret: LRESULT;
begin
DefEditWndProc(Message);
if (Message.Msg = WM_GETOBJECT) and (DWORD(Message.LParam) = OBJID_CLIENT) and (Message.Result > 0) then
begin
if ObjectFromLresult(Message.Result, IAccessible, Message.WParam, DefAcc) = S_OK then
begin
MyAcc := TMyAccessibleEdit.Create(Edit1, DefAcc) as IAccessible;
Message.Result := LresultFromObject(IAccessible, Message.WParam, MyAcc);
end;
end;
end;
I was able to get this working via
unit mainAcc;
interface
uses
Winapi.Windows,
Winapi.Messages,
System.SysUtils,
System.Variants,
System.Classes,
Vcl.Graphics,
Vcl.Controls,
Vcl.Forms,
Vcl.Dialogs,
Vcl.StdCtrls,
Vcl.ComCtrls,
Vcl.ExtCtrls,
oleacc;
type
TForm1 = class(TForm)
lblFirstName: TLabel;
btnGetAccInfo: TButton;
accInfoOutput: TEdit;
procedure btnGetAccInfoClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
aEdit: TTWEdit;
FAccProperties: TStringList;
public
{ Public declarations }
end;
TAccessibleEdit = class(TEdit, IAccessible)
private
FOwner: TComponent;
FAccessibleItem: IAccessible;
FAccessibleName: string;
FAccessibleDescription: string;
procedure WMGetMSAAObject(var Message : TMessage); message WM_GETOBJECT;
// IAccessible
function Get_accParent(out ppdispParent: IDispatch): HResult; stdcall;
function Get_accChildCount(out pcountChildren: Integer): HResult; stdcall;
function Get_accChild(varChild: OleVariant; out ppdispChild: IDispatch): HResult; stdcall;
function Get_accName(varChild: OleVariant; out pszName: WideString): HResult; stdcall;
function Get_accValue(varChild: OleVariant; out pszValue: WideString): HResult; stdcall;
function Get_accDescription(varChild: OleVariant; out pszDescription: WideString): HResult; stdcall;
function Get_accRole(varChild: OleVariant; out pvarRole: OleVariant): HResult; stdcall;
function Get_accState(varChild: OleVariant; out pvarState: OleVariant): HResult; stdcall;
function Get_accHelp(varChild: OleVariant; out pszHelp: WideString): HResult; stdcall;
function Get_accHelpTopic(out pszHelpFile: WideString; varChild: OleVariant;
out pidTopic: Integer): HResult; stdcall;
function Get_accKeyboardShortcut(varChild: OleVariant; out pszKeyboardShortcut: WideString): HResult; stdcall;
function Get_accFocus(out pvarChild: OleVariant): HResult; stdcall;
function Get_accSelection(out pvarChildren: OleVariant): HResult; stdcall;
function Get_accDefaultAction(varChild: OleVariant; out pszDefaultAction: WideString): HResult; stdcall;
function accSelect(flagsSelect: Integer; varChild: OleVariant): HResult; stdcall;
function accLocation(out pxLeft: Integer; out pyTop: Integer; out pcxWidth: Integer;
out pcyHeight: Integer; varChild: OleVariant): HResult; stdcall;
function accNavigate(navDir: Integer; varStart: OleVariant; out pvarEndUpAt: OleVariant): HResult; stdcall;
function accHitTest(xLeft: Integer; yTop: Integer; out pvarChild: OleVariant): HResult; stdcall;
function accDoDefaultAction(varChild: OleVariant): HResult; stdcall;
function Set_accName(varChild: OleVariant; const pszName: WideString): HResult; stdcall;
function Set_accValue(varChild: OleVariant; const pszValue: WideString): HResult; stdcall;
protected
function QueryInterface(const IID: TGUID; out Obj): HResult; override;
public
constructor Create(AOwner: TComponent); override;
published
property AccessibleItem: IAccessible read FAccessibleItem write FAccessibleItem;
property AccessibleName: string read FAccessibleName write FAccessibleName;
property AccessibleDescription: string read FAccessibleDescription write FAccessibleDescription;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{------------------------------------------------------------------------------}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
inherited;
FreeAndNil(aEdit);
end;
{------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
begin
aEdit := TAccessibleEdit.Create(self);
aEdit.Visible := true;
aEdit.Parent := Form1;
aEdit.Left := 91;
aEdit.Top := 17;
aEdit.Height := 21;
aEdit.Width := 204;
aEdit.Hint := 'This is a custom accessible edit control hint';
end;
{------------------------------------------------------------------------------}
procedure TForm1.btnGetAccInfoClick(Sender: TObject);
var
vWSTemp: WideString;
vAccObj: IAccessible;
begin
FAccProperties := TStringList.Create;
if (AccessibleObjectFromWindow(aEdit.Handle, OBJID_CLIENT, IID_IAccessible, vAccObj) = S_OK) then
begin
vAccObj.Get_accName(CHILDID_SELF, vWSTemp);
FAccProperties.Add('Name: ' + vWSTemp);
vWSTemp := '';
vAccObj.Get_accDescription(CHILDID_SELF, vWSTemp);
FAccProperties.Add('Description: ' + vWSTemp);
vWSTemp := '';
vAccObj.Get_accValue(CHILDID_SELF, vWSTemp);
FAccProperties.Add('Value: ' + vWSTemp);
end;
accInfoOutput.Text := FAccProperties.Text;
end;
{ TAccessibleEdit }
{------------------------------------------------------------------------------}
constructor TAccessibleEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FOwner := AOwner;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.QueryInterface(const IID: TGUID; out Obj): HResult;
begin
if GetInterface(IID, Obj) then
Result := 0
else
Result := E_NOINTERFACE;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.accDoDefaultAction(varChild: OleVariant): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.accHitTest(xLeft, yTop: Integer;
out pvarChild: OleVariant): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.accLocation(out pxLeft, pyTop, pcxWidth, pcyHeight: Integer;
varChild: OleVariant): HResult;
var
P: TPoint;
begin
Result := S_FALSE;
pxLeft := 0;
pyTop := 0;
pcxWidth := 0;
pcyHeight := 0;
if varChild = CHILDID_SELF then
begin
P := self.ClientToScreen(self.ClientRect.TopLeft);
pxLeft := P.X;
pyTop := P.Y;
pcxWidth := self.Width;
pcyHeight := self.Height;
Result := S_OK;
end
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.accNavigate(navDir: Integer; varStart: OleVariant;
out pvarEndUpAt: OleVariant): HResult;
begin
result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.accSelect(flagsSelect: Integer; varChild: OleVariant): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accChild(varChild: OleVariant;
out ppdispChild: IDispatch): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accChildCount(out pcountChildren: Integer): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accDefaultAction(varChild: OleVariant;
out pszDefaultAction: WideString): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accDescription(varChild: OleVariant;
out pszDescription: WideString): HResult;
begin
pszDescription := '';
result := S_FALSE;
if varChild = CHILDID_SELF then
begin
pszDescription := 'TAccessibleEdit_AccessibleDescription';
Result := S_OK;
end;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accFocus(out pvarChild: OleVariant): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accHelp(varChild: OleVariant;
out pszHelp: WideString): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accHelpTopic(out pszHelpFile: WideString;
varChild: OleVariant; out pidTopic: Integer): HResult;
begin
pszHelpFile := '';
pidTopic := 0;
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
pszHelpFile := '';
pidTopic := self.HelpContext;
Result := S_OK;
end;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accKeyboardShortcut(varChild: OleVariant;
out pszKeyboardShortcut: WideString): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accName(varChild: OleVariant; out pszName: WideString): HResult;
begin
pszName := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
pszName := 'TAccessibleEdit_AccessibleName';
result := S_OK;
end;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accParent(out ppdispParent: IDispatch): HResult;
begin
ppdispParent := nil;
result := AccessibleObjectFromWindow(self.ParentWindow, CHILDID_SELF, IID_IAccessible, Pointer(ppDispParent));
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accRole(varChild: OleVariant;
out pvarRole: OleVariant): HResult;
begin
Result := S_OK;
if varChild = CHILDID_SELF then
pvarRole := ROLE_SYSTEM_OUTLINE;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accSelection(out pvarChildren: OleVariant): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accState(varChild: OleVariant;
out pvarState: OleVariant): HResult;
begin
Result := S_OK;
if varChild = CHILDID_SELF then
pvarState := STATE_SYSTEM_FOCUSED;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Get_accValue(varChild: OleVariant;
out pszValue: WideString): HResult;
begin
pszValue := '';
Result := S_FALSE;
if varChild = CHILDID_SELF then
begin
pszValue := WideString(self.Text);
result := S_OK;
end;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Set_accName(varChild: OleVariant;
const pszName: WideString): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
function TAccessibleEdit.Set_accValue(varChild: OleVariant;
const pszValue: WideString): HResult;
begin
Result := DISP_E_MEMBERNOTFOUND;
end;
{------------------------------------------------------------------------------}
procedure TAccessibleEdit.WMGetMSAAObject(var Message : TMessage);
begin
if (Message.Msg = WM_GETOBJECT) then
begin
QueryInterface(IID_IAccessible, FAccessibleItem);
Message.Result := LresultFromObject(IID_IAccessible, Message.WParam, FAccessibleItem);
end
else
Message.Result := DefWindowProc(Handle, Message.Msg, Message.WParam, Message.LParam);
end;
end.
end.
If you copy files under Windows 7, you will see the progress of the copy in a sort of progress bar begin displayed in the status or task bar button of the application.
Can this be achieved using Delphi 7 ?
I have some lengthy operation which would be ideally suited to show it's progress this way.
sample of such a button using copy with Total Commander
.
Use the ITaskbarList3 interface for that, specifically its SetProgressState and SetProgressValue methods. Use CoCreateInstance() specifying CLSID_TaskbarList and IID_ITaskbarList3 to access the interface.
For example:
type
ITaskbarList = interface(IUnknown)
['{56FDF342-FD6D-11D0-958A-006097C9A090}']
function HrInit: HRESULT; stdcall;
function AddTab(hwnd: HWND): HRESULT; stdcall;
function DeleteTab(hwnd: HWND): HRESULT; stdcall;
function ActivateTab(hwnd: HWND): HRESULT; stdcall;
function SetActiveAlt(hwnd: HWND): HRESULT; stdcall;
end;
ITaskbarList2 = interface(ITaskbarList)
['{602D4995-B13A-429B-A66E-1935E44F4317}']
function MarkFullscreenWindow(hwnd: HWND;
fFullscreen: BOOL): HRESULT; stdcall;
end;
THUMBBUTTON = record
dwMask: DWORD;
iId: UINT;
iBitmap: UINT;
hIcon: HICON;
szTip: packed array[0..259] of WCHAR;
dwFlags: DWORD;
end;
TThumbButton = THUMBBUTTON;
PThumbButton = ^TThumbButton;
ITaskbarList3 = interface(ITaskbarList2)
['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}']
function SetProgressValue(hwnd: HWND; ullCompleted: ULONGLONG;
ullTotal: ULONGLONG): HRESULT; stdcall;
function SetProgressState(hwnd: HWND;
tbpFlags: Integer): HRESULT; stdcall;
function RegisterTab(hwndTab: HWND; hwndMDI: HWND): HRESULT; stdcall;
function UnregisterTab(hwndTab: HWND): HRESULT; stdcall;
function SetTabOrder(hwndTab: HWND;
hwndInsertBefore: HWND): HRESULT; stdcall;
function SetTabActive(hwndTab: HWND; hwndMDI: HWND;
tbatFlags: Integer): HRESULT; stdcall;
function ThumbBarAddButtons(hwnd: HWND; cButtons: UINT;
pButton: PThumbButton): HRESULT; stdcall;
function ThumbBarUpdateButtons(hwnd: HWND; cButtons: UINT;
pButton: PThumbButton): HRESULT; stdcall;
function ThumbBarSetImageList(hwnd: HWND;
himl: HIMAGELIST): HRESULT; stdcall;
function SetOverlayIcon(hwnd: HWND; hIcon: HICON;
pszDescription: LPCWSTR): HRESULT; stdcall;
function SetThumbnailTooltip(hwnd: HWND;
pszTip: LPCWSTR): HRESULT; stdcall;
function SetThumbnailClip(hwnd: HWND;
var prcClip: TRect): HRESULT; stdcall;
end;
const
CLSID_TaskbarList: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}';
TBPF_NOPROGRESS = 0;
TBPF_INDETERMINATE = $1;
TBPF_NORMAL = $2;
TBPF_ERROR = $4;
TBPF_PAUSED = $8;
var
TBL: ITaskbarList3;
I: Integer;
begin
CoCreateInstance(CLSID_TaskbarList, nil, CLSCTX_INPROC, ITaskbarList3, TBL);
if (TBL <> nil) then
TBL.SetProgressState(Application.Handle, TBPF_INDETERMINATE);
try
for I := 0 to 100 do
begin
if (TBL <> nil) then
TBL.SetProgressValue(Application.Handle, I, 100);
Sleep(1000);
end;
finally
if (TBL <> nil) then
TBL.SetProgressState(Application.Handle, TBPF_NOPROGRESS);
end;
end;
Also you can try my unit (Tested in Delphi 7):
{*******************************************************************************
Windows 7 TaskBar Progress Unit File
File Version: 0.0.0.3
https://github.com/tarampampam
*******************************************************************************}
unit Win7TaskBarProgressUnit;
interface
uses
Windows, ActiveX;
type
ITaskbarList = interface(IUnknown)
['{56FDF342-FD6D-11D0-958A-006097C9A090}']
function HrInit: HRESULT; stdcall;
function AddTab(hwnd: LongWord): HRESULT; stdcall;
function DeleteTab(hwnd: LongWord): HRESULT; stdcall;
function ActivateTab(hwnd: LongWord): HRESULT; stdcall;
function SetActiveAlt(hwnd: LongWord): HRESULT; stdcall;
end;
ITaskbarList2 = interface(ITaskbarList)
['{602D4995-B13A-429B-A66E-1935E44F4317}']
function MarkFullscreenWindow(hwnd: LongWord;
fFullscreen: LongBool): HRESULT; stdcall;
end;
ITaskbarList3 = interface(ITaskbarList2)
['{EA1AFB91-9E28-4B86-90E9-9E9F8A5EEFAF}']
procedure SetProgressValue(hwnd: LongWord; ullCompleted: UInt64; ullTotal: UInt64); stdcall;
procedure SetProgressState(hwnd: LongWord; tbpFlags: Integer); stdcall;
end;
type
TTaskBarProgressStyle = (tbpsNone, tbpsIndeterminate, tbpsNormal, tbpsError, tbpsPaused);
TWin7TaskProgressBar = class
glHandle: LongWord;
glMin: Byte;
glMax,
glValue: Integer;
glStyle: TTaskBarProgressStyle;
glVisible,
glMarquee: Boolean;
glTaskBarInterface: ITaskbarList3;
private
procedure SetProgress(const Value: Integer);
procedure SetMax(const Value: Integer);
procedure SetStyle(const Style: TTaskBarProgressStyle);
procedure SetVisible(const IsVisible: Boolean);
procedure SetMarquee(const IsMarquee: Boolean);
published
constructor Create(const Handle: LongWord);
property Max: Integer read glMax write SetMax default 100;
property Min: Byte read glMin default 0;
property Progress: Integer read glValue write SetProgress default 0;
property Marquee: Boolean read glMarquee write SetMarquee default False;
property Style: TTaskBarProgressStyle read glStyle write SetStyle default tbpsNone;
property Visible: Boolean read glVisible write SetVisible default False;
destructor Destroy; override;
end;
implementation
procedure TWin7TaskProgressBar.SetMax(const Value: Integer);
begin
glMax := Value;
SetProgress(glValue);
end;
procedure TWin7TaskProgressBar.SetProgress(const Value: Integer);
begin
if (glTaskBarInterface <> nil) and (glHandle <> 0) then begin
glValue := Value;
if not glMarquee then
glTaskBarInterface.SetProgressValue(glHandle, UInt64(glValue), UInt64(glMax));
end;
end;
procedure TWin7TaskProgressBar.SetStyle(const Style: TTaskBarProgressStyle);
const
Flags: array[TTaskBarProgressStyle] of Cardinal = (0, 1, 2, 4, 8);
begin
if (glTaskBarInterface <> nil) and (glHandle <> 0) then
glTaskBarInterface.SetProgressState(glHandle, Flags[Style]);
glStyle := Style;
end;
procedure TWin7TaskProgressBar.SetVisible(const IsVisible: Boolean);
begin
if IsVisible then begin
if (glStyle <> tbpsNormal) then
SetStyle(tbpsNormal)
end else
SetStyle(tbpsNone);
glVisible := IsVisible;
end;
procedure TWin7TaskProgressBar.SetMarquee(const IsMarquee: Boolean);
begin
if IsMarquee then
SetStyle(tbpsIndeterminate)
else begin
SetStyle(tbpsNone);
if glVisible then begin
SetProgress(glValue);
SetStyle(tbpsNormal);
end;
end;
glMarquee := IsMarquee;
end;
constructor TWin7TaskProgressBar.Create(const Handle: LongWord);
const
CLSID_TaskbarList: TGUID = '{56FDF344-FD6D-11d0-958A-006097C9A090}';
var
OSVersionInfo : TOSVersionInfo;
begin
OSVersionInfo.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
if (Handle <> 0) and GetVersionEx(OSVersionInfo) then
if OSVersionInfo.dwMajorVersion >= 6 then try
glHandle := Handle;
CoCreateInstance(CLSID_TaskbarList, nil, CLSCTX_INPROC, ITaskbarList3, glTaskBarInterface);
if (glTaskBarInterface <> nil) then
glTaskBarInterface.SetProgressState(glHandle, 0);
glMin := 0;
glMax := 100;
glValue := 10;
glStyle := tbpsNormal;
SetStyle(glStyle);
SetVisible(glVisible);
except
glTaskBarInterface := nil;
end;
end;
destructor TWin7TaskProgressBar.Destroy;
begin
if (glTaskBarInterface <> nil) then begin
glTaskBarInterface.SetProgressState(glHandle, 0);
glTaskBarInterface := nil;
end;
end;
end.
There are some complete solutions like TaskBarList component.
TTaskbarListProgress is a Pascal wrapper class for displaying progress in the taskbar.
i've played a little bit with the Scenic Ribbon API (Windows Ribbon Framework). This is my result:
program RibTest;
uses
Windows,
Messages,
ActiveX,
ComObj;
{$R 'e:\ribbon\test.res'}
type
UI_VIEWTYPE = (UI_VIEWTYPE_RIBBON = 1);
UI_VIEWVERB = (UI_VIEWVERB_CREATE = 0, UI_VIEWVERB_DESTROY = 1,
UI_VIEWVERB_SIZE = 2, UI_VIEWVERB_ERROR = 3);
UI_COMMANDTYPE = (UI_COMMANDTYPE_UNKNOWN = 0,
UI_COMMANDTYPE_GROUP = 1,
UI_COMMANDTYPE_ACTION = 2,
UI_COMMANDTYPE_ANCHOR = 3,
UI_COMMANDTYPE_CONTEXT = 4,
UI_COMMANDTYPE_COLLECTION = 5,
UI_COMMANDTYPE_COMMANDCOLLECTION = 6,
UI_COMMANDTYPE_DECIMAL = 7,
UI_COMMANDTYPE_BOOLEAN = 8,
UI_COMMANDTYPE_FONT = 9,
UI_COMMANDTYPE_RECENTITEMS = 10,
UI_COMMANDTYPE_COLORANCHOR = 11,
UI_COMMANDTYPE_COLORCOLLECTION = 12);
UI_EXECUTEVERB = (UI_EXECUTIONVERB_EXECUTE = 0,
UI_EXECUTIONVERB_PREVIEW = 1,
UI_EXECUTIONVERB_CANCELPREVIEW = 2);
IUIRibbon = interface
['{803982ab-370a-4f7e-a9e7-8784036a6e26}']
function GetHeight(var CY: UInt32): HRESULT; StdCall;
function LoadSettingsFromStream(Stream: IStream): HRESULT; StdCall;
function SaveSettingsToStream(Stream: IStream): HRESULT; StdCall;
end;
IUISimplePropertySet = interface
['{c205bb48-5b1c-4219-a106-15bd0a5f24e2}']
function GetValue(Key: TPropertyKey; var Value: TPropVariant): HRESULT; StdCall;
end;
IUICommandHandler = interface
['{75ae0a2d-dc03-4c9f-8883-069660d0beb6}']
function Execute(CommandID: UInt32; Verb: UI_EXECUTEVERB; Key: TPropertyKey;
Value: TPropVariant; ExecProps: IUISimplePropertySet): HRESULT; StdCall;
function UpdateProperty(CommandID: UInt32; Key: TPropertyKey; CurrValue: TPropVariant;
var NewValue: TPropertyKey): HRESULT; StdCall;
end;
IUIApplication = interface
['{D428903C-729A-491d-910D-682A08FF2522}']
function OnViewChanged(ViewID: UInt32; TypeID: UI_VIEWTYPE; View: IUnknown;
Verb: UI_VIEWVERB; ReasonCode: Int32): HRESULT; stdcall;
function OnCreateUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT; stdcall;
function OnDestroyUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT; stdcall;
end;
UI_INVALIDATIONS = (UI_INVALIDATIONS_STATE = 1, UI_INVALIDATIONS_VALUE = 2,
UI_INVALIDATIONS_PROPERTY = 4, UI_INVALIDATIONS_ALLPROPERTIES = 8);
IUIFramework = interface
['{F4F0385D-6872-43a8-AD09-4C339CB3F5C5}']
function Initialize(FrameWnd: HWND; App: IUIApplication): HRESULT; StdCall;
function LoadUI(Instance: Cardinal; RecName: LPCWSTR): HRESULT; StdCall;
function GetView(ViedID: Uint32; RiID: TIID; var PPV: Pointer): HRESULT; StdCall;
function GetUICommandProperty(CommandID: UInt32; Key: TPropertyKey;
var Value: TPropVariant): HRESULT; StdCall;
function SetUICommandProperty(CommandID: UInt32; Key: TPropertyKey;
Value: TPropVariant): HRESULT; StdCall;
function InvalidateUICommand(CommandID: UInt32; Flags: UI_INVALIDATIONS;
const Key: PPropertyKey): HRESULT; StdCall;
function FlushPendingInvalidations: HRESULT; StdCall;
function SetModes(iModes: Int32): HRESULT; StdCall;
end;
TTest = class(TInterfacedObject, IUIApplication)
public
function OnViewChanged(ViewID: UInt32; TypeID: UI_VIEWTYPE; View: IUnknown;
Verb: UI_VIEWVERB; ReasonCode: Int32): HRESULT; stdcall;
function OnCreateUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT; stdcall;
function OnDestroyUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT; stdcall;
end;
const
CLSID_UIRibbonFramework: TGUID = '{926749fa-2615-4987-8845-c33e65f2b957}';
var
MyApp: TTest;
MeinHandle: HWND;
tmpFrameW: IUIFramework;
function WndProc(hWnd: HWND; uMsg: UINT; wParam: WPARAM;
lParam: LPARAM): LRESULT; stdcall;
var
Res: HRESULT;
begin
Result := 0;
case uMsg OF
WM_CREATE:
begin
CoInitialize(nil);
CoCreateInstance(CLSID_UIRibbonFramework, nil, CLSCTX_INPROC_SERVER,
IUIFramework, tmpFrameW);
if Succeeded(tmpFrameW.Initialize(hWnd, IUIApplication(MyApp))) then
begin
Res := tmpFrameW.LoadUI(HInstance, PChar('APPLICATION_RIBBON'));
if not Succeeded(Res)then
sleep(5);
end;
end;
WM_DESTROY:
begin
PostQuitMessage(0);
end;
else
Result := DefWindowProc(hWnd, uMsg, wParam, lParam);
end;
end;
var
wc: TWndClassEx;
msg: TMSG;
{ TTest }
function TTest.OnCreateUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TTest.OnDestroyUICommand(CommandID: UInt32; TypeID: UI_COMMANDTYPE;
CommandHandler: IUICommandHandler): HRESULT;
begin
Result := E_NOTIMPL;
end;
function TTest.OnViewChanged(ViewID: UInt32; TypeID: UI_VIEWTYPE;
View: IUnknown; Verb: UI_VIEWVERB; ReasonCode: Int32): HRESULT;
begin
Result := E_NOTIMPL;
end;
begin
MyApp := TTest.Create;
wc.cbSize := SizeOf(TWndClassEx);
wc.style := 0;
wc.cbClsExtra := 0;
wc.cbWndExtra := 0;
wc.hbrBackground := COLOR_WINDOW;
wc.lpszMenuName := nil;
wc.lpszClassName := 'MeinRibbon';
wc.hIconSm := 0;
wc.hInstance := HInstance;
wc.hIcon := LoadIcon(HInstance, MAKEINTRESOURCE(1));
wc.hCursor := LoadCursor(0, IDC_ARROW);
wc.lpfnWndProc := #WndProc;
RegisterClassEx(wc);
MeinHandle := CreateWindow('MeinRibbon', 'TestAPP',
WS_OVERLAPPED or WS_CLIPCHILDREN or WS_SYSMENU or WS_CAPTION,
Integer(CW_USEDEFAULT), 0, Integer(CW_USEDEFAULT), 0, HWND_DESKTOP,
0, HInstance, nil);
ShowWindow(MeinHandle, SW_SHOWNORMAL);
UpdateWindow(MeinHandle);
while True do
begin
if not GetMessage(msg, 0, 0, 0) then break;
translatemessage(msg);
dispatchmessage(msg);
end;
ExitCode := GetLastError;
end.
Everything runs without an error. I've made a resource with the Ribbon binary XML definition and it got linked correctly into my executable. But my window appears without the Ribbon.
The important part is in WndProc. The framework gets initialized with tmpFrameW.Initialize (seems to be correct). The reference counter of MyApp (it's my IUIApplication implementation) increases. With a call to tmpFrameW.LoadUI the Ribbon definition should be loaded. There is no error in this call (result is 0 and no exception raises) but the reference counter of MyApp decreases.
That's what happens... Does anybody have an idea what i'm doing wrong?
I've found the error...
I'm not familiar with c or c++. (I guess) Therefore i've overlooked some asterisks and some out's. So there are some incorrect params which leads to minor bugs.
But my main problem is the header file. In UIRibbon.h is the function IUIFramework.Destroy missing. In the online SDK and in the UIRibbon.idl this function is defined. I added it to my interface and now everything works like expected.
i want to adjust the volume programatically like Get/SetMasterVolume in vista and xp? using mmsystem unit?
Here's the implementation of a general purpose api for audio: MMDevApi
http://social.msdn.microsoft.com/Forums/en/windowspro-audiodevelopment/thread/5ce74d5d-2b1e-4ca9-a8c9-2e27eb9ec058
and an example with a button
unit Unit33;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, MMDevApi, ActiveX, StdCtrls;
type
TForm33 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form33: TForm33;
endpointVolume: IAudioEndpointVolume = nil;
implementation
{$R *.dfm}
procedure TForm33.Button1Click(Sender: TObject);
var
VolumeLevel: Single;
begin
if endpointVolume = nil then Exit;
VolumeLevel := 0.50;
endpointVolume.SetMasterVolumeLevelScalar(VolumeLevel, nil);
Caption := Format('%1.8f', [VolumeLevel])
end;
procedure TForm33.FormCreate(Sender: TObject);
var
deviceEnumerator: IMMDeviceEnumerator;
defaultDevice: IMMDevice;
begin
CoCreateInstance(CLASS_IMMDeviceEnumerator, nil, CLSCTX_INPROC_SERVER, IID_IMMDeviceEnumerator, deviceEnumerator);
deviceEnumerator.GetDefaultAudioEndpoint(eRender, eConsole, defaultDevice);
defaultDevice.Activate(IID_IAudioEndpointVolume, CLSCTX_INPROC_SERVER, nil, endpointVolume);
end;
end.
Windows XP:
function SetMasterVolume(VolToSet: word; out VolSet: word): MMResult;
var
MixerHandle: HMixer;
Volume: TMixerControlDetails_Unsigned;
MixerLine: TMixerLine;
MixerLineControls: TMixerLineControls;
VolumeCtrl: TMixerControl;
MixerControlDetails: TMixerControlDetails;
begin
// Get mixer handle
Result := mixerOpen(#MixerHandle, 0, 0, 0, 0);
if Result <> MMSYSERR_NOERROR then Exit;
try
// Get master volume line
FillChar(MixerLine, SizeOf(TMixerLine), 0);
MixerLine.cbStruct := SizeOf(TMixerLine);
MixerLine.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
Result := mixerGetLineInfo(MixerHandle, #MixerLine, MIXER_GETLINEINFOF_COMPONENTTYPE);
if Result <> MMSYSERR_NOERROR then Exit;
// Get the volume control of the master volume line
FillChar(VolumeCtrl, SizeOf(TMixerControl), 0);
MixerLineControls.cbStruct := SizeOf(TMixerLineControls);
MixerLineControls.dwLineID := MixerLine.dwLineID;
MixerLineControls.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
MixerLineControls.cControls := 1;
MixerLineControls.cbmxctrl := SizeOf(TMixerControl);
MixerLineControls.pamxctrl := #VolumeCtrl;
Result := mixerGetLineControls(MixerHandle,#MixerLineControls,MIXER_GETLINECONTROLSF_ONEBYTYPE);
if Result <> MMSYSERR_NOERROR then Exit;
// Set details (volume) for the volume control of the master volume line
FillChar(MixerControlDetails, SizeOf(TMixerControlDetails), 0);
MixerControlDetails.cbStruct := SizeOf(TMixerControlDetails);
MixerControlDetails.dwControlID := VolumeCtrl.dwControlID;
MixerControlDetails.cChannels := 1;
MixerControlDetails.cMultipleItems := 0;
MixerControlDetails.cbDetails := SizeOf(TMixerControlDetails_Unsigned);
MixerControlDetails.paDetails := #Volume;
Volume.dwValue := VolToSet;
Result := mixerSetControlDetails(MixerHandle, #MixerControlDetails,MIXER_SETCONTROLDETAILSF_VALUE);
finally
mixerClose(MixerHandle);
end;
end;
And the call:
var y:word;
begin
SetMasterVolume(2000,y);
end;
Final code is(for Delphi 7):
unit DevUnit;
interface
uses Windows, ActiveX, Classes, Graphics, OleServer, OleCtrls, StdVCL,ComObj;
const
// TypeLibrary Major and minor versions
CLASS_IMMDeviceEnumerator: TGUID = '{BCDE0395-E52F-467C-8E3D-C4579291692E}';
IID_IMMDeviceEnumerator: TGUID = '{A95664D2-9614-4F35-A746-DE8DB63617E6}';
IID_IMMDevice: TGUID = '{D666063F-1587-4E43-81F1-B948E807363F}';
IID_IMMDeviceCollection: TGUID = '{0BD7A1BE-7A1A-44DB-8397-CC5392387B5E}';
IID_IAudioEndpointVolume: TGUID = '{5CDF2C82-841E-4546-9722-0CF74078229A}';
IID_IAudioMeterInformation : TGUID = '{C02216F6-8C67-4B5B-9D00-D008E73E0064}';
IID_IAudioEndpointVolumeCallback: TGUID = '{657804FA-D6AD-4496-8A60-352752AF4F89}';
DEVICE_STATE_ACTIVE = $00000001;
DEVICE_STATE_UNPLUGGED = $00000002;
DEVICE_STATE_NOTPRESENT = $00000004;
DEVICE_STATEMASK_ALL = $00000007;
type
EDataFlow = TOleEnum;
const
eRender = $00000000;
eCapture = $00000001;
eAll = $00000002;
EDataFlow_enum_count = $00000003;
type
ERole = TOleEnum;
const
eConsole = $00000000;
eMultimedia = $00000001;
eCommunications = $00000002;
ERole_enum_count = $00000003;
type
IAudioEndpointVolumeCallback = interface(IUnknown)
['{657804FA-D6AD-4496-8A60-352752AF4F89}']
end;
IMMAudioEndpointVolume = interface(IUnknown)
['{5CDF2C82-841E-4546-9722-0CF74078229A}']
Function RegisterControlChangeNotify( AudioEndPtVol: IAudioEndpointVolumeCallback): Integer; stdcall;
Function UnregisterControlChangeNotify( AudioEndPtVol: IAudioEndpointVolumeCallback): Integer; stdcall;
Function GetChannelCount(out PInteger): Integer; stdcall;
Function SetMasterVolumeLevel(fLevelDB: single; pguidEventContext: PGUID):Integer; stdcall;
Function SetMasterVolumeLevelScalar(fLevelDB: single; pguidEventContext: PGUID):Integer; stdcall;
Function GetMasterVolumeLevel(out fLevelDB: single):Integer; stdcall;
Function GetMasterVolumeLevelScaler(out fLevel: single):Integer; stdcall;
Function SetChannelVolumeLevel(nChannel: Integer; fLevelDB: single; pguidEventContext: PGUID):Integer; stdcall;
Function SetChannelVolumeLevelScalar(nChannel: Integer; fLevelDB: single; pguidEventContext: PGUID):Integer; stdcall;
Function GetChannelVolumeLevel(nChannel: Integer; out fLevelDB: single) : Integer; stdcall;
Function GetChannelVolumeLevelScalar(nChannel: Integer; out fLevel: single) : Integer; stdcall;
Function SetMute(bMute: Boolean ; pguidEventContext: PGUID) :Integer; stdcall;
Function GetMute(out bMute: Boolean ) :Integer; stdcall;
Function GetVolumeStepInfo( pnStep: Integer; out pnStepCount: Integer):Integer; stdcall;
Function VolumeStepUp(pguidEventContext: PGUID) :Integer; stdcall;
Function VolumeStepDown(pguidEventContext: PGUID) :Integer; stdcall;
Function QueryHardwareSupport(out pdwHardwareSupportMask): Integer; stdcall;
Function GetVolumeRange(out pflVolumeMindB: single; out pflVolumeMaxdB: single; out pflVolumeIncrementdB: single): Integer; stdcall;
end;
IPropertyStore = interface(IUnknown)
end;
type
IMMDevice = interface(IUnknown)
['{D666063F-1587-4E43-81F1-B948E807363F}']
Function Activate( refId :PGUID;
dwClsCtx: DWORD;
pActivationParams: PInteger ;
out pEndpointVolume: IMMAudioEndpointVolume): Hresult; stdCall;
Function OpenPropertyStore(stgmAccess: DWORD; out ppProperties :IPropertyStore): Hresult; stdcall;
Function GetId(out ppstrId: PLPWSTR ): Hresult; stdcall;
Function GetState(out State :Integer): Hresult; stdcall;
end;
IMMDeviceCollection = interface(IUnknown)
['{0BD7A1BE-7A1A-44DB-8397-CC5392387B5E}']
end;
IMMNotificationClient = interface (IUnknown)
['{7991EEC9-7E89-4D85-8390-6C703CEC60C0}']
end;
IMMDeviceEnumerator = interface(IUnknown)
['{A95664D2-9614-4F35-A746-DE8DB63617E6}']
Function EnumAudioEndpoints( dataFlow: EDataFlow; deviceState: SYSUINT; DevCollection:IMMDeviceCollection ): Hresult ; stdcall;
Function GetDefaultAudioEndpoint(EDF: SYSUINT; ER: SYSUINT; out Dev :IMMDevice ): Hresult ; stdcall;
Function GetDevice( pwstrId: pointer ; out Dev :IMMDevice) : HResult; stdcall;
Function RegisterEndpointNotificationCallback(pClient :IMMNotificationClient) :Hresult; stdcall;
end;
implementation
end.
The MMDevApi has a number of incorrect declarations. The double parameters should be single. The Boolean parameters work better as integer. And many if not all of the TGUID parameters should be PGUID. After correcting the declarations I was able to set the mute and the volume level.