In Windows XP, with Delphi, how to get the master volume?
I know I can set up and down sending key strokes with keybd_event(VK_VOLUME_UP, 1, 0, 0); and keybd_event(VK_VOLUME_DOWN, 1, 0, 0);, but I don't know how to get the actual value of the volume.
The below is a little modification on the example code found here (credited there is Thomas Stutz). The example there sets the microphone volume. I just modified the component type - speaker destination instead of microphone source, and replaced mixerSetControlDetails with mixerGetControlDetails, and turned the setter into a getter of course. On the few systems I tested here (XPSp3, XPSp2, W2K, 98), it seems to work. The return of the function is the speaker out of the first (default) mixer - a value of 0-65535, the 'ShowMessage' in the button handler changes it into a percentage. But don't ask me more details about it, I really have no experience with the mixer api. Instead refer here f.i., though old the article really seemed to be comprehensive to me.
function GetSpeakerVolume(var bValue: Word): Boolean;
var {0..65535}
hMix: HMIXER;
mxlc: MIXERLINECONTROLS;
mxcd: TMIXERCONTROLDETAILS;
vol: TMIXERCONTROLDETAILS_UNSIGNED;
mxc: MIXERCONTROL;
mxl: TMixerLine;
intRet: Integer;
nMixerDevs: Integer;
begin
Result := False;
// Check if Mixer is available
nMixerDevs := mixerGetNumDevs();
if (nMixerDevs < 1) then
Exit;
// open the mixer
intRet := mixerOpen(#hMix, 0, 0, 0, 0);
if intRet = MMSYSERR_NOERROR then
begin
mxl.dwComponentType := MIXERLINE_COMPONENTTYPE_DST_SPEAKERS;
mxl.cbStruct := SizeOf(mxl);
// get line info
intRet := mixerGetLineInfo(hMix, #mxl, MIXER_GETLINEINFOF_COMPONENTTYPE);
if intRet = MMSYSERR_NOERROR then
begin
ZeroMemory(#mxlc, SizeOf(mxlc));
mxlc.cbStruct := SizeOf(mxlc);
mxlc.dwLineID := mxl.dwLineID;
mxlc.dwControlType := MIXERCONTROL_CONTROLTYPE_VOLUME;
mxlc.cControls := 1;
mxlc.cbmxctrl := SizeOf(mxc);
mxlc.pamxctrl := #mxc;
intRet := mixerGetLineControls(hMix, #mxlc, MIXER_GETLINECONTROLSF_ONEBYTYPE);
if intRet = MMSYSERR_NOERROR then
begin
ZeroMemory(#mxcd, SizeOf(mxcd));
mxcd.dwControlID := mxc.dwControlID;
mxcd.cbStruct := SizeOf(mxcd);
mxcd.cMultipleItems := 0;
mxcd.cbDetails := SizeOf(vol);
mxcd.paDetails := #vol;
mxcd.cChannels := 1;
intRet := mixerGetControlDetails(hMix, #mxcd, MIXER_GETCONTROLDETAILSF_VALUE);
if intRet <> MMSYSERR_NOERROR then
ShowMessage('GetControlDetails Error')
else begin
bValue := vol.dwValue;
Result := True;
end;
end
else
ShowMessage('GetLineInfo Error');
end;
intRet := mixerClose(hMix);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Vol: Word;
begin
if GetSpeakerVolume(Vol) then
ShowMessage(IntToStr(Round(Vol * 100 / 65535)));
end;
Related
Language: delphi 6
I succeeded in opening the dialog using documentproperties.
However, I changed the settings and clicked OK, but it does not change.
I want to change the paper to A3.
Please tell me how to do it.
code:
var
FPrinterHandle:THandle;
aDevice: array[0..255] of char;
DevMode: PDeviceMode;
StubDevMode: TDeviceMode;
DeviceMode: THandle;
begin
strpcopy(aDevice, Combobox1.Text);
if OpenPrinter(aDevice,FPrinterHandle,nil) then begin
DeviceMode := GlobalAlloc(GHND, DocumentProperties(self.handle, FPrinterHandle, ADevice, StubDevMode, StubDevMode, 0));
if DeviceMode <> 0 then begin
DevMode := GlobalLock(DeviceMode);
DocumentProperties(0, FPrinterHandle, ADevice, DevMode^, DevMode^, DM_OUT_BUFFER);
DevMode^.dmFields := DM_PAPERSIZE;
DevMode^.dmPaperSize := DMPAPER_A3;
DocumentProperties(0, FPrinterHandle, ADevice, DevMode^, DevMode^, DM_OUT_BUFFER or DM_IN_BUFFER);
GlobalUnlock(DeviceMode);
GlobalFree(DeviceMode);
end;
end;
end;
It's not the code I wrote, it's from somewhere. Hope it helps.
Pass the printer name and desired paper size as parameters. (I used GetPrinter procedure)
If parameter(integer) is 0, it is set to A3, and if it is 1, it is set to A4.
And when I printed pdf file with shellexecute, I checked that it prints in the desired size.
※ Before print, the tray of the printer should be set to 'automatic selection'.
procedure SetPrinterInfo(APrinterName: PChar; Psize: Integer);
var
HPrinter : THandle;
InfoSize, BytesNeeded: Cardinal;
DevMode: PDeviceMode;
PI2: PPrinterInfo2;
PrinterDefaults: TPrinterDefaults;
begin
with PrinterDefaults do
begin
DesiredAccess := PRINTER_ACCESS_USE;
pDatatype := nil;
pDevMode := nil;
end;
if OpenPrinter(APrinterName, HPrinter, #PrinterDefaults) then
try
SetLastError(0);
//Determine the number of bytes to allocate for the PRINTER_INFO_2 construct...
if not GetPrinter(HPrinter, 2, nil, 0, #BytesNeeded) then
begin
//Allocate memory space for the PRINTER_INFO_2 pointer (PrinterInfo2)...
PI2 := AllocMem(BytesNeeded);
try
InfoSize := SizeOf(TPrinterInfo2);
if GetPrinter(HPrinter, 2, PI2, BytesNeeded, #BytesNeeded) then
begin
DevMode := PI2.pDevMode;
DevMode.dmFields := DevMode.dmFields or DM_PAPERSIZE;
if Psize = 0 then DevMode.dmPaperSize := DMPAPER_A3
else if Psize = 1 then DevMode.dmPaperSize := DMPAPER_A4;
PI2.pSecurityDescriptor := nil;
// Apply settings to the printer
if DocumentProperties(0, hPrinter, APrinterName, PI2.pDevMode^,
PI2.pDevMode^, DM_IN_BUFFER or DM_OUT_BUFFER) = IDOK then
begin
SetPrinter(HPrinter, 2, PI2, 0); // Ignore the result of this call...
end;
end;
finally
FreeMem(PI2, BytesNeeded);
end;
end;
finally
ClosePrinter(HPrinter);
end;
end;
I useSHGetFileInfo('', 0, aFileInfo, SizeOf(TSHFileInfo), SHGFI_ICON or SHGFI_SYSICONINDEX) to extract an icon list in TImageList and then associate index with TListView. Which flag I must use to get hidden style like Explorer?
To the best of my knowledge, the system does not offer such functionality. You need to create faded icons yourself, based on the original icon. You can use a function along these lines to do that:
function CreateFadedIcon(Icon: HICON): HICON;
type
TRGBA = record
B,G,R,A: Byte
end;
procedure InitialiseBitmapInfoHeader(Width, Height: Integer; var bih: BITMAPINFOHEADER);
begin
bih.biSize := SizeOf(BITMAPINFOHEADER);
bih.biWidth := Width;
bih.biHeight := 2*Height;//height of xor bitmap plus height of and bitmap
bih.biPlanes := 1;
bih.biBitCount := 32;
bih.biCompression := BI_RGB;
end;
procedure CreateXORbitmap(const sbih, dbih: BITMAPINFOHEADER; sptr, dptr: PDWORD);
var
i, j: Integer;
begin
for i := 0 to sbih.biHeight-1 do begin
for j := 0 to sbih.biWidth-1 do begin
dptr^ := sptr^;
TRGBA(dptr^).A := TRGBA(dptr^).A div 3;
inc(dptr);//relies on the fact that no padding is needed for RGBA scanlines
inc(sptr);//likewise
end;
end;
end;
var
IconInfo: TIconInfo;
sBits, xorBits: PDWORD;
xorScanSize, andScanSize: Integer;
xorBitsSize, andBitsSize: Integer;
sbih: BITMAPINFOHEADER;
dbih: ^BITMAPINFOHEADER;
resbitsSize: DWORD;
resbits: Pointer;
begin
Result := 0;
Try
if not GetIconInfo(Icon, IconInfo) then begin
exit;
end;
Try
GetDIBheaderAndBits(IconInfo.hbmColor, sbih, Pointer(sBits));
if Assigned(sBits) then begin
Try
if (sbih.biPlanes<>1) or (sbih.biBitCount<>32) then begin
exit;
end;
xorScanSize := BytesPerScanline(sbih.biWidth, 32, 32);
Assert(xorScanSize=SizeOf(DWORD)*sbih.biWidth);
andScanSize := BytesPerScanline(sbih.biWidth, 1, 32);
xorBitsSize := sbih.biHeight*xorScanSize;
andBitsSize := sbih.biHeight*andScanSize;
resbitsSize := SizeOf(BITMAPINFOHEADER) + xorBitsSize + andBitsSize;
resbits := AllocMem(resbitsSize);//AllocMem zeroises the memory
Try
dbih := resbits;
InitialiseBitmapInfoHeader(sbih.biWidth, sbih.biHeight, dbih^);
xorBits := resbits;
inc(PByte(xorBits), SizeOf(BITMAPINFOHEADER));
CreateXORbitmap(sbih, dbih^, sBits, xorBits);
//don't need to fill in the mask bitmap when using RGBA
Result := CreateIconFromResourceEx(resbits, resbitsSize, True, $00030000, sbih.biWidth, sbih.biHeight, LR_DEFAULTCOLOR);
Finally
FreeMem(resbits);
End;
Finally
FreeMem(sBits);
End;
end;
Finally
if IconInfo.hbmMask<>0 then begin
DeleteObject(IconInfo.hbmMask);
end;
if IconInfo.hbmColor<>0 then begin
DeleteObject(IconInfo.hbmColor);
end;
End;
Finally
DestroyIcon(Icon);
End;
end;
I have this code right here that modifies the clipboard and then restores it back:
function SetClipText(szText:WideString):Boolean;
var
pData: DWORD;
dwSize: DWORD;
begin
Result := FALSE;
if OpenClipBoard(0) then
begin
dwSize := (Length(szText) * 2) + 2;
if dwSize <> 0 then
begin
pData := GlobalAlloc(MEM_COMMIT, dwSize);
if pData <> 0 then
begin
CopyMemory(Pointer(pData), #szText[1], dwSize - 2);
if SetClipBoardData(CF_UNICODETEXT, pData) <> 0 then
Result := TRUE;
end;
end;
CloseClipBoard;
end;
end;
function GetClipText(var szText:WideString):Boolean;
var
hData: DWORD;
pData: Pointer;
dwSize: DWORD;
begin
Result := FALSE;
if OpenClipBoard(0) then
begin
hData := GetClipBoardData(CF_UNICODETEXT);
if hData <> 0 then
begin
pData := GlobalLock(hData);
if pData <> nil then
begin
dwSize := GlobalSize(hData);
if dwSize <> 0 then
begin
SetLength(szText, (dwSize div 2) - 1);
CopyMemory(#szText[1], pData, dwSize);
Result := TRUE;
end;
GlobalUnlock(DWORD(pData));
end;
end;
CloseClipBoard;
end;
end;
var
OldClip : WideString;
begin
repeat until GetClipText (OldClip);
repeat until SetClipText ('NewClipBoardText');
// PASTE
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), 0, 0);
keybd_event(Ord('V'), MapVirtualKey(Ord('V'), 0), KEYEVENTF_KEYUP, 0);
keybd_event(VK_CONTROL, MapVirtualKey(VK_CONTROL, 0), KEYEVENTF_KEYUP, 0);
repeat until SetClipText (OldClip);
end.
I use keybd_event to paste new clipboard text to a window (e.g. notepad).
It seems like that keybd_event is so fast, that repeat until SetClipText (OldClip); get's called before the keys got pressed. Is there way to check when and if the keys were pressed?
keybd_event never fails. It merely places they event that you specify into the currently active input queue.
Because the function is asynchronous the keyboard event is not processed until the other application gets round to processing it. So, most likely the other application has not processed the keyboard event by the time you call SetClipText. You can't expect to know when a particular keyboard event is processed, unless you have control of the other application. But in that case you would not be communicating with it by faking input.
I have created this function to get the path of various network processes, like svchost, Firefox, etc. Here is the code:
function GetProcessPath(var pId:Integer):String;
var
Handle: THandle;
begin
Result := '';
try
Handle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, pID);
if Handle <> 0 then
begin
try
SetLength(Result, MAX_PATH);
if GetModuleFileNameEx(Handle, 0, PChar(Result), MAX_PATH) > 0 then
SetLength(Result, StrLen(PChar(Result)))
else
Result := '';
finally
CloseHandle(Handle);
end;
end;
except
on E:Exception do
ShowMessage(E.ClassName + ':' + E.Message);
end;
end;
My problem is that I do not get the path of all the processes. It works fine for getting the path of Firefox, and other similar user level processes. But for processes like alg, Svchost, I cannot get the path by this method. My guess is I must use some different API. How can I fix this problem?
I am using Windows XP, 32 bits.
You need to set debug privileges. Here is how it is done:
function NTSetPrivilege(sPrivilege: string; bEnabled: Boolean): Boolean;
var
hToken: THandle;
TokenPriv: TOKEN_PRIVILEGES;
PrevTokenPriv: TOKEN_PRIVILEGES;
ReturnLength: Cardinal;
begin
Result := True;
// Only for Windows NT/2000/XP and later.
if not (Win32Platform = VER_PLATFORM_WIN32_NT) then Exit;
Result := False;
// Obtain the processes token
if OpenProcessToken(GetCurrentProcess(),
TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
begin
try
// Get the locally unique identifier (LUID) .
if LookupPrivilegeValue(nil, PChar(sPrivilege),
TokenPriv.Privileges[0].Luid) then
begin
TokenPriv.PrivilegeCount := 1; // One privilege to set
case bEnabled of
True: TokenPriv.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
False: TokenPriv.Privileges[0].Attributes := 0;
end;
ReturnLength := 0; // Replaces a var parameter
PrevTokenPriv := TokenPriv;
// Enable or disable the privilege
AdjustTokenPrivileges(hToken, False, TokenPriv, SizeOf(PrevTokenPriv),
PrevTokenPriv, ReturnLength);
end;
finally
CloseHandle(hToken);
end;
end;
end;
NtSetPrivilege('SeDebugPrivilege', TRUE); // Call this on form create
I've created a GLOBAL keyboard hook DLL, using source code found on the internet. For the best part it works brilliant, except when it comes to browsers.
It picks up every key in the browser except, it seems, when the browser gets focus, it looses the first key that is pressed. Tested this in IE and Firefox and it seems to be the same for both.
For instance, if I open IE and start typing www. , I only get back ww. If the browser window stays in focus no further keys are lost. As soon as the browser looses focus and regains focus, the first key is again missing.
Could it be because of using only WH_KEYDOWN instead of WH_KEYPRESS / WH_KEYUP ? Can anyone shed some light on this please?
Thank you
PS: The hook function itself is below: The DLL is sent a memo box and app handle to wich the DLL will send messages as well as a usermessage.
function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
KeyState1: TKeyBoardState;
AryChar: array[0..1] of Char;
Count: Integer;
begin
Result := 0;
if Code = HC_NOREMOVE then Exit;
Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);
{I moved the CallNextHookEx up here but if you want to block
or change any keys then move it back down}
if Code < 0 then
Exit;
if Code = HC_ACTION then
begin
if ((KeyStroke and (1 shl 30)) <> 0) then
if not IsWindow(hMemo) then
begin
{I moved the OpenFileMapping up here so it would not be opened
unless the app the DLL is attatched to gets some Key messages}
hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'NetParentMAP');//Global7v9k
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
if PHookRec1 <> nil then
begin
hMemo := PHookRec1.MemoHnd;
hApp := PHookRec1.AppHnd;
end;
end;
if ((KeyStroke AND (1 shl 31)) = 0) then //if ((KeyStroke and (1 shl 30)) <> 0) then
begin
GetKeyboardState(KeyState1);
Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);
if Count = 1 then
begin
SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);
{I included 2 ways to get the Charaters, a Memo Hnadle and
a WM_USER+1678 message to the program}
PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);
end;
end;
end;
end;
You are not assigning your hMemo and hApp values early enough. You are waiting until a notification with a "previous state" flag of 1, which indicates a key has been held down for at least 1 repeat count, or is being released, whichever occurs first. Thus, hMemo and hApp are not available yet when your hook detects its first key down notification. That is why you miss characters. Try this instead:
function KeyHookFunc(Code, VirtualKey, KeyStroke: Integer): LRESULT; stdcall;
var
KeyState1: TKeyBoardState;
AryChar: array[0..1] of Char;
Count: Integer;
begin
Result := CallNextHookEx(hKeyHook, Code, VirtualKey, KeyStroke);
if Code <> HC_ACTION then Exit;
{ a key notification had occured, prepare the HWNDs
before checking the actual key state }
if (hMemo = 0) or (hApp = 0) then
begin
if hMemFile = 0 then
begin
hMemFile := OpenFileMapping(FILE_MAP_WRITE, False, 'NetParentMAP');
if hMemFile = 0 then Exit;
end;
if PHookRec1 = nil then
begin
PHookRec1 := MapViewOfFile(hMemFile, FILE_MAP_WRITE, 0, 0, 0);
if PHookRec1 = nil then Exit;
end;
hMemo := PHookRec1.MemoHnd;
hApp := PHookRec1.AppHnd;
if (hMemo = 0) and (hApp = 0) then Exit;
end;
if ((KeyStroke and (1 shl 31)) = 0) then // a key is down
begin
GetKeyboardState(KeyState1);
Count := ToAscii(VirtualKey, KeyStroke, KeyState1, AryChar, 0);
if Count = 1 then
begin
if hMemo <> 0 then SendMessage(hMemo, WM_CHAR, Ord(AryChar[0]), 0);
if hApp <> 0 then PostMessage(hApp, WM_USER + 1678, Ord(AryChar[0]), 0);
end;
end;
end;