Problema al conectar y desconectar memoria USB

[monchito_elroro]

Buenas amigos de delphiaccess, aquí yo de nuevo solicitando su
sabia ayuda en una interrogante, resulta que estoy haciendo que
mi aplicación detecte la inserción de una memoria USB, esto ya lo tengo
hecho con:

Código DELPHI

1. procedure TForm1.Timer1Timer(Sender: TObject);
2. begin
3.  
4. for letra:= 'C' to 'Z' do
5.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE then
6.     begin
7.     memo1.Lines.Add(letra);  // este es para saber que letras se usan
8.     BitBtn1.Enabled:=true;
9.     BitBtn1.Caption:=Letra+':\'+GetCDLabel(letra+':\');
10.     end;
11.  

Si se dan cuenta este bucle FOR lo tengo dentro de un timer para que detecte
de cuando en cuando la inserción de un USB, y a la vez hago que la letra de
la Unidad del USB más su Etiqueta aparezcan como CAPTION en un "BitBtn1"


Ahora el problema es que me gustaría que cuando no haya ningún USB el
"Caption" del "BitBtn1" diga "No hay USB" ......  lo intentado de muchas
maneras pero o bien no pasa nada o sino siempre el "Caption" del "BitBtn1"
dice "No hay USB".....

este es uno de mis intentos.....:

Código DELPHI

1. procedure TForm1.Timer1Timer(Sender: TObject);
2. begin
3.  
4. for letra:= 'C' to 'Z' do
5.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE then
6.     begin
7.     memo1.Lines.Add(letra);  // este es para saber que letras se usan
8.     BitBtn1.Enabled:=true;
9.     BitBtn1.Caption:=Letra+':\'+GetCDLabel(letra+':\');
10.     end
11.     else
12.    begin
13.      BitBtn1.Enabled:=false;
14.      BitBtn1.Caption:='   -  INSERTE su USB  -';
15.      //ShowMessage('ya no hay USB');
16.      end;

Les pido una ayudadita...... Gracias

[escafandra]

Creo que deberías leer este truco que utiliza las notificaciones del shell (SHChangeNotify) para, entre otras muchas cosas, saber cuando se inserta un USB de almacenamiento y cuando se retira. En concreto fíjate en esta parte del código:

Código DELPHI

1. case Msg.LParam and $7FFFFFF of
2.   .............................
3.   .............................
4.   SHCNE_DRIVEADD:
5.       Memo1.Lines.Add('Disco insertado: ' + String(Path));  
6.   SHCNE_DRIVEREMOVED:
7.       Memo1.Lines.Add('Disco retirado: ' + String(Path));  
8.   ............................
9. end;
10.  

[monchito_elroro]

Gracias le darè un vistazo y les cuento........

 

[monchito_elroro]

Bueno he visto los ejemplos que me aconsejaron y los voy a tomar en cuenta, pero
parece que voy a optar por dejar de mostrar los resultados de los USB en un "Bitbutton"

mas bien pienso poner estos resultados como una pequeña lista y que el usuario escoja
pues lo veo más práctico......... para este motivo pienso usar un "TCheckListBox" y
justo he encontrado un ejemplo de ayuda, pero tengo otra incognita.... primero les
paso el código que encontre de ejemplo:

Código DELPHI

1. unit UnidadMenuPrincipal;
2.  
3. {$R WinXP.res}
4.  
5. interface
6.  
7. uses
8.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms,
9.   Dialogs, StdCtrls, ShlObj, Controls, CheckLst, ExtCtrls, Buttons,
10.   shellapi, ThemeMgr;
11.  
12. type
13.   TformMenuPrincipal = class(TForm)
14.     lsListaDispositivos: TCheckListBox;
15.     Label1: TLabel;
16.     LWEB: TLabel;
17.     ThemeManager1: TThemeManager;
18.     btRetirarUSB: TBitBtn;
19.     btSalir: TBitBtn;
20.     procedure FormActivate(Sender: TObject);
21.     procedure btRetirarUSBClick(Sender: TObject);
22.     procedure LWEBClick(Sender: TObject);
23.     procedure btSalirClick(Sender: TObject);
24.   private
25.     Procedure estadoConexionDispositivo (var Msg: TMessage); Message $0219;
26.   public
27.   end;
28.  
29. var
30.   vRetirarDispositivo : TformMenuPrincipal;
31.   letraVolumen, volumen : string;
32.  
33. implementation
34.  
35. {$R *.dfm}
36.  
37. Procedure TformMenuPrincipal.estadoConexionDispositivo (var Msg: TMessage);
38. //Dbt.h
39. Type
40.   DEV_BROADCAST_HDR     = ^PDEV_BROADCAST_HDR;
41.     PDEV_BROADCAST_HDR  = packed record
42.       dbch_size         : DWORD;
43.       dbch_devicetype   : DWORD;
44.       dbch_reserved     : DWORD;
45.   end;
46.  
47.   DEV_BROADCAST_VOLUME    = ^PDEV_BROADCAST_VOLUME;
48.     PDEV_BROADCAST_VOLUME = packed record
49.       dbcv_size           : DWORD;
50.       dbcv_devicetype     : DWORD;
51.       dbcv_reserved       : DWORD;
52.       dbcv_unitmask       : DWORD;
53.       dbcv_flags          : WORD;
54.   end;
55. var
56.   C : Integer;
57. begin
58.   //desconexión física
59.   if Msg.wParam = $8004 then
60.   begin
61.     if DEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype = 2 then
62.     begin
63.       if DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_flags = 0 then
64.       begin
65.         Str(Ln(DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_unitmask) / Ln(2) +
66.             Ord('A'):2:0, letraVolumen);
67.         letraVolumen := Char(StrToInt(letraVolumen));
68.         for c := 0 to lsListaDispositivos.Count - 1 do
69.         begin
70.           //quitar dispositivo de la lista
71.           volumen := lsListaDispositivos.Items.Strings[c];
72.           if volumen[1] = letraVolumen then
73.           begin
74.             lsListaDispositivos.Items.Delete(c);
75.             Break;
76.           end;
77.         end;
78.       end;
79.     end;
80.   end;
81.  
82.   //conexión física
83.   if Msg.wParam = $8000 then
84.   begin
85.     if DEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype = 2 then
86.     begin
87.       if DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_flags = 0 then
88.       begin
89.         //añadir nuevo volumen a la lista
90.         Str(Ln(DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_unitmask) / Ln(2) +
91.             Ord('A'):2:0, letraVolumen);
92.         letraVolumen := Char(StrToInt(letraVolumen));
93.         lsListaDispositivos.Items.Add(letraVolumen + ':\ -> Conectado');
94.       end;
95.     end;
96.   end;
97. end;
98.  
99. function extraerDispositivoUSB (letraDispositivo : String;
100.     intervaloTiempo : Integer = 0; numeroIntentos : Integer = 1) : Boolean;
101. const
102.   //parámetros de WinIoCtl.h
103.   FSCTL_LOCK_VOLUME           = ($00000009 shl 16) or ($0000 shl 14) or (00006 shl 2) or 0;
104.   FSCTL_DISMOUNT_VOLUME       = ($00000009 shl 16) or ($0000 shl 14) or (00008 shl 2) or 0;
105.   IOCTL_STORAGE_MEDIA_REMOVAL = ($0000002d shl 16) or ($0001 shl 14) or ($0201 shl 2) or 0;
106.   IOCTL_STORAGE_EJECT_MEDIA   = ($0000002d shl 16) or ($0001 shl 14) or ($0202 shl 2) or 0;
107.   FSCTL_UNLOCK_VOLUME         = ($00000009 shl 16) or ($0000 shl 14) or (00007 shl 2) or 0;
108. Type
109.   TPREVENT_MEDIA_REMOVAL  = record
110.   PreventMediaRemoval : ByteBool;
111. end;
112. var
113.   HandleVolume : THandle;
114.   formatoLetraDispositivo : string;
115.   lpBytesReturned : DWORD;
116.   PreventRemoval : TPREVENT_MEDIA_REMOVAL;
117.   T : Integer;
118. begin
119.   letraDispositivo := Uppercase(letraDispositivo);
120.   formatoLetraDispositivo := Format('%s:', [letraDispositivo]);
121.   Result := False;
122.   case GetDriveType(PChar(formatoLetraDispositivo)) of
123.     DRIVE_REMOVABLE:
124.     begin
125.       //configurar el formato deseado
126.       formatoLetraDispositivo := Format('\\.\%s:', [letraDispositivo]);
127.       PreventRemoval.PreventMediaRemoval := False;
128.       //creación del volumen
129.       HandleVolume := CreateFile(PChar(formatoLetraDispositivo),
130.           GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,
131.           nil, OPEN_EXISTING, 0, 0);
132.       //cierre del volumen
133.       for T := 0 to numeroIntentos do
134.       begin
135.         if DeviceIoControl(HandleVolume, FSCTL_LOCK_VOLUME,
136.             nil, 0, nil, 0, lpBytesReturned, nil) then
137.         begin
138.           //desmontar volumen
139.           DeviceIoControl(HandleVolume, FSCTL_DISMOUNT_VOLUME,
140.               nil, 0, nil, 0, lpBytesReturned, nil);
141.           //control del volumen
142.           DeviceIoControl(HandleVolume, IOCTL_STORAGE_MEDIA_REMOVAL,
143.               @PreventRemoval, SizeOf(TPREVENT_MEDIA_REMOVAL),
144.               nil, 0, lpBytesReturned, nil);
145.           //retirar volumen
146.           DeviceIoControl(HandleVolume, IOCTL_STORAGE_EJECT_MEDIA, nil,
147.               0, nil, 0, lpBytesReturned, nil);
148.           //liberar el volumen
149.           Result := DeviceIoControl(HandleVolume, FSCTL_UNLOCK_VOLUME, nil,
150.               0, nil, 0, lpBytesReturned, nil);
151.           formatoLetraDispositivo := Format('%s:\',[letraDispositivo]);
152.           //enviar al sistema aviso de que desmonte el dispositivo
153.           ShChangeNotify(SHCNE_MEDIAREMOVED, SHCNF_PATH,
154.               PChar(formatoLetraDispositivo), Nil);
155.           Break;
156.         end
157.         else
158.         begin
159.           Result := False;
160.           Sleep(intervaloTiempo);
161.         end;
162.       end;
163.       //liberar volumen
164.       CloseHandle(HandleVolume);
165.     end
166.     else
167.       Result := False;
168.   end;
169. end;
170.  
171. Procedure listaDispositivos (dispositivos : TStrings; tipos : Integer);
172. var
173.   i   : integer;
174.   bits  : set of 0..25;
175.   disco : String;
176. begin
177.   //obtener nombre de los discos lógicos
178.   integer(bits):= GetLogicalDrives;
179.  
180.   //obtener letras si el dispositivo es removible DRIVE_REMOVABLE
181.   for i := 0 to 25 do
182.   begin
183.     if i in bits then
184.     begin
185.       disco := Char(i + Ord('A')) + ':';
186.       if tipos = GetDriveType(PChar(disco)) then
187.         dispositivos.Append(Char(i + Ord('A')) + ':\ -> Conectado');
188.     end;
189.   end;
190. end;
191.  
192. procedure TformMenuPrincipal.FormActivate(Sender: TObject);
193. begin
194.   lsListaDispositivos.Clear;
195.   listaDispositivos(lsListaDispositivos.Items, DRIVE_REMOVABLE);
196. end;
197.  
198. procedure TformMenuPrincipal.btRetirarUSBClick(Sender: TObject);
199. var
200.   i : Integer;
201. begin
202.   volumen := '';
203.   for i := 0 to lsListaDispositivos.Count - 1 do
204.   begin
205.     if lsListaDispositivos.Checked[i] then
206.     begin
207.       volumen := lsListaDispositivos.Items.Strings[i];
208.       //retirar volúmenes seleccionados, con tres intentos
209.       //con un intervalo de de 2000 ms cada uno
210.       if extraerDispositivoUSB (volumen[1], 2000, 3) then
211.       begin
212.         MessageDlg('El dispositivo ' + volumen[1] +
213.             ' ya se puede retirar con seguridad.', mtInformation, [mbOk], 0);
214.         lsListaDispositivos.Items.Strings[i] := volumen[1] +
215.             ':\ -> esperando ser extraído físicamente '
216.       end
217.       else
218.         MessageDlg('El dispositivo ' + volumen[1] + ' no puede ser retirado.' +
219.                     chr(13) + chr(13) + 'Posible causa:' + chr(13) +
220.                    '- El dispositivo ' + volumen[1] + ' está siendo utilizado.' +
221.                     chr(13) +
222.                    '- El dispositivo ' + volumen[1] + ' ya no existe.' + chr(13) +
223.                    '- El dispositivo ' + volumen[1] + ' tiene algún problema.',
224.                    mtWarning, [mbOk], 0);
225.     end;
226.   end;
227. end;
228.  
229. procedure TformMenuPrincipal.LWEBClick(Sender: TObject);
230. begin
231.   ShellExecute(Handle, Nil, PChar('[url=http://www.ajpdsoft.com]http://www.ajpdsoft.com[/url]'),
232.       Nil, Nil, SW_SHOWNORMAL);
233. end;
234.  
235. procedure TformMenuPrincipal.btSalirClick(Sender: TObject);
236. begin
237.   close;
238. end;
239.  
240. end.

Al parecer el chico que lo creo lo hizo en Borland Delphi 6 .....
ahora, yo lo he tratado de traducir para LAZARUS.... y me sale bien
pero la incognita que tengo es:

Como hago para que los datos del "TCheckListBox" estén actualizados
en su misma línea(tanto cuando inserto y desconecto un USB), pues
tal como veo el creador no uso ni un "Timer" u otro...


Con el permiso del creador les mando su ejemplo....

[monchito_elroro]

Continuando con la interrogante anterior he probado otra manera
con un ejemplo más sencillo, les enseño el código:

Código DELPHI

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms,
9.   Dialogs, StdCtrls, ShlObj, Controls, CheckLst, ExtCtrls, Buttons,
10.   shellapi;
11.  
12. type
13.  
14.   { TForm1 }
15.  
16.   TForm1 = class(TForm)
17.     ListBox1: TListBox;
18.     Timer1: TTimer;
19.     procedure FormCreate(Sender: TObject);
20.     procedure Timer1Timer(Sender: TObject);
21.   private
22.     { private declarations }
23.     Lista: set of Char;
24.     procedure CrearLista;
25.     procedure WMDEVICECHANGE(var Msg: TMessage); message WM_DEVICECHANGE;
26.   public
27.     { public declarations }
28.   end;
29.  
30. var
31.   Form1: TForm1;
32.  
33. implementation
34.  
35. {$R *.lfm}
36.  
37. { TForm1 }
38. const
39.   DBT_DEVICEARRIVAL = $8000;
40.   DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
41.  
42. procedure TForm1.CrearLista;
43. var
44.   Letra: Char;
45. begin
46.   Lista:= [];
47.   ListBox1.Clear;
48.   for Letra:= 'C' to 'Z' do
49.   begin
50.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
51.     begin
52.       Lista:= Lista + [Letra];
53.       ListBox1.Items.Add(Letra + ':\');
54.     end;
55.   end;
56. end;
57.  
58. procedure TForm1.WMDEVICECHANGE(var Msg: TMessage);
59. var
60.   Letra: Char;
61. begin
62.   if Msg.WParam = DBT_DEVICEARRIVAL  then
63.   begin
64.     for Letra:= 'C' to 'Z' do
65.     begin
66.       if GetDriveType(Pchar(Letra + ':\')) = DRIVE_REMOVABLE  then
67.       begin
68.         if not (Letra in Lista) then
69.         begin
70.           ShowMessage('Este es un disco removible ' + Letra + ':\');
71.         end;
72.       end;
73.     end;
74.     CrearLista;
75.   end;
76.   if Msg.WParam = DBT_DEVICEREMOVAL then
77.   begin
78.     CrearLista;
79.   end;
80.   //CrearLista;
81.   inherited;
82. end;
83.  
84. procedure TForm1.FormCreate(Sender: TObject);
85. begin
86.   //CrearLista;
87. end;
88.  
89. procedure TForm1.Timer1Timer(Sender: TObject);
90. begin
91.   CrearLista;
92. end;
93. end.

Pero al igual que el anterior ejemplo tengo la misma incertidumbre...???

Como puedo hacer para que los datos (esta vez de "TListBox") se actualizen
de forma automatica.... ni bien inserto o saco el USB..

PD: fijense que puse un Timer y si me funciona solo que no permite
    elegir los items porque se actualiza a cada rato, pienso que
    debe haber otra forma más limpia.... ayuda plis.   

[escafandra]

Aunque veo este tema mas controlable con las notificaciones del shell (SHChangeNotify) la propuesta de captar los WM_DEVICECHANGE es válida aunque un poco mas engorrosa si queremos un control exhaustivo.

Pera este segundo caso podrías simplificar así el código (delphi):

Código DELPHI

1. unit Unit1;
2.  
3.  
4. interface
5.  
6. uses
7.   Windows, Messages, Forms, Classes, Controls, StdCtrls;
8.  
9. type
10.  
11.   { TForm1 }
12.  
13.   TForm1 = class(TForm)
14.     ListBox1: TListBox;
15.     procedure FormCreate(Sender: TObject);
16.   private
17.     { private declarations }
18.     Lista: set of Char;
19.     procedure CrearLista;
20.     procedure WMDEVICECHANGE(var Msg: TMessage); message WM_DEVICECHANGE;
21.   public
22.     { public declarations }
23.   end;
24.  
25. var
26.   Form1: TForm1;
27.  
28. implementation
29.  
30. {$R *.dfm}
31.  
32. { TForm1 }
33. const
34.   DBT_DEVICEARRIVAL = $8000;
35.   DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
36.  
37. procedure TForm1.CrearLista;
38. var
39.   Letra: Char;
40. begin
41.   Lista:= [];
42.   ListBox1.Clear;
43.   for Letra:= 'C' to 'Z' do
44.   begin
45.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
46.     begin
47.       Lista:= Lista + [Letra];
48.       ListBox1.Items.Add(Letra + ':\');
49.     end;
50.   end;
51. end;
52.  
53. procedure TForm1.WMDEVICECHANGE(var Msg: TMessage);
54. var
55.   Letra: Char;
56. begin
57.   if (Msg.WParam = DBT_DEVICEARRIVAL) or (Msg.WParam = DBT_DEVICEREMOVAL) then
58.     CrearLista;
59.   inherited;
60. end;
61.  
62. procedure TForm1.FormCreate(Sender: TObject);
63. begin
64.    CrearLista;
65. end;
66.  
67. end.
68.  

Esto funciona sin Timer no nada por el estilo.

Si quieres captar el dispositivo que se inserta o extrae puedes usar este código en la respuesta al mensaje analizando el parámetro LParam:

Código DELPHI

1. if PDWORD(Msg.LParam + 4)^ = 2 then Letra:= CHAR(DWORD('C') + PDWORD(Msg.LParam + 16)^);

En cualquier caso piensa que esto sólo va a funcionar en Windows.


Saludos.

[monchito_elroro]

Gracias escafandra por tu ayuda, y disculpa si los incomodo con mis preguntas, lo que pasa es que quiero aprender....y en ese camino me he topado con cada problem....

Otra cosa tambien es que al buscar ejemplo me tope con un codigo que les puse arriba y todo me saliò a la perfecciòn, solo que no lograba hacer que el programita detectarà cuando uno saca y pone su USB....y lo que màs me intriga es que en el ejemplo no hay nada de TIMER que lo justifique entonces me preguntaba "Como lo habìa hecho" .... Tambièn estaba probando con los eventos del FORM principal, concretamente con "OnActive" o algo asì pues el chico lo habìa puesto asì:

Código DELPHI

1. procedure TformMenuPrincipal.FormActivate(Sender: TObject);
2. begin
3.   lsListaDispositivos.Clear;
4.   listaDispositivos(lsListaDispositivos.Items, DRIVE_REMOVABLE);
5. end;

Pero al Probarlo en Lazarus no pasaba nada ...... lo màs curioso es que cuando este mismo còdigo lo ponìa en un TIMER entonces si funcionaba pero no como querìa....

seguire intentando y de ahì les comento.... GRACIAS chicos..

[escafandra]

Al no comprender porqué parece que no te funciona en Lazarus, he realizado un ejemplo. Al real izarlo me he dado cuenta de que Lazarus no es 100% compatible con Win32. Sencillamente Lazarus no recibe el mensaje WM_DEVICECHANGE 

Pero vamos a resolver ese pequeño problema. Lo que vamos a hacer es un Hook a la función de tratamiento de mensajes del formulario en cuestión o Subclassing. Pongo el código completo:

Código DELPHI

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Windows, Messages, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
9.  
10. type
11.  
12.   { TForm1 }
13.  TForm1 = class(TForm)
14.     ListBox1: TListBox;
15.     procedure FormCreate(Sender: TObject);
16.   private
17.     PrevWndProc: WNDPROC;
18.     procedure CrearLista;
19.   public
20.     { public declarations }
21.   end;
22.  
23. var
24.   Form1: TForm1;
25.  
26. implementation
27.  
28. {$R *.lfm}
29.  
30. { TForm1 }
31. const
32.   DBT_DEVICEARRIVAL = $8000;
33.   DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
34.  
35. function TForm1_WndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
36. begin
37.   if uMsg = WM_DEVICECHANGE then
38.     if(WParam = DBT_DEVICEARRIVAL) or (WParam = DBT_DEVICEREMOVAL) then
39.       Form1.CrearLista;
40.   Result:=CallWindowProc(Form1.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
41. end;
42.  
43.  
44. procedure TForm1.FormCreate(Sender: TObject);
45. begin
46.   PrevWndProc:= Windows.WNDPROC(SetWindowLong(Self.Handle, GWL_WNDPROC, PtrInt(@TForm1_WndProc)));
47.   CrearLista;
48. end;
49.  
50. procedure TForm1.CrearLista;
51. var
52.     Letra: Char;
53. begin
54.   ListBox1.Clear;
55.   for Letra:= 'C' to 'Z' do
56.   begin
57.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
58.     begin
59.       ListBox1.Items.Add(Letra + ':\');
60.     end;
61.   end;
62. end;
63.  
64. end.
65.  

Para facilitar mas, subo el proyecto con fuente y binario.


Saludos.

[monchito_elroro]

Amigo escafandra es usted muy amable....... lo probarè y de ahì les cuento....

[monchito_elroro]

Gracias amigo escafandra, me ayudo muchisimo tu código, solo una ultima pregunta, como podrìa hacer para que el label o etiqueta de la unidad tambièn se actualize, pues solo se actualiza la letra de la unidad + :\

Gracias.....

[escafandra]

Gracias amigo escafandra, me ayudo muchisimo tu código, solo una ultima pregunta, como podrìa hacer para que el label o etiqueta de la unidad tambièn se actualize, pues solo se actualiza la letra de la unidad + :\

Gracias.....

En este truco tienes la solución.


Saludos.

[monchito_elroro]

Gracias, le darè un vistazo....

[monchito_elroro]

Gracias amigo escafranda por el dato, pero al probarlo en Lazarus
me salé un pequeño error:

Este es el código que puse (el mismo de la fuente):

Código DELPHI

1. function GetDriveName(Drive: String): String;
2. var
3.    Desk: ISHELLFOLDER;
4.    pidl: PITEMIDLIST;
5.    StrRet: TSTRRET;
6. begin
7.    Result:= '';
8.    if SUCCEEDED(SHGetDesktopFolder(Desk)) then
9.    begin
10.       Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
11.       Desk.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);    // si estoy bien aca marca el error
12.       case StrRet.uType of
13.         STRRET_WSTR:
14.           Result:= StrRet.pOleStr;
15.         STRRET_OFFSET:
16.           Result:= PCHAR(pidl) + StrRet.uOffset;
17.         STRRET_CSTR:
18.           Result:= StrRet.cStr;
19.       end;
20.       Desk._Release();
21.    end;
22. end;

Claro que pongo antes el uses "shlobj".....pero me sale el siguiente error:

Código DELPHI

1. unit1.pas(43,47) Error: Incompatible type for arg no. 2: Got "SHGNO", expected "LongWord"
2. unit1.pas(44,12) Warning: Local variable "StrRet" does not seem to be initialized
3. unit1.pas(66) Fatal: There were 1 errors compiling module, stopping

Agradezco su ayuda....

[escafandra]

Define la constante SHGDN_NORMAL = 0 o simplemente en la línea donde aparece cámbiala por 0.

Código DELPHI

1. Desk.GetDisplayNameOf(pidl, 0{SHGDN_NORMAL}, StrRet);  
2.  

Saludos.

[monchito_elroro]

Gracias amigo lo probarè.....

[monchito_elroro]

Buenas amigo, lo he probado y ya me funciona, pero despues de obtener el resultado
me salta el siguiente error en un cuadradito:

El proyecto project1 ha lanzado una excepción de la
clase 'External: SIGSEGV'.

este es el código que uso:

Código DELPHI

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9.   shlobj, windows;
10.  
11. type
12.  
13.   { TForm1 }
14.  
15.   TForm1 = class(TForm)
16.     Button1: TButton;
17.     Button2: TButton;
18.     Label1: TLabel;
19.     procedure Button1Click(Sender: TObject);
20.     procedure Button2Click(Sender: TObject);
21.     procedure FormCreate(Sender: TObject);
22.   private
23.     { private declarations }
24.   public
25.     { public declarations }
26.   end;
27.  
28. const
29.   SHGDN_NORMAL = 0;
30.  
31. var
32.   Form1: TForm1;
33.  
34. implementation
35.  
36. {$R *.lfm}
37.  
38. { TForm1 }
39. function GetDriveName(Drive: String): String;
40. var
41.    Desk: ISHELLFOLDER;
42.    pidl: PITEMIDLIST;
43.    StrRet: TSTRRET;
44. begin
45.    Result:= '';
46.    if SUCCEEDED(SHGetDesktopFolder(Desk)) then
47.    begin
48.       Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
49.       Desk.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);
50.       //Desk.GetDisplayNameOf(pidl, 0, StrRet);  // También lo use así, pero igual me sale el error
51.       case StrRet.uType of
52.         STRRET_WSTR:
53.           Result:= StrRet.pOleStr;
54.         STRRET_OFFSET:
55.           Result:= PCHAR(pidl) + StrRet.uOffset;
56.         STRRET_CSTR:
57.           Result:= StrRet.cStr;
58.       end;
59.       Desk._Release();
60.    end;
61. end;
62.  
63. procedure TForm1.FormCreate(Sender: TObject);
64. begin
65.  
66. end;
67.  
68. procedure TForm1.Button1Click(Sender: TObject);
69. begin
70.   Label1.Caption:= GetDriveName('C:\');
71.  
72. end;
73.  
74. procedure TForm1.Button2Click(Sender: TObject);
75. begin
76.   ShowMessage(GetDriveName('C:\'));
77. end;
78.  
79. end.

Ya antes me aparecía ese error en otros proyectos, pero esta vez no se que pueda ser
intente ejecutarlo con clic derecho - ejecutar como administrador pero nada

una cosa que me di cuenta es que en winXP todo esta bien, pero uso win7x64 y aquí sale el error
les pido una ayudadita.

PD: ya probé con lazarus versión 32 y 64 bits en win7x64 pero sigue igual.

[escafandra]

El proyecto project1 ha lanzado una excepción de la
clase 'External: SIGSEGV'.

Comenta la línea: Desk._Release();. A ver que pasa.
También debes revisar esto.


Saludos.

[monchito_elroro]

Gracias lo voy a probar....

[monchito_elroro]

Gracias amigo es usted un genio me funcionó comentandolo '//' ..... ahora yo lo
implemento de la siguiente manera:

Código DELPHI

1. unit Unit1;
2.  
3. {$mode objfpc}{$H+}
4.  
5. interface
6.  
7. uses
8.   Windows, Messages, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
9.   shlobj;
10.  
11. type
12.  
13.   { TForm1 }
14.  TForm1 = class(TForm)
15.     ListBox1: TListBox;
16.     procedure FormCreate(Sender: TObject);
17.   private
18.     PrevWndProc: WNDPROC;
19.     procedure CrearLista;
20.   public
21.     { public declarations }
22.   end;
23.  
24. var
25.   Form1: TForm1;
26.  
27. implementation
28.  
29. {$R *.lfm}
30.  
31. { TForm1 }
32.  
33. function GetDriveName(Drive: String): String;
34. var
35.    Desk: ISHELLFOLDER;
36.    pidl: PITEMIDLIST;
37.    StrRet: TSTRRET;
38. begin
39.    Result:= '';
40.    if SUCCEEDED(SHGetDesktopFolder(Desk)) then
41.    begin
42.       Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
43.       Desk.GetDisplayNameOf(pidl, 0, StrRet);
44.       case StrRet.uType of
45.         STRRET_WSTR:
46.           Result:= StrRet.pOleStr;
47.         STRRET_OFFSET:
48.           Result:= PCHAR(pidl) + StrRet.uOffset;
49.         STRRET_CSTR:
50.           Result:= StrRet.cStr;
51.       end;
52.       //Desk._Release();    // si no lo comento entonces me sale error
53.    end;
54. end;
55.  
56. const
57.   DBT_DEVICEARRIVAL = $8000;
58.   DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
59.  
60. function TForm1_WndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
61. begin
62.   if uMsg = WM_DEVICECHANGE then
63.     if(WParam = DBT_DEVICEARRIVAL) or (WParam = DBT_DEVICEREMOVAL) then
64.       Form1.CrearLista;
65.   Result:=CallWindowProc(Form1.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
66. end;
67.  
68.  
69. procedure TForm1.FormCreate(Sender: TObject);
70. begin
71.   PrevWndProc:= Windows.WNDPROC(SetWindowLong(Self.Handle, GWL_WNDPROC, PtrInt(@TForm1_WndProc)));
72.   CrearLista;
73. end;
74.  
75. procedure TForm1.CrearLista;
76. var
77.     Letra: Char;
78. begin
79.   ListBox1.Clear;
80.   for Letra:= 'C' to 'Z' do
81.   begin
82.     if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
83.     begin
84.       //ListBox1.Items.Add(Letra + ':\');
85.       ListBox1.Items.Add(GetDriveName(Letra + ':\'));
86.     end;
87.   end;
88. end;
89.  
90. end.

Funciona todo muy bien..... solo que sigue sin actualizarse el label cuando le cambio de nombre
a la unidad X:\

Habrá alguna manera..... gracias..

[escafandra]

Código DELPHI

1. ListBox1.Items.Add(GetDriveName(Letra + ':\'));  

Saludos.