I have a problem with my Pascal code.
There is some error and I don´t know where.
program GTA6;
uses
Crt;
var
obraz, x, mampistoli, mamnuz: Integer;
begin
clrscr;
randomize;
obraz := 1;
repeat
clrscr;
if obraz = 1 then
begin
writeln('Je 9:00 rano. Probudis se ve svem byte. Nekdo ti zvoni na dvere. Pujdes otevrit(2) nebo budes zvonek ignorovat(3)?');
readln(obraz);
if (obraz <> 2) and (obraz <> 3) then
obraz := 1;
end
else
if obraz = 2 then
begin
writeln('Otevres dvere a jsou tam dva dvoumetrovy plesaty chlapi s pistolema v ruce. Prej dluzis jejich sefoj 200 000 Kc a chce je vratit do 19:00 jinak te prijdou zabit.');
writeln(' Sahnout po pistoli(4), nedelat nic (5)');
readln(obraz);
if (obraz <> 2) and (obraz <> 3) and (obraz <> 4) and (obraz<> 5) then
obraz := 2;
end
else
if obraz = 5 then
begin
if mampistoli <> 1 then
begin
writeln('Odesli. Ty zjistis, ze nemas 200 000.');
writeln('vzit si pistoli(1), nebo si vzit nuz(2)');
readln(x);
if x = 1 then
mampistoli := 1;
if x = 2 then
mamnuz := 1;
end;
writeln('Takhle narychlo tolik penez nesezenes...budes muset udelat banku, nebo tak neco.');
writeln('Vyloupit banku (6), trafiku (7), vykr st auto (8)');
readln(obraz);
if (obraz <> 6) and (obraz <> 7) and (obraz <> 8) then
obraz := 5;
end
else
if obraz = 6 then
begin
if mampistoli = 1 then
begin
writeln('Rozhodl jsi se vyloupit banku s pistoli.');
writeln('Hlidac videl tvoji zbran a vystrelil po tobe!');
x := random(100);
if x < 50 then
writeln('Trefil te primo do hlavy!');
writeln('Zemrel jsi!');
obraz := 0;
end;
until obraz = 0;
writeln('KONEC HRY');
if x > 50 then
writeln('Netrefil se!');
readln;
end.
where is problem?
Add an end; before the until statement.
You are missing an end; for one of the if statements.
You have these two if statements beginning a code block:
end else if obraz=6 then begin
if mampistoli=1 then begin
but there is only one end; to end them.
If you indent your code carefully, it is easier to spot problems like this.
repeat
...
end else if obraz=6 then
begin
if mampistoli=1 then
begin
writeln('Rozhodl jsi se vyloupit banku s pistoli.');
writeln('Hlidac videl tvoji zbran a vystrelil po tobe!');
x:=random(100);
if x< 50 then writeln('Trefil te primo do hlavy!');
writeln('Zemrel jsi!');
obraz:=0;
end;
END; <---
until obraz=0;
Related
Support for Oracle Multimedia was dropped in Oracle 19c, so my code to extract dimensions from a JPEG image is throwing an error. Is there a workaround to this issue?
For Oracle 12, my code looked like this:
BEGIN
img := ORDSYS.ORDImage.init('FILE', my_dir, my_img_name);
img.setProperties();
w := img.getWidth();
h := img.getHeight();
EXCEPTION
WHEN OTHERS THEN
w := NULL;
h := NULL;
END;
Based on code found in a response to "Getting Image size of JPEG from its binary" (I'm not sure which language), I came up with this procedure:
PROCEDURE p_jpegstats(directory_in IN VARCHAR2,
filename_in IN VARCHAR2,
height_out OUT INTEGER,
width_out OUT INTEGER,
bpc_out OUT INTEGER, -- bits per channel
cps_out OUT INTEGER -- colors per component
) IS
file bfile;
pos INTEGER:=1;
h VARCHAR2(4);
w VARCHAR2(4);
mrkr VARCHAR2(2);
len VARCHAR2(4);
bpc VARCHAR2(2);
cps VARCHAR2(2);
-- Declare a quick helper procedure for readability
PROCEDURE next_byte(buf out varchar2, amt INTEGER:=1) IS
cnt INTEGER;
BEGIN
cnt := amt;
dbms_lob.read(file, cnt, pos, buf);
pos := pos + cnt;
END next_byte;
BEGIN
-- This code is based off of code found here: https://stackoverflow.com/a/48488655/3303651
-- Open the file
file := bfilename(directory_in, filename_in);
dbms_lob.fileopen(file);
-- Init the output variables in case something goes awry.
height_out := NULL;
width_out := NULL;
bpc_out := NULL;
cps_out := NULL;
LOOP
BEGIN
LOOP
next_byte(mrkr);
EXIT WHEN mrkr <> 'FF';
END LOOP;
CONTINUE WHEN mrkr = 'D8'; -- Start of image (SOI)
EXIT WHEN mrkr = 'D9'; -- End of image (EOI)
CONTINUE WHEN mrkr BETWEEN 'D0' AND 'D7';
CONTINUE WHEN mrkr = '01'; -- TEM
next_byte(len, 2);
IF mrkr = 'C0' THEN
next_byte(bpc); -- bits per channel
next_byte(h, 2); -- height
next_byte(w, 2); -- width
next_byte(cps); -- colors per component
EXIT;
END IF;
pos := pos + to_number(len, 'XXXX') - 2;
EXCEPTION WHEN OTHERS THEN EXIT; END;
END LOOP;
-- Write back the values we found
height_out := to_number(h, 'XXXX');
width_out := to_number(w, 'XXXX');
bpc_out := to_number(bpc, 'XX');
cps_out := to_number(cps, 'XX');
-- close out the file
dbms_lob.fileclose(file);
END p_jpegstats;
This will throw an error if the directory is invalid or the file can't be opened. If the outputs are NULL, then there was some other issue.
It's probably not the most efficient or elegant code (I'm not a pro with PL/SQL [yet!]), but it works. Here is an example usage:
DECLARE
h INTEGER;
w INTEGER;
bpc INTEGER;
cps INTEGER;
BEGIN
p_jpegstats('MY_DIR', 'my_image.jpg', h, w, bpc, cps);
DBMS_OUTPUT.PUT_LINE(w || ' x ' || h || ' ' || bpc || ' ' || cps);
END;
/
This ought to return something like
800 x 200 8 3
Edit: Removed unused variable.
I am trying to create a program that takes a users input and checks if its valid as a date (years 2000 - 2099). when I was bug testing the code I put in an enter as the input twice in a row, the first time I entered an enter, no error was thrown but the second time the console flashes a message and crashes. I took a screenshot as it crashed and this is the error it showed
An unhandled exception occured at $0040CDE1
EConvertError : "" is an invalid integer
My best guess is that the error was caused by one of my StrToInt due to the EConvertError but it unclear to me as to why it only throws it on the second run through and not the first. I suspect that the error occurs on either line, 85, 98, 111, or 195.
When I initially wrote this program a was a beginner to Pascal so I apologise in advance for any sloppy code.
below is all of the code if you would like to run it for yourselves.
program DateVerifierAssignment;
uses crt, sysutils;
var
userInputArray: array[0..7] of string;
len, i, day, month, year: integer;
date, userInput, stringDay, stringMonth, stringYear: string;
errorCatch: boolean;
//DECLARING FUNCTIONS & PROCEDURES
procedure TitleScreen();
begin
//prints a coloured wall of text to give information like name and instructions
WriteLn(' o-------------------------o');
Write(' | ');TextColor(White);Write('Date Validation Program');TextColor(Cyan);WriteLn(' |');
WriteLn(' o-------------------------o');
WriteLn();
WriteLn(' o-------------------------o');
Write(' | ');TextColor(White);Write('Instructions');TextColor(Cyan);WriteLn(' |');
WriteLn(' o-------------------------o');
Write(' | ');TextColor(White);Write('Enter a date and the');TextColor(Cyan);WriteLn(' |');
Write(' | ');TextColor(White);Write('program will verify it');TextColor(Cyan);WriteLn(' |');
Write(' | ');TextColor(White);Write('and convert it to its');TextColor(Cyan);WriteLn(' |');
Write(' | ');TextColor(White);Write('long form');TextColor(Cyan);WriteLn(' |');
WriteLn(' o-------------------------o');
WriteLn();
TextColor(White);
Write(' press any key to begin');
//waits for user input then clears the screen and returns the text color to white
ReadKey();
ClrScr;
end;
function DateVerification(var userInput: string): boolean;
var
errorLimit : boolean;
bounds: integer;
begin
errorLimit := True;
//stores the length of the string as a variable
len := Length(userInput);
//checks to see if entry is 8 chracters long and displays an error message and returns user to input screen if it doesn't fit
if (len <> 8) and (errorLimit = True) then
begin
ClrScr();
TextColor(Red);
WriteLn('input was not the right length (8 characters)');
TextColor(White);
Write('make sure date fits format ');
TextColor(LightGreen);
WriteLn('dd/mm/yy');
TextColor(White);
Readkey();
ClrScr();
errorLimit := false;
Dateverification := false;
end;
//spits each character into its own spot in an array
for i := 1 to len do
userInputArray[i - 1] := userInput[i];
//tests if every slot in the array where a slash should be is a slash
for i := 0 to len-1 do
begin
if (userInputArray[2] <> '/') or (userInputArray[5] <> '/') and (errorLimit = true) then
begin
ClrScr();
TextColor(Red);
WriteLn('input did not have slashes in correct locations ');
TextColor(LightGreen);
WriteLn('dd/mm/yy');
TextColor(White);
Readkey();
ClrScr();
errorLimit := false;
Dateverification := false;
end;
end;
year := ((StrToInt(userInputArray[6]))*10) + StrToInt(userInputArray[7]);
if (year < 1) or (year > 99) and (errorLimit = true) then
begin
ClrScr();
TextColor(Red);
WriteLn('year was not from 0 to 99');
TextColor(White);
Readkey();
ClrScr();
errorLimit := false;
Dateverification := false;
end;
month := ((StrToInt(userInputArray[3]))*10) + StrToInt(userInputArray[4]);
if (month < 1) or (month > 12) and (errorLimit = true) then
begin
ClrScr();
TextColor(Red);
WriteLn('month was not from 1 to 12');
TextColor(White);
Readkey();
ClrScr();
errorLimit := false;
Dateverification := false;
end;
day := ((StrToInt(userInputArray[0]))*10) + StrToInt(userInputArray[1]);
if (month = 4) or (month = 6) or (month = 9) or (month = 11) then
bounds := 30;
if (month = 2) then
begin
if (IsLeapYear(year) = true) then
bounds := 29
else
bounds := 28;
end
else
bounds := 31;
if (day < 1) or (day > bounds) and (errorLimit = true) then
begin
ClrScr();
TextColor(Red);
WriteLn('day was not from 1 to days in month');
TextColor(White);
Readkey();
ClrScr();
errorLimit := false;
Dateverification := false;
end;
if (errorLimit = true) then
DateVerification := True;
end;
function IsLeapYear(var year: integer): boolean;
//simple function to determine if a year is a leap year on the gregorian calender
begin
if (year mod 4) = 0 then
if (year mod 100 <> 0) then
if (year mod 400 = 0) then
IsLeapYear := true
else
IsLeapYear := false
else
IsLeapyear := false
else
IsLeapyear := false
end;
procedure DateToAlpha(var userInput: string);
begin
end;
//MAIN PROGRAM
begin
//preparing for while loop later in code and changes text colour to cyan
errorCatch := true;
TextColor(Cyan);
//Displays a title screen and instruction about how to use(stored in a procedure to help with readability)
TitleScreen();
//begins a loop so that if an error is to occur the program can easily ask for a new date and try again
while (errorCatch = true) do
begin
//sets error catch to 0 so that if there a no errors the program will not loop
errorCatch := false;
//displays information on how to input a date as well as an example with different colours for better readability
Write('Enter a date in the format');TextColor(LightGreen); WriteLn(' dd/mm/yy');TextColor(White);
Write('e.g. ');TextColor(LightGreen);WriteLn(' 09/07/20'#13#10);TextColor(White);
//takes date user inputs and stores it
ReadLn(userInput);
//calls the date verification function to see if the date is valid
//(refer to dateVerification at the top of the program for more info and comments)
if (DateVerification(userInput) = false) then
errorCatch := true;
len := Length(userInput);
for i := 1 to len do
userInputArray[i - 1] := userInput[i];
year := ((StrToInt(userInputArray[6]))*10) + StrToInt(userInputArray[7]);
readKey();
end;
end.
Ordinarily on SO we don't provide fully-coded answers to qs which are obviously coursework.
In this case I thought I'd make an exception because it was obvious that you are making
unnecessarily heavy weather of this, and the way you've coded it is likely to actually get in the way
of debugging it and getting it working correctly.
So, the example below shows a very simple,
clean way to validate a date in the 21st century supplied in dd/mm/yyyy format. It
shows the correct order of processing and validation steps; if it detects an error
in any step, it says what the problem is and halts. If execution drops through to the end,
the supplied date string must be valid.
I have deliberately left out any loops
or prettifying code, because the important thing to get right first is a clean and concise
coding of the processing and validation steps. If you want to use loops, fine, but the way you've used
e.g. errorCatch, I bet that if you come back to your code in 6 months, you won't remember how
it's supposed to work. You don't need any complicated flags or loops for this task - the user simply has to be able to type exactly eight characters (followed by [Enter]) and the code will tell then whether it's valid or not.
Note I've used the standard Copy function to separate out the various parts of the
date inputted. Btw, your declaration
userInputArray: array[0..7] of string;
is just plain wrong. If you want an array of a certain number of characters, fine, but that would
just needlessly complicate handling and processing what the user types. It's far
simpler, and therefore less error-prone to accept a single string of 8 characters
and just deal with that. But in any case, to permit the string to include the / characters after the day and month digits, the length of the stringg should be 10, not eight, to allow for those and four year digits.
program DateVerification;
uses
SysUtils;
var
sUserInput,
sDay,
sMonth,
sYear : String;
iDay,
iMonth,
iYear,
iDays: Integer;
bIsLeapYear : Boolean;
function DaysInMonth(iMonth, iYear : Integer) : Integer;
begin
Result := -1; // you supply the code for this taking into account leap year for February
end;
begin
writeln('Please enter a date between 01/01/2000 and 31/12/2099 in the format shown');
readln(sUserInput);
if Length(sUserInput) <> 10 then begin
writeln('Input is wrong length.');
Halt;
end;
if (sUserInput[3] <> '/') or (sUserInput[6] <> '/') then begin
writeln('Input is incorrectly delimited.');
Halt;
end;
sDay := Copy(sUserInput, 1, 2);
sMonth := Copy(sUserInput, 4, 2);
sYear := Copy(sUserInput, 7, 4);
iYear := StrToInt(sYear);
if (iYear < 2000) or (iYear > 2099) then begin
writeln('Invalid year : ', sYear);
Halt;
end;
bIsLeapYear := IsLeapYear(iYear); // you supply the code for IsLeapYear
iMonth := StrToInt(sMonth);
if (iMonth < 1) or (iMonth > 12) then begin
writeln('Invalid month : ', sMonth);
Halt;
end;
iDay := StrToInt(sDay);
if (iDay < 1) or (iDay > DaysInMonth(iMonth, iYear)) then begin
// You need to supply the DaysInMoth function, which of course
// needs to account for February in a leap year
writeln('Invalid day of month: ', sMonth);
Halt;
end;
writeln(sUserInput, ' is a valid date.');
readln;
end.
I have to write a program in Pascal which checks whether a word is a palindrome.
For example:
if I input "abba" then write 'TRUE'
input 'abb a' then write 'TRUE'
input 'abca' write 'FALSE'
I wrote this:
program palindromek;
var i,j,delka,pul:integer;
str:string;
function palindrom(slovo:string):boolean;
const mezera=32;
begin
delka:=length(str);
if (delka mod 2) = 0 then pul:=delka div 2
else pul:=(delka-1) div 2;
for i:=1 to delka do
begin
if (ord(slovo[i])>=ord('a')) and (ord(slovo[i])<=ord('z')) then
begin
if (delka>=4)and(delka<=100) then
begin
if (length(str) mod 2) = 0 then {slovo se sudym poctem pismen}
begin
for j:=1 to pul do
begin
if slovo[j]=slovo[length(str)-j+1]
then palindrom:=true else palindrom:=false
end
end else
begin
for j:=1 to pul do
begin
if slovo[j]=slovo[length(str)-j+1]
then palindrom:=true else palindrom:=false
end
end
end else if slovo[1]=slovo[delka]
then palindrom:=true else palindrom:=false
end
end;
end;
begin
readln(str);
writeln(palindrom(str));
end.
but it has to ignore spaces. Do you have any idea please?
To remove all spaces, you can use function like this:
procedure RemoveSpacesInplace(var s: string);
var
i, SpaceCount: Integer;
begin
SpaceCount := 0;
for i := 1 to Length(s) do
if s[i] = ' ' then
Inc(SpaceCount)
else
s[i - SpaceCount] := s[i];
SetLength(s, Length(s) - SpaceCount);
end;
You can modify it for other non-letter chars.
Note that your logic for odd and even length is excessive. Try to simplify it.
You can use the functions StringReplace and ReverseString for your task.
program palindromek;
uses SysUtils, StrUtils;
var
str:string;
function palindrom(slovo:string):boolean;
begin
slovo := StringReplace(slovo, ' ', '', [rfReplaceAll]);
Result := slovo = ReverseString(slovo)
end;
begin
readln(str);
writeln(palindrom(str));
readln;
end.
If you are not allowed to use SysUtils and StrUtils then you can manually reverse your string and then compare if the original string and the reversed string are equal.
This would look something like this: (not tested!)
function palindrom(slovo:string):boolean;
var slovofor: string;
slovorev: string;
i: integer;
begin
for i:= length(slovo) downto 1 do begin
if slovo[i] <> ' ' then begin
slovofor := slovofor + slovo[length(slovo)-i+1];
slovorev := slovorev + slovo[i];
end;
end;
writeln(slovofor);
Result := slovofor = slovorev
end;
I am new to Inno Setup. I am creating an installer for my C# application using Inno Setup compiler-5.1.6.
Using my script an installer is created, and it works fine. It installs the application and can be uninstalled from control panel as well.
But my problem is that, if my application is already installed on my machine and I try to install it again it get installed without any message. It replaces the older installation.
So my requirement is that , if application is already installed , it should show me a message that "App already installed {existing version}. Do you want to replace existing installation." with 'Yes' and 'No' buttons. If user clicks 'Yes' button installer should proceed normally otherwise it should exit installation wizard without new installation.
AppVersion: it is changeable as version increases.
AppId: it will remain same for all version.
So, please can someone help me to achieve above..
Thanks in advance . .
Plz refer my question how to terminate installer if unstallation of legacy version of software is cancelled before executing it? , You can use same trick of checking registry for your app to check whether it is installed or not.
and to check version of app you can use following code that i got from https://blog.lextudio.com/2007/08/inno-setup-script-sample-for-version-comparison-2/:
[Code]
function GetNumber(var temp: String): Integer;
var
part: String;
pos1: Integer;
begin
if Length(temp) = 0 then
begin
Result := -1;
Exit;
end;
pos1 := Pos('.', temp);
if (pos1 = 0) then
begin
Result := StrToInt(temp);
temp := '';
end
else
begin
part := Copy(temp, 1, pos1 - 1);
temp := Copy(temp, pos1 + 1, Length(temp));
Result := StrToInt(part);
end;
end;
function CompareInner(var temp1, temp2: String): Integer;
var
num1, num2: Integer;
begin
num1 := GetNumber(temp1);
num2 := GetNumber(temp2);
if (num1 = -1) or (num2 = -1) then
begin
Result := 0;
Exit;
end;
if (num1 > num2) then
begin
Result := 1;
end
else if (num1 < num2) then
begin
Result := -1;
end
else
begin
Result := CompareInner(temp1, temp2);
end;
end;
function CompareVersion(str1, str2: String): Integer;
var
temp1, temp2: String;
begin
temp1 := str1;
temp2 := str2;
Result := CompareInner(temp1, temp2);
end;
function InitializeSetup(): Boolean;
var
oldVersion: String;
uninstaller: String;
ErrorCode: Integer;
begin
if RegKeyExists(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\{F768F6BA-F164-4599-BC26-DCCFC2F76855}_is1') then
begin
RegQueryStringValue(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\{F768F6BA-F164-4599-BC26-DCCFC2F76855}_is1','DisplayVersion', oldVersion);
if (CompareVersion(oldVersion, '6.0.0.1004') < 0) then
begin
if MsgBox('Version ' + oldVersion + ' of Code Beautifier Collection is already installed. Continue to use this old version?',mbConfirmation, MB_YESNO) = IDYES then
begin
Result := False;
end
else
begin
RegQueryStringValue(HKEY_LOCAL_MACHINE,'SOFTWARE\Microsoft\Windows\CurrentVersion\Uninstall\{F768F6BA-F164-4599-BC26-DCCFC2F76855}_is1','UninstallString', uninstaller);
ShellExec('runas', uninstaller, '/SILENT', '', SW_HIDE, ewWaitUntilTerminated, ErrorCode);
Result := True;
end;
end
else
begin
MsgBox('Version ' + oldVersion + ' of Code Beautifier Collection is already installed. This installer will exit.',mbInformation, MB_OK);
Result := False;
end;
end
else
begin
Result := True;
end;
end;
GetNumber function returns only 'major' release.
To apply full Version comparison, you must concatenate Major and Minor release parts.
function GetNumber(var temp: String): Integer;
var
part: String;
pos1: Integer;
begin
if Length(temp) = 0 then
begin
Result := -1;
Exit;
end;
pos1 := Pos('.', temp);
if (pos1 = 0) then
begin
Result := StrToInt(temp);
temp := '';
end
else
begin
part := Copy(temp, 1, pos1 - 1);
temp := Copy(temp, pos1 + 1, Length(temp));
insert(temp, part, pos1);
Result := StrToInt(part);
end;
end;
I'm maintaining an old code base that's using waveOutGetDevCaps to get the names of the audio devices on the system. On Windows 7 machines this results in truncated names, as WAVEOUTCAPS.szPname is limited by MAXPNAMELEN (31 chars).
What's the Win7 way of doing this?
You could use one of the Core Audio APIs:
// get the device enumerator
IMMDeviceEnumerator* pEnumerator = NULL;
HRESULT hr = CoCreateInstance(__uuidof(MMDeviceEnumerator), NULL,
CLSCTX_ALL,__uuidof(IMMDeviceEnumerator),
(void**)&pEnumerator);
// get the endpoint collection
IMMDeviceCollection* pCollection = NULL;
DWORD mask = DEVICE_STATE_ACTIVE || DEVICE_STATE_UNPLUGGED;
hr = pEnumerator->EnumAudioEndpoints(eRender, mask, &pCollection);
// get the size of the collection
UINT count = 0;
hr = pCollection->GetCount(&count);
for (int i = 0; i < (int)count; i++)
{
// get the endpoint
IMMDevice* pEndPoint = NULL;
hr = pCollection->Item(i, &pEndPoint);
// get the human readable name
String^ friendlyName;
IPropertyStore* pProps = NULL;
HRESULT hr = pEndPoint->OpenPropertyStore(STGM_READ, &pProps);
PROPVARIANT varName;
PropVariantInit(&varName);
hr = pProps->GetValue(PKEY_Device_FriendlyName, &varName);
friendlyName = gcnew String(varName.pwszVal);
PropVariantClear(&varName);
}
Error handling was removed in the above code to make it more readable. (I happen to love using C++/CLI to move between C# and the Windows APIs.)
Now the harder part will be to relate the endpoint names to the MME devices in your old code base.
I have found another way using the registry to find audio devices' full name, both Input and Output.
Works on Windows 7 and Windows 10.
procedure TForm_Config.FormCreate(Sender: TObject);
type
tagWAVEOUTCAPS2A = packed record
wMid: WORD;
wPid: WORD;
vDriverVersion: MMVERSION;
szPname: array[0..MAXPNAMELEN-1] of AnsiChar;
dwFormats: DWORD;
wChannels: WORD;
wReserved1: WORD;
dwSupport: DWORD;
ManufacturerGuid: System.TGUID;
ProductGuid: System.TGUID;
NameGuid: System.TGUID;
end;
var
i,outdevs: Integer;
woCaps: tagWAVEOUTCAPS2A;
RegistryService: TRegistry;
iClasses, iSubClasses, iNames: Integer;
audioDeviceClasses, audioDeviceSubClasses, audioDeviceNames: TStringList;
initialDeviceName, partialDeviceName, fullDeviceName: string;
begin
audioDeviceClasses := TStringList.Create;
audioDeviceSubClasses := TStringList.Create;
audioDeviceNames := TStringList.Create;
try
RegistryService := TRegistry.Create;
try
RegistryService.RootKey := HKEY_LOCAL_MACHINE;
if RegistryService.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Enum\HDAUDIO\') then begin
RegistryService.GetKeyNames(audioDeviceClasses);
RegistryService.CloseKey();
for iClasses := 0 to audioDeviceClasses.Count - 1 do begin
if RegistryService.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Enum\HDAUDIO\'+audioDeviceClasses[iClasses]) then begin
RegistryService.GetKeyNames(audioDeviceSubClasses);
RegistryService.CloseKey();
for iSubClasses := 0 to audioDeviceSubClasses.Count - 1 do begin
if RegistryService.OpenKeyReadOnly('\SYSTEM\CurrentControlSet\Enum\HDAUDIO\'+audioDeviceClasses[iClasses]+'\'+audioDeviceSubClasses[iSubClasses]) then begin
if RegistryService.ValueExists('DeviceDesc') then begin
fullDeviceName := Trim(RegistryService.ReadString('DeviceDesc'));
if AnsiPos(';',fullDeviceName) > 0 then begin
fullDeviceName := Trim(AnsiMidStr(fullDeviceName, AnsiPos(';',fullDeviceName)+1, Length(fullDeviceName)));
end;
audioDeviceNames.Add(fullDeviceName);
end;
RegistryService.CloseKey();
end;
end;
end;
end;
end;
finally
FreeAndNil(RegistryService);
end;
// WaveOutDevComboBox is a selection box (combo) placed in the form and will receive the list of output audio devices
WaveOutDevComboBox.Clear;
try
outdevs := waveOutGetNumDevs;
for i := 0 to outdevs - 1 do begin
ZeroMemory(#woCaps, sizeof(woCaps));
if waveOutGetDevCaps(i, #woCaps, sizeof(woCaps)) = MMSYSERR_NOERROR then begin
RegistryService := TRegistry.Create;
try
RegistryService.RootKey := HKEY_LOCAL_MACHINE;
if RegistryService.OpenKeyReadOnly('\System\CurrentControlSet\Control\MediaCategories\' + GUIDToString(woCaps.NameGuid)) then begin
WaveOutDevComboBox.Items.Add(RegistryService.ReadString('Name'));
RegistryService.CloseKey();
end
else begin
initialDeviceName := '';
partialDeviceName := Trim(woCaps.szPname);
if AnsiPos('(',partialDeviceName) > 0 then begin
initialDeviceName := Trim(AnsiLeftStr(partialDeviceName,AnsiPos('(',partialDeviceName)-1));
partialDeviceName := Trim(AnsiMidStr(partialDeviceName,AnsiPos('(',partialDeviceName)+1,Length(partialDeviceName)));
if AnsiPos(')',partialDeviceName) > 0 then begin
partialDeviceName := Trim(AnsiLeftStr(partialDeviceName,AnsiPos(')',partialDeviceName)-1));
end;
end;
for iNames := 0 to audioDeviceNames.Count - 1 do begin
fullDeviceName := audioDeviceNames[iNames];
if AnsiStartsText(partialDeviceName,fullDeviceName) then begin
break;
end
else begin
fullDeviceName := partialDeviceName;
end;
end;
WaveOutDevComboBox.Items.Add(initialDeviceName + IfThen(initialDeviceName<>EmptyStr,' (','') + fullDeviceName + IfThen(initialDeviceName<>EmptyStr,')',''));
end;
finally
FreeAndNil(RegistryService);
end;
end;
end;
except
WaveOutDevComboBox.Enabled := False;
end;
finally
FreeAndNil(audioDeviceClasses);
FreeAndNil(audioDeviceSubClasses);
FreeAndNil(audioDeviceNames);
end;
end;