В Помошь Программисту, Функции,процедуры,компоненты и т.д. Поделиться Опции

[Udman]

Решил создать тему, которая поможет начинающим, в программировании с телефоном. Помню когда-то давно на форуме спрашивал как из цифр тех что в смс получить текст. :) Мне посоветовали этот метод. Он таже используетя при чтении справочника.

Вообщем давайте вместе выкладывать функции и все что связано с программированием у кого что есть интересное, чтобы облегчить работу начинающим программистам и не только,а то из-за каждого такого вопроса приходится создавать новую тему!

Все вопросы также пишите сюда!

function AnsiToUcs(Convert:string):string;
var
f:string;
qa:integer;
begin
result:='';
for qa:=1 to Length(Convert) do begin
f:=Convert[qa];
if f='А' then result:=result+'0410';if f='Б' then result:=result+'0411';if f='В' then result:=result+'0412';if f='Г' then result:=result+'0413';
if f='Д' then result:=result+'0414';if f='Е' then result:=result+'0415';if f='Ж' then result:=result+'0416';if f='З' then result:=result+'0417';
if f='И' then result:=result+'0418';if f='Й' then result:=result+'0419';if f='К' then result:=result+'041A';if f='Л' then result:=result+'041B';
if f='М' then result:=result+'041C';if f='Н' then result:=result+'041D';if f='О' then result:=result+'041E';if f='П' then result:=result+'041F';
if f='Р' then result:=result+'0420';if f='С' then result:=result+'0421';if f='Т' then result:=result+'0422';if f='У' then result:=result+'0423';
if f='Ф' then result:=result+'0424';if f='Х' then result:=result+'0425';if f='Ц' then result:=result+'0426';if f='Ч' then result:=result+'0427';
if f='Ш' then result:=result+'0428';if f='Щ' then result:=result+'0429';if f='Ъ' then result:=result+'042A';if f='Ы' then result:=result+'042B';
if f='Ь' then result:=result+'042C';if f='Э' then result:=result+'042D';if f='Ю' then result:=result+'042E';if f='Я' then result:=result+'042F';
if f='а' then result:=result+'0430';if f='б' then result:=result+'0431';if f='в' then result:=result+'0432';if f='г' then result:=result+'0433';
if f='д' then result:=result+'0434';if f='е' then result:=result+'0435';if f='ж' then result:=result+'0436';if f='з' then result:=result+'0437';
if f='и' then result:=result+'0438';if f='й' then result:=result+'0439';if f='к' then result:=result+'043A';if f='л' then result:=result+'043B';
if f='м' then result:=result+'043C';if f='н' then result:=result+'043D';if f='о' then result:=result+'043E';if f='п' then result:=result+'043F';
if f='р' then result:=result+'0440';if f='с' then result:=result+'0441';if f='т' then result:=result+'0442';if f='у' then result:=result+'0443';
if f='ф' then result:=result+'0444';if f='х' then result:=result+'0445';if f='ц' then result:=result+'0446';if f='ч' then result:=result+'0447';
if f='ш' then result:=result+'0448';if f='щ' then result:=result+'0449';if f='ъ' then result:=result+'044A';if f='ы' then result:=result+'044B';
if f='ь' then result:=result+'044C';if f='э' then result:=result+'044D';if f='ю' then result:=result+'044E';if f='я' then result:=result+'044F';
if f='Ё' then result:=result+'0401';if f='ё' then result:=result+'0451';if f='.' then result:=result+'002E';if f=',' then result:=result+'002C';
if f='!' then result:=result+'0021';if f='"' then result:=result+'0022';if f='№' then result:=result+'2116';if f=';' then result:=result+'003B';
if f='%' then result:=result+'0025';if f=':' then result:=result+'003A';if f='?' then result:=result+'003F';if f='*' then result:=result+'002A';
if f='(' then result:=result+'0028';if f=')' then result:=result+'0029';if f='/' then result:=result+'002F';if f='0' then result:=result+'0030';
if f='1' then result:=result+'0031';if f='2' then result:=result+'0032';if f='3' then result:=result+'0033';if f='4' then result:=result+'0034';
if f='5' then result:=result+'0035';if f='6' then result:=result+'0036';if f='7' then result:=result+'0037';if f='8' then result:=result+'0038';
if f='9' then result:=result+'0039';if f='+' then result:=result+'002B';if f='-' then result:=result+'002D';if f='=' then result:=result+'003D';
if f=',' then result:=result+'2C00';if f=' ' then result:=result+'0020';if f='A' then result:=result+'4100';if f='B' then result:=result+'4200';
if f='C' then result:=result+'4300';if f='D' then result:=result+'4400';if f='E' then result:=result+'4500';if f='F' then result:=result+'4600';
if f='G' then result:=result+'4700';if f='H' then result:=result+'4800';if f='I' then result:=result+'4900';if f='J' then result:=result+'4A00';
if f='K' then result:=result+'4B00';if f='L' then result:=result+'4C00';if f='M' then result:=result+'4D00';if f='N' then result:=result+'4E00';
if f='O' then result:=result+'4F00';if f='P' then result:=result+'5000';if f='Q' then result:=result+'5100';if f='R' then result:=result+'5200';
if f='S' then result:=result+'5300';if f='T' then result:=result+'5400';if f='U' then result:=result+'5500';if f='V' then result:=result+'5600';
if f='W' then result:=result+'5700';if f='X' then result:=result+'5800';if f='Y' then result:=result+'5900';if f='Z' then result:=result+'5A00';
if f='a' then result:=result+'6100';if f='b' then result:=result+'6200';if f='c' then result:=result+'6300';if f='d' then result:=result+'6400';
if f='e' then result:=result+'6500';if f='f' then result:=result+'6600';if f='g' then result:=result+'6700';if f='h' then result:=result+'6800';
if f='i' then result:=result+'6900';if f='j' then result:=result+'6A00';if f='k' then result:=result+'6B00';if f='l' then result:=result+'6C00';
if f='m' then result:=result+'6D00';if f='n' then result:=result+'6E00';if f='o' then result:=result+'6F00';if f='p' then result:=result+'7000';
if f='q' then result:=result+'7100';if f='r' then result:=result+'7200';if f='s' then result:=result+'7300';if f='t' then result:=result+'7400';
if f='u' then result:=result+'7500';if f='v' then result:=result+'7600';if f='w' then result:=result+'7700';if f='x' then result:=result+'7800';
if f='y' then result:=result+'7900';if f='z' then result:=result+'7A00';
end;
end;

function UcsToAnsi(Convert:string):string;
var
f:string;
qa:integer;
begin
result:='';
for qa:=1 to Length(Convert)div 4 do begin
f:=Copy(Convert,1,4);
Delete(Convert,1,4);
if f='0040' then result:=result+'@';if f='0410' then result:=result+'А';if f='0411' then result:=result+'Б';if f='0412' then result:=result+'В';
if f='0413' then result:=result+'Г';if f='0414' then result:=result+'Д';if f='0415' then result:=result+'Е';if f='0416' then result:=result+'Ж';
if f='0417' then result:=result+'З';if f='0418' then result:=result+'И';if f='0419' then result:=result+'Й';if f='041A' then result:=result+'К';
if f='041B' then result:=result+'Л';if f='041C' then result:=result+'М';if f='041D' then result:=result+'Н';if f='041E' then result:=result+'О';
if f='041F' then result:=result+'П';if f='0420' then result:=result+'Р';if f='0421' then result:=result+'С';if f='0422' then result:=result+'Т';
if f='0423' then result:=result+'У';if f='0424' then result:=result+'Ф';if f='0425' then result:=result+'Х';if f='0426' then result:=result+'Ц';
if f='0427' then result:=result+'Ч';if f='0428' then result:=result+'Ш';if f='0429' then result:=result+'Щ';if f='042A' then result:=result+'Ъ';
if f='042B' then result:=result+'Ы';if f='042C' then result:=result+'Ь';if f='042D' then result:=result+'Э';if f='042E' then result:=result+'Ю';
if f='042F' then result:=result+'Я';if f='0430' then result:=result+'а';if f='0431' then result:=result+'б';if f='0432' then result:=result+'в';
if f='0433' then result:=result+'г';if f='0434' then result:=result+'д';if f='0435' then result:=result+'е';if f='0436' then result:=result+'ж';
if f='0437' then result:=result+'з';if f='0438' then result:=result+'и';if f='0439' then result:=result+'й';if f='043A' then result:=result+'к';
if f='043B' then result:=result+'л';if f='043C' then result:=result+'м';if f='043D' then result:=result+'н';if f='043E' then result:=result+'о';
if f='043F' then result:=result+'п';if f='0440' then result:=result+'р';if f='0441' then result:=result+'с';if f='0442' then result:=result+'т';
if f='0443' then result:=result+'у';if f='0444' then result:=result+'ф';if f='0445' then result:=result+'х';if f='0446' then result:=result+'ц';
if f='0447' then result:=result+'ч';if f='0448' then result:=result+'ш';if f='0449' then result:=result+'щ';if f='044A' then result:=result+'ъ';
if f='044B' then result:=result+'ы';if f='044C' then result:=result+'ь';if f='044D' then result:=result+'э';if f='044E' then result:=result+'ю';
if f='044F' then result:=result+'я';if f='0401' then result:=result+'Ё';if f='0451' then result:=result+'ё';if f='002E' then result:=result+'.';
if f='002C' then result:=result+',';if f='0021' then result:=result+'!';if f='0022' then result:=result+'"';if f='2116' then result:=result+'№';
if f='003B' then result:=result+';';if f='0025' then result:=result+'%';if f='003A' then result:=result+':';if f='003F' then result:=result+'?';
if f='002A' then result:=result+'*';if f='0028' then result:=result+'(';if f='0029' then result:=result+')';if f='002F' then result:=result+'/';
if f='0030' then result:=result+'0';if f='0031' then result:=result+'1';if f='0032' then result:=result+'2';if f='0033' then result:=result+'3';
if f='0034' then result:=result+'4';if f='0035' then result:=result+'5';if f='0036' then result:=result+'6';if f='0037' then result:=result+'7';
if f='0038' then result:=result+'8';if f='0039' then result:=result+'9';if f='002B' then result:=result+'+';if f='002D' then result:=result+'-';
if f='003D' then result:=result+'=';if f='2C00' then result:=result+',';if f='0020' then result:=result+' ';if f='0041' then result:=result+'A';
if f='0042' then result:=result+'B';if f='0043' then result:=result+'C';if f='0044' then result:=result+'D';if f='0045' then result:=result+'E';
if f='0046' then result:=result+'F';if f='0047' then result:=result+'G';if f='0048' then result:=result+'H';if f='0049' then result:=result+'I';
if f='004A' then result:=result+'J';if f='004B' then result:=result+'K';if f='004C' then result:=result+'L';if f='004D' then result:=result+'M';
if f='004E' then result:=result+'N';if f='004F' then result:=result+'O';if f='0050' then result:=result+'P';if f='0051' then result:=result+'Q';
if f='0052' then result:=result+'R';if f='0053' then result:=result+'S';if f='0054' then result:=result+'T';if f='0055' then result:=result+'U';
if f='0056' then result:=result+'V';if f='0057' then result:=result+'W';if f='0058' then result:=result+'X';if f='0059' then result:=result+'Y';
if f='005A' then result:=result+'Z';if f='0061' then result:=result+'a';if f='0062' then result:=result+'b';if f='0063' then result:=result+'c';
if f='0064' then result:=result+'d';if f='0065' then result:=result+'e';if f='0066' then result:=result+'f';if f='0067' then result:=result+'g';
if f='0068' then result:=result+'h';if f='0069' then result:=result+'i';if f='006A' then result:=result+'j';if f='006B' then result:=result+'k';
if f='006C' then result:=result+'l';if f='006D' then result:=result+'m';if f='006E' then result:=result+'n';if f='006F' then result:=result+'o';
if f='0070' then result:=result+'p';if f='0071' then result:=result+'q';if f='0072' then result:=result+'r';if f='0073' then result:=result+'s';
if f='0074' then result:=result+'t';if f='0075' then result:=result+'u';if f='0076' then result:=result+'v';if f='0077' then result:=result+'w';
if f='0078' then result:=result+'x';if f='0079' then result:=result+'y';if f='007A' then result:=result+'z';
end;
end;

[n0wheremany]

Что за глупый, необразованный код, который доступен лишь начиниющему програмисту.

Если ты хочешь делать таким способом, то делай вот так:

Код

function UCSToAnsi(s:string):string;

function FMT(C:string):Char;
var i:integer;
begin
 i := StrToIntDef('$'+C,0);
 case i of
  1040..1103: i := i - 848;
  1105      : i := 184;
 end;
 Result := Chr(i);
end;

var C:integer;
   I:integer;
begin
Result := '';
C := Length(S) div 4;
For i:=0 to C-1 do
 Result := Result + FMT(Copy(S,i*4+1,4));
end;

function AnsitoUCS(S:string):string;

function FMT(C:Char):string;
var i:integer;
begin
 Result := '';
 i := ord(C);
 case i of
  192..255 : i := i + 848;
  184      : i := 1105;
 end;
 result := inttohex(i,4)
end;

var C:integer;
   I:integer;
begin
Result := '';
C := Length(S);
For i:=1 to C do
 Result := Result + FMT(S[i]);
end;  

[OFF]Прошу такую тему OffTop. Т.к. подобные вопросы должны рассматриваться на специальных форумах, посвящённых програмистам, а не на этом. off_topic;
[/OFF]

ЗЫ. По натуре я критик :)

[Udman]

Прошу такую тему OffTop. Т.к. подобные вопросы должны рассматриваться на специальных форумах, посвящённых програмистам, а не на этом. off_topic;

на спец форумах вопросы программирования рассматриваются очень редко. А уж тем более МОТОРОЛ. Я этих форумов облазил много. А по телефону ничего не нашел. Тем более "Ломаем и строим" это я так понял посвящается созданию программ и т.д.

За упрощенный вариант спасибо. Вот видишь какую пользу сделал!!! Теперь я буду знать как написать проще! :)))

Ни на одном форуме по программированию не найдешь, как отправить смс или считать их с помошью АТ комманд к примеру! bigsmile;

И сразу возникающий вопрос!! Как отправить смс???

[_GALE_]

Всем привет. Прикольная темка . Хочу выложить что нибудь своё. Вот фрагменты кода из одной моей проги(P2kExplorer):
Загрузка файла:

Код

procedure savefile(filename:string;dest:string);
var
buf:array[0..4095] of byte;
f:file of byte;
i:integer;
fsize:int64;
cur:int64;
toread:integer;
less:int64;
begin
toread:=4096;
cur:=0;
for I:=low(mas)to high(mas)do
if mas[i].Name=filename then
fsize:=mas[i].Size;
{$I-}
assignfile(f,dest);
rewrite(f);
file_create(pchar(filename),0);
file_setpointer(0,0);
while cur<>fsize do begin
if fsize-cur>toread then begin
file_read(buf[0],toread);
BLOCKWRITE(f,buf[low(buf)],toread);
cur:=cur+toread    end
else begin
file_read(buf[0],fsize-cur);
BLOCKWRITE(f,buf[low(buf)],fsize-cur);
cur:=cur+(fsize-cur);
end;
end;
closefile(f);
file_close;  {$I+}

end;

[n0wheremany]

Всем привет. Прикольная темка . Хочу выложить что нибудь своё. Вот фрагменты кода из одной моей проги(P2kExplorer):
Загрузка файла:

Я так понимаю здесь использование P2KApi.
Просьба, в таком случае, писать что где и как должно работать и что используется. Таких кодов много в теме P2KApi.

Кстати на Tstream Получше будет

Ни на одном форуме по программированию не найдешь, как отправить смс или считать их с помошью АТ комманд к примеру! bigsmile;

И сразу возникающий вопрос!! Как отправить смс???

http://forum.sources.ru/index.php?showtopic=128055
http://forum.sources.ru/index.php?showtopic=128057
http://forum.sources.ru/index.php?showtopic=128057

На этом форуме много подобных вопросов. На некоторые я ответил, на некоторые другие.

[Udman]

Сделал чудный компонент. Маленький но есть полезные функции. Берите кому надо!

[KEO]

Udman,

Данные о модемах и портах нашел у себя в реестре
в ключе HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Class\{4D36E96D-E325-11CE-BFC1-08002BE10318}
если и у вас так, знач все будет работать ОК!

У меня такой ветки даже нет...
советую искать модемы в ветке HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM

[Udman]

KEO,
А у тебя ХР??

В этой ветке есть только информация о активных портах но не о модемах!
HKEY_LOCAL_MACHINE\HARDWARE\DEVICEMAP\SERIALCOMM

[n0wheremany]

В этой ветке есть только информация о активных портах но не о модемах!

Модемы по другому находятся.

Кроме функции просмотра списка COM портов ничего полезного не вижу (да и то не для меня полезная). Проще вывести 1 процедуру и всё, а не писать компонент, да и ещё без исходников (как сам ниписал - в помощь програмисту).
При этом название не совпадает с содержанием. Там чёта про мото-модемы даже и не слыхано.

[Udman]

n0wheremany,

У тебя хобби всех наламывать и об.... их творения? Или после создания МотоВкл считаешь себя супер программистом по сравнению с нами? Если тебе что-то не нравится, не пользуйся. А вот критиковать не надо. Держа свою критику при себе!

Кроме функции просмотра списка COM портов ничего полезного не вижу

Может для тебя это одна единственная полезная функция, но для других они полезны все!

Проще вывести 1 процедуру и всё, а не писать компонент, да и ещё без исходников (как сам ниписал - в помощь програмисту).

А если таких процедур 30??? Что, все выводить? А в МотоВКЛ где исходники? Тему читать надо внимательней, и все что чуть ниже под темой написано!

В Помошь Программисту,функции,процедуры,компоненты и т.д.

Это значит что в этой теме выкладывать полезные функции, полезные процедуры, КОМПОНЕНТЫ, и т.д.
И если написано КОМПОНЕНТЫ, это не значит что они должны быть объязательно в исходником!

Если кто захочет, поделится своими функциями. Я решил поделится не нужным для тебя компонентом, но нужным для других!

Старое:
ActivePortNames:TStringList;
ModemPorts:TStringList;
ModemNames:TStringList;
UCSToAnsi(s:string):string;
AnsitoUCS(S:string):string;
ImportP2KToolsSMS(FileName:String):TStringList;

Новое:
ConvertSMS(SMS:TStrings)
ConvertSMSWD(SMS:TStrings)
RepairDate(DateStr:String)
CoDecode(S: String; Code: Integer)
Свойство OnUSBArrival
Свойство OnUSBRemove


Описание внутри архива!

[n0wheremany]

У тебя хобби всех наламывать и об.... их творения? Или после создания МотоВкл считаешь себя супер программистом по сравнению с нами? Если тебе что-то не нравится, не пользуйся. А вот критиковать не надо. Держа свою критику при себе!

Где-то я писал что я критик по натуре. А критика - это не наламывае, дабы показать что критикующий выше, а двигатель прогресса. Т.к. если ты исправляешь, то у тебя увеличивается опыт и функциональность созданного твоего детища. Если надо конецно могу и помочь кодом. Только попроси.
Я не считаю себя супер-програмистом, но вчмто я опытней тебя (многие и меня критиковали), ну и наверно есть то в чём и ты меня опытней. Я с такими вопросами встречался - посему могу критиковать.

Может для тебя это одна единственная полезная функция, но для других они полезны все!

Это было моё мнение. И всё. Обидеть не хотел.

А если таких процедур 30??? Что, все выводить? А в МотоВКЛ где исходники?!

Можно и выводить. МотоВКЛ это другая тема. там слишком большой код - листов 20-30 А4, да и исходники я давал когдато, по просьбе конечно.

[Udman]

n0wheremany,
Вот вместо критики, лучше напиши что-то типа: "А можно сделать еще проще" и покажи как это сделать, а не говори что это фуфло и на этом все.
Тема называется в помошь программисту, для того чтобы нам было проще, чтобы каждый раз при возникающем вопросе не создавать тему "Как зделать это?".

А компонент я сделал, потому что сечйас делаю программу "MotoSMSManager" и в старой версии тоже был исходник на 3700 с чем-то строк. Думаю ты понимаешь что это не мало, и постоянно путаеся в тексте, тяжело искать функцию или то что тебе надо, вот и решил создать для себя компонент чтобы было проще, и подумал, а почему бы и не закинуть его сюда??? Может кому какие функции понадобятся или мало ли кто-то тоже будет делать прогу по работе с смс. Тем более компонент занимает 12 кб, что не очень то и много.

Т.к. если ты исправляешь, то у тебя увеличивается опыт и функциональность созданного твоего детища

А как можно исправить, если ты даже не написал что не правильно, а просто наламал и сказал что оно никому не надо?

Большая просьба. Если обсуждаешь функцию компонент или процедуру или еще что-то, не пеши типа это фуфло, лучше напиши это фуфло, лучше сделать так.....! bigsmile;

[Udman]

Нашел такую статью

Работа с USB на DELPHI

procedure TMain.WMDeviceChange(var message: TMessage);
var
s : string;
begin
{Do Something here}
case message.wParam of
DBT_DEVICEARRIVAL :
showessage('ok');
DBT_DEVICEQUERYREMOVE:
begin
s := 'Permission to remove a device is requested';
ShowMessage(s);
{True grants premission}
message.Result := integer(true);
exit;
end;
DBT_DEVICEQUERYREMOVEFAILED :
s := 'Request to remove a device has been canceled';
DBT_DEVICEREMOVEPENDING :
s := 'Device is about to be removed';
DBT_DEVICEREMOVECOMPLETE :
showmessage('del');

DBT_DEVICETYPESPECIFIC :
s := 'Device-specific event';
DBT_CONFIGCHANGED :
s:= 'Current configuration has changed'
else
s := 'Unknown Device Message';
end;
if s <> '' then ShowMessage(s);
inherited;
end;

Один исходник и все. ЧТо он делает не понял, помоему обрабатывает что-то при подкл. ЮСБ!

[grafmoto]

off_topic; вы тут чего в каждом посте собираетесь исходные тексты выкладывать? хоть бы архивом...

[n0wheremany]

...
Один исходник и все. ЧТо он делает не понял, помоему обрабатывает что-то при подкл. ЮСБ!

Программа ловит сообщение винды.
Не указано в коде:
1. Регистрация сообщения от том что программа будет принимать сообщение.
2. Не указаны строки констант.

По идее Код не должен работать, т.к. много не работает.

Вот компонент, который когдато я делал. Возможны небольшие синт ошибки, т.к. это всеволишь часть компонента.

Код

unit DetectUSB;

interface

uses
 Windows, Messages, SysUtils, Classes, Forms;

type
 PDevBroadcastHdr  = ^DEV_BROADCAST_HDR;
 DEV_BROADCAST_HDR = packed record
   dbch_size: DWORD;
   dbch_devicetype: DWORD;
   dbch_reserved: DWORD;
 end;

 PDevBroadcastDeviceInterface  = ^DEV_BROADCAST_DEVICEINTERFACE;
 DEV_BROADCAST_DEVICEINTERFACE = record
   dbcc_size: DWORD;
   dbcc_devicetype: DWORD;
   dbcc_reserved: DWORD;
   dbcc_classguid: TGUID;
   dbcc_name: short;
 end;

const
 GUID_DEVINTERFACE_USB_DEVICE: TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
 DBT_DEVICEARRIVAL          = $8000;          // system detected a new device
 DBT_DEVICEREMOVECOMPLETE   = $8004;          // device is gone
 DBT_DEVTYP_DEVICEINTERFACE = $00000005;      // device interface class

 TDetectUSB = class(TComponent)
 private
   FWindowHandle: HWND;
   FOnUSBArrival: TNotifyEvent;
   FOnUSBRemove: TNotifyEvent;
   procedure WndProc(var Msg: TMessage);
   function USBRegister: Boolean;
 protected
   procedure WMDeviceChange(var Msg: TMessage); dynamic;
 public
   constructor Create(AOwner: TComponent); override;
   destructor Destroy; override;
 published
   property OnUSBArrival: TNotifyEvent read FOnUSBArrival write FOnUSBArrival;
   property OnUSBRemove: TNotifyEvent read FOnUSBRemove write FOnUSBRemove;
 end;

procedure Register;

implementation

procedure Register;
begin
 RegisterComponents('n0where USB', [TDetectUSB]);
end;

constructor TDetectUSB.Create(AOwner: TComponent);
begin
 inherited Create(AOwner);
 FWindowHandle := AllocateHWnd(WndProc);
 USBRegister;
end;

destructor TDetectUSB.Destroy;
begin
 DeallocateHWnd(FWindowHandle);
 inherited Destroy;
end;

procedure TDetectUSB.WndProc(var Msg: TMessage);
begin
 if (Msg.Msg = WM_DEVICECHANGE) then  
 begin
   try
     WMDeviceChange(Msg);
   except
     Application.HandleException(Self);
   end;
 end
 else
   Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
end;

procedure TDetectUSB.WMDeviceChange(var Msg: TMessage);
var
 devType: Integer;
 Datos: PDevBroadcastHdr;
begin
 if (Msg.wParam = DBT_DEVICEARRIVAL) or (Msg.wParam = DBT_DEVICEREMOVECOMPLETE) then
 begin
   Datos := PDevBroadcastHdr(Msg.lParam);
   devType := Datos^.dbch_devicetype;
   if devType = DBT_DEVTYP_DEVICEINTERFACE then  
   begin // USB Device
     if Msg.wParam = DBT_DEVICEARRIVAL then  
     begin
       if Assigned(FOnUSBArrival) then
         FOnUSBArrival(Self);
     end  
     else  
     begin
       if Assigned(FOnUSBRemove) then
         FOnUSBRemove(Self);
     end;
   end;
 end;
end;

function TDetectUSB.USBRegister: Boolean;
var
 dbi: DEV_BROADCAST_DEVICEINTERFACE;
 Size: Integer;
 r: Pointer;
begin
 Result := False;
 Size := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
 ZeroMemory(@dbi, Size);
 dbi.dbcc_size := Size;
 dbi.dbcc_devicetype := DBT_DEVTYP_DEVICEINTERFACE;
 dbi.dbcc_reserved := 0;
 dbi.dbcc_classguid  := GUID_DEVINTERFACE_USB_DEVICE;
 dbi.dbcc_name := 0;

 r := RegisterDeviceNotification(FWindowHandle, @dbi,
   DEVICE_NOTIFY_WINDOW_HANDLE
   );
 if Assigned(r) then Result := True;
end;

end.

[n0wheremany]

Кстати важен не размер палагина, а его влияние на РАЗМЕР ПРОГРАММЫ И ЕЁ ПАМЯТИ.

Если ты используешь Registry модуль или подобный. Прошу переделать всё вручную, т.к. размер программы увеличивается.

ЗЫ пиши если нужен код.

[Udman]

n0wheremany, Ты имеешь ввиду без использования Registry работать в реестре?

[azt59]

Кто нить может выложить процедурку для конвертирования SHX файла в smg(bin) на делфях

[n0wheremany]

n0wheremany, Ты имеешь ввиду без использования Registry работать в реестре?

Да. С использованием функции WinApi. Я обычно там и пишу.

[Udman]

azt59 J,Обратись к Random
n0wheremany Подкинь функции. Очень интересно!

[n0wheremany]

n0wheremany Подкинь функции. Очень интересно!

Лови, но само сабой не все. Если надо какие пиши

Код

//////////////////////////////////////////////////////
// Registry
//////////////////////////////////////////////////////

function RegKeyOpenRead( Key: HKey; const SubKey: String ): HKey;
begin
 if RegOpenKeyEx( Key, PChar( SubKey ), 0, KEY_READ, Result ) <> ERROR_SUCCESS then
    Result := 0;
end;

function RegKeyGetStr( Key: HKey; const ValueName: String ): String;
var dwType, dwSize: DWORD;
   Buffer, Buffer2: PChar;
   Sz: Integer;
   function Query: Boolean;
   begin
     Result := RegQueryValueEx( Key, PChar( ValueName ), nil, @dwType,
               Pointer( Buffer ), @dwSize ) = ERROR_SUCCESS;
   end;
begin
 Result := '';
 if Key = 0 then Exit;
 dwSize := 0;
 Buffer := nil;
 if not Query or ((dwType <> REG_SZ) and (dwtype <> REG_EXPAND_SZ)) then Exit;
 GetMem( Buffer, dwSize );
 if Query then
 begin
   if dwtype = REG_EXPAND_SZ then
   begin
     Sz := ExpandEnvironmentStrings(Buffer,nil,0);
     GetMem(Buffer2,Sz);                            
     ExpandEnvironmentStrings(Buffer, Buffer2, Sz);
     Result:=Buffer2;                              
     FreeMem(Buffer2);                              
   end
     else
   Result := Buffer;
 end;
 FreeMem( Buffer );
end;

procedure RegKeyClose( Key: HKey );
begin
 if Key <> 0 then
   RegCloseKey( Key );
end;

function RegKeyExists( Key: HKey; const SubKey: String ): Boolean;
var K: Integer;
begin
 if Key = 0 then
 begin
   Result := FALSE;
   Exit;
 end;
 K := RegKeyOpenRead( Key, SubKey );
 Result := K <> 0;
 if K <> 0 then
   RegKeyClose( K );
end;

function RegKeyValExists( Key: HKey; const ValueName: String ): Boolean;
var dwType, dwSize: DWORD;
begin
 Result := (Key <> 0) and
           (RegQueryValueEx( Key, PChar( ValueName ), nil,
           @dwType, nil, @dwSize ) = ERROR_SUCCESS);
end;

//////////////////////////////////////////////////////
// End Registry
//////////////////////////////////////////////////////

[0vZ]

MS_Tos, все Дэльфисты :)
Умные Дэльфисты, помогите глупому, где ошибка в коде?
Проблема в чем: эта процедурка проводит рекурсивный поиск в указанной папке файлов с расширениями .m4a и .mp3. И работает вроде как верно! Я её использую в motoTunes. Но вот проблема, при попытке дать ей в качестве папки корень какого-нибудь диска (прим: 'D:\'), на котором есть папки (даю конкретный пример, т.к. закономерность не выявил):
\iTunes
--Music
\mobile
--audio

Так вот, если в папке \iTunes\Music лежат файлы, то процедурка не показывает файлы, которые находятся в mobile\audio, а показывает только файлы из iTunes\Music. Аттрибуты папки (и файлов в iTunes\music - "скрытый")

Код

procedure RecurseDirMUSIC(const ADir: string; var AFileList: TStringList);
var
 SR: TSearchRec;
 FileAttrs: Integer;
 E: string;
begin
 FileAttrs := faAnyFile;// or faDirectory or faReadOnly or faHidden or faArchive or faVolumeID or faSysFile;
 if FindFirst(IncludeTrailingBackslash(ADir){ + PathDelim }+ AllFilePattern, FileAttrs, SR) = 0 then
   while FindNext(SR) = 0 do
   begin
     if (SR.Attr and faDirectory) <> 0 then
     begin
       if (SR.Name <> '.') and (SR.Name <> '..') then
         RecurseDirMUSIC(IncludeTrailingBackslash(ADir){ + PathDelim }+ SR.Name, AFileList);
     end
     else
     begin
       E := LowerCase(ExtractFileExt(SR.Name));
       if (E = '.mp3') or (E = '.m4a')  then
         AFileList.Add(ADir + PathDelim + SR.Name);
     end;
   end;
 SysUtils.FindClose(SR);
end;

[Udman]

0vZ,
Не понял что именно не правильно. А попробуй такой код для поиска файлов.

procedure TForm1.ScanDir(StartDir: string; Mask:string; List:TStrings);
var SearchRec : TSearchRec;
begin
if Mask = '' then Mask := '*.*';
if StartDir[Length(StartDir)] <> '\' then StartDir := StartDir + '\';
if FindFirst(StartDir+Mask, faAnyFile, SearchRec) = 0 then
begin
repeat
Application.ProcessMessages;
if (SearchRec.Attr and faDirectory) <> faDirectory then
List.Add(StartDir + SearchRec.Name)
else if (SearchRec.Name <> '..') and (SearchRec.Name <> '.') then
begin
List.Add(StartDir+SearchRec.Name+'\');
ScanDir(StartDir+SearchRec.Name+'\',Mask,List);
end;
until FindNext(SearchRec) <> 0;
FindClose(SearchRec);
end;
end;

[n0wheremany]

Не понял что именно не правильно. А попробуй такой код для поиска файлов.

От куда вы берёте такой код?

Если не получается с корнем. попробуй поставить так D:\\

Код

type TFindFile= function (FindFile:TSearchRec):boolean;
type TFindDir= function (FindDir:TSearchRec):boolean;

procedure ScanDir(Dir: string; Mask:string; const FindFile:TFindFile; FindDir:TFindDir=nil);
var SearchRec : TSearchRec;
begin      
if Mask='' then Mask := '*.*';
if Dir[Length(Dir)] <> '\' then Dir:= Dir+ '\';
if FindFirst(Dir+Mask, faAnyFile, SearchRec) = 0 then begin
repeat
 if (SearchRec.Name = '..') or (SearchRec.Name = '.') then continue;
 if (SearchRec.Attr and faDirectory) <> faDirectory then begin
   if assigned(FindFile) then
    if not FindFile(SearchRec) then
     break;
  end else
    if assigned(FindDir) then
     if not FindDir(SearchRec) then
      break;
     ScanDir(Dir+SearchRec.Name,Mask,FindFile,FindDir);
   end;
 until FindNext(SearchRec) <> 0;
 FindClose(SearchRec);
end;
end;

Такой код будет более универсальным и без каких либо погрешностей.

Использовать так

Код

     
var List:TStringList;

function FindFileCB(FindFile:TSearchRec):boolean;
begin  
Result := true;
if List=nil then
 List.Add(FindFile.Name);  
Application.ProcessMessages;
end;

procedure Form1.Button1OnClick(Sender:TObject);
begin
List := TStringList.Create;
try    
 ScanDir(Dir,'*.*', @FindFileCB, nil);
 //... Ещё какие либо операции с List.
finally  
 List.Free;
end;
end;

[Udman]

Может кто знает а? Интересуют АТ комманды. Чтобы набрать номер, если на той стороне сняли трубочку, то положить у меня.

[n0wheremany]

Может кто знает а? Интересуют АТ комманды. Чтобы набрать номер, если на той стороне сняли трубочку, то положить у меня.

Дозвон то просто ATD, положимть тоже ATH.
А вот с мониторингом проблемы:
Посмотри 2 команды:

ATL Monitor Speaker Loudness
ATM Monitor Speaker Mode

Может одна из них тебе поможет...