33 respuestas en este tema

[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:

delphi

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

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.....:

delphi

procedure TForm1.Timer1Timer(Sender: TObject);
begin 
 
for letra:= 'C' to 'Z' do
    if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE then
    begin
    memo1.Lines.Add(letra);  // este es para saber que letras se usan
    BitBtn1.Enabled:=true;
    BitBtn1.Caption:=Letra+':\'+GetCDLabel(letra+':\');
    end
 	else
	begin
  	BitBtn1.Enabled:=false;
  	BitBtn1.Caption:='   -  INSERTE su USB  -';
  	//ShowMessage('ya no hay USB');
  	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:

delphi

case Msg.LParam and $7FFFFFF of
  .............................
  .............................
  SHCNE_DRIVEADD:
      Memo1.Lines.Add('Disco insertado: ' + String(Path)); 
  SHCNE_DRIVEREMOVED:
      Memo1.Lines.Add('Disco retirado: ' + String(Path)); 
  ............................
end;

[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:

delphi

unit UnidadMenuPrincipal;
 
{$R WinXP.res}
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms,
  Dialogs, StdCtrls, ShlObj, Controls, CheckLst, ExtCtrls, Buttons,
  shellapi, ThemeMgr;
 
type
  TformMenuPrincipal = class(TForm)
    lsListaDispositivos: TCheckListBox;
    Label1: TLabel;
    LWEB: TLabel;
    ThemeManager1: TThemeManager;
    btRetirarUSB: TBitBtn;
    btSalir: TBitBtn;
    procedure FormActivate(Sender: TObject);
    procedure btRetirarUSBClick(Sender: TObject);
    procedure LWEBClick(Sender: TObject);
    procedure btSalirClick(Sender: TObject);
  private
    Procedure estadoConexionDispositivo (var Msg: TMessage); Message $0219;
  public
  end;
 
var
  vRetirarDispositivo : TformMenuPrincipal;
  letraVolumen, volumen : string;
 
implementation
 
{$R *.dfm}
 
Procedure TformMenuPrincipal.estadoConexionDispositivo (var Msg: TMessage);
//Dbt.h
Type
  DEV_BROADCAST_HDR     = ^PDEV_BROADCAST_HDR;
    PDEV_BROADCAST_HDR  = packed record
      dbch_size         : DWORD;
      dbch_devicetype   : DWORD;
      dbch_reserved     : DWORD;
  end;
 
  DEV_BROADCAST_VOLUME    = ^PDEV_BROADCAST_VOLUME;
    PDEV_BROADCAST_VOLUME = packed record
      dbcv_size           : DWORD;
      dbcv_devicetype     : DWORD;
      dbcv_reserved       : DWORD;
      dbcv_unitmask       : DWORD;
      dbcv_flags          : WORD;
  end;
var
  C : Integer;
begin
  //desconexión física
  if Msg.wParam = $8004 then
  begin
    if DEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype = 2 then
    begin
      if DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_flags = 0 then
      begin
        Str(Ln(DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_unitmask) / Ln(2) +
            Ord('A'):2:0, letraVolumen);
        letraVolumen := Char(StrToInt(letraVolumen));
        for c := 0 to lsListaDispositivos.Count - 1 do
        begin
          //quitar dispositivo de la lista
          volumen := lsListaDispositivos.Items.Strings[c];
          if volumen[1] = letraVolumen then
          begin
            lsListaDispositivos.Items.Delete(c);
            Break;
          end;
        end;
      end;
    end;
  end;
 
  //conexión física
  if Msg.wParam = $8000 then
  begin
    if DEV_BROADCAST_HDR(Msg.LParam)^.dbch_devicetype = 2 then
    begin
      if DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_flags = 0 then
      begin
        //añadir nuevo volumen a la lista
        Str(Ln(DEV_BROADCAST_VOLUME(Msg.LParam)^.dbcv_unitmask) / Ln(2) +
            Ord('A'):2:0, letraVolumen);
        letraVolumen := Char(StrToInt(letraVolumen));
        lsListaDispositivos.Items.Add(letraVolumen + ':\ -> Conectado');
      end;
    end;
  end;
end;
 
function extraerDispositivoUSB (letraDispositivo : String;
    intervaloTiempo : Integer = 0; numeroIntentos : Integer = 1) : Boolean;
const
  //parámetros de WinIoCtl.h
  FSCTL_LOCK_VOLUME           = ($00000009 shl 16) or ($0000 shl 14) or (00006 shl 2) or 0;
  FSCTL_DISMOUNT_VOLUME       = ($00000009 shl 16) or ($0000 shl 14) or (00008 shl 2) or 0;
  IOCTL_STORAGE_MEDIA_REMOVAL = ($0000002d shl 16) or ($0001 shl 14) or ($0201 shl 2) or 0;
  IOCTL_STORAGE_EJECT_MEDIA   = ($0000002d shl 16) or ($0001 shl 14) or ($0202 shl 2) or 0;
  FSCTL_UNLOCK_VOLUME         = ($00000009 shl 16) or ($0000 shl 14) or (00007 shl 2) or 0;
Type
  TPREVENT_MEDIA_REMOVAL  = record
  PreventMediaRemoval : ByteBool;
end;
var
  HandleVolume : THandle;
  formatoLetraDispositivo : string;
  lpBytesReturned : DWORD;
  PreventRemoval : TPREVENT_MEDIA_REMOVAL;
  T : Integer;
begin
  letraDispositivo := Uppercase(letraDispositivo);
  formatoLetraDispositivo := Format('%s:', [letraDispositivo]);
  Result := False;
  case GetDriveType(PChar(formatoLetraDispositivo)) of
    DRIVE_REMOVABLE:
    begin
      //configurar el formato deseado
      formatoLetraDispositivo := Format('\\.\%s:', [letraDispositivo]);
      PreventRemoval.PreventMediaRemoval := False;
      //creación del volumen
      HandleVolume := CreateFile(PChar(formatoLetraDispositivo),
          GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE,
          nil, OPEN_EXISTING, 0, 0);
      //cierre del volumen
      for T := 0 to numeroIntentos do
      begin
        if DeviceIoControl(HandleVolume, FSCTL_LOCK_VOLUME,
            nil, 0, nil, 0, lpBytesReturned, nil) then
        begin
          //desmontar volumen
          DeviceIoControl(HandleVolume, FSCTL_DISMOUNT_VOLUME,
              nil, 0, nil, 0, lpBytesReturned, nil);
          //control del volumen
          DeviceIoControl(HandleVolume, IOCTL_STORAGE_MEDIA_REMOVAL,
              @PreventRemoval, SizeOf(TPREVENT_MEDIA_REMOVAL),
              nil, 0, lpBytesReturned, nil);
          //retirar volumen
          DeviceIoControl(HandleVolume, IOCTL_STORAGE_EJECT_MEDIA, nil,
              0, nil, 0, lpBytesReturned, nil);
          //liberar el volumen
          Result := DeviceIoControl(HandleVolume, FSCTL_UNLOCK_VOLUME, nil,
              0, nil, 0, lpBytesReturned, nil);
          formatoLetraDispositivo := Format('%s:\',[letraDispositivo]);
          //enviar al sistema aviso de que desmonte el dispositivo
          ShChangeNotify(SHCNE_MEDIAREMOVED, SHCNF_PATH,
              PChar(formatoLetraDispositivo), Nil);
          Break;
        end
        else
        begin
          Result := False;
          Sleep(intervaloTiempo);
        end;
      end;
      //liberar volumen
      CloseHandle(HandleVolume);
    end
    else
      Result := False;
  end;
end;
 
Procedure listaDispositivos (dispositivos : TStrings; tipos : Integer);
var
  i   : integer;
  bits  : set of 0..25;
  disco : String;
begin
  //obtener nombre de los discos lógicos
  integer(bits):= GetLogicalDrives;
 
  //obtener letras si el dispositivo es removible DRIVE_REMOVABLE
  for i := 0 to 25 do
  begin
    if i in bits then
    begin
      disco := Char(i + Ord('A')) + ':';
      if tipos = GetDriveType(PChar(disco)) then
        dispositivos.Append(Char(i + Ord('A')) + ':\ -> Conectado');
    end;
  end;
end;
 
procedure TformMenuPrincipal.FormActivate(Sender: TObject);
begin
  lsListaDispositivos.Clear;
  listaDispositivos(lsListaDispositivos.Items, DRIVE_REMOVABLE);
end;
 
procedure TformMenuPrincipal.btRetirarUSBClick(Sender: TObject);
var
  i : Integer;
begin
  volumen := '';
  for i := 0 to lsListaDispositivos.Count - 1 do
  begin
    if lsListaDispositivos.Checked[i] then
    begin
      volumen := lsListaDispositivos.Items.Strings[i];
      //retirar volúmenes seleccionados, con tres intentos
      //con un intervalo de de 2000 ms cada uno
      if extraerDispositivoUSB (volumen[1], 2000, 3) then
      begin
        MessageDlg('El dispositivo ' + volumen[1] +
            ' ya se puede retirar con seguridad.', mtInformation, [mbOk], 0);
        lsListaDispositivos.Items.Strings[i] := volumen[1] +
            ':\ -> esperando ser extraído físicamente '
      end
      else
        MessageDlg('El dispositivo ' + volumen[1] + ' no puede ser retirado.' +
                    chr(13) + chr(13) + 'Posible causa:' + chr(13) +
                   '- El dispositivo ' + volumen[1] + ' está siendo utilizado.' +
                    chr(13) +
                   '- El dispositivo ' + volumen[1] + ' ya no existe.' + chr(13) +
                   '- El dispositivo ' + volumen[1] + ' tiene algún problema.',
                   mtWarning, [mbOk], 0);
    end;
  end;
end;
 
procedure TformMenuPrincipal.LWEBClick(Sender: TObject);
begin
  ShellExecute(Handle, Nil, PChar('[url=http://www.ajpdsoft.com]http://www.ajpdsoft.com[/url]'),
      Nil, Nil, SW_SHOWNORMAL);
end;
 
procedure TformMenuPrincipal.btSalirClick(Sender: TObject);
begin
  close;
end;
 
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....

Archivos adjuntos

•  3359_1199e5b5a02bc944cc9d99926be1f6ef86246d20.zip   352,71KB   6 descargas

[monchito_elroro]

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

delphi

unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Forms,
  Dialogs, StdCtrls, ShlObj, Controls, CheckLst, ExtCtrls, Buttons,
  shellapi;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    ListBox1: TListBox;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
  private
    { private declarations }
    Lista: set of Char;
    procedure CrearLista;
    procedure WMDEVICECHANGE(var Msg: TMessage); message WM_DEVICECHANGE;
  public
    { public declarations }
  end; 
 
var
  Form1: TForm1; 
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
 
procedure TForm1.CrearLista;
var
  Letra: Char;
begin
  Lista:= [];
  ListBox1.Clear;
  for Letra:= 'C' to 'Z' do
  begin
    if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
    begin
      Lista:= Lista + [Letra];
      ListBox1.Items.Add(Letra + ':\');
    end;
  end;
end;
 
procedure TForm1.WMDEVICECHANGE(var Msg: TMessage);
var
  Letra: Char;
begin
  if Msg.WParam = DBT_DEVICEARRIVAL  then
  begin
    for Letra:= 'C' to 'Z' do
    begin
      if GetDriveType(Pchar(Letra + ':\')) = DRIVE_REMOVABLE  then
      begin
        if not (Letra in Lista) then
        begin
          ShowMessage('Este es un disco removible ' + Letra + ':\');
        end;
      end;
    end;
    CrearLista;
  end;
  if Msg.WParam = DBT_DEVICEREMOVAL then
  begin
    CrearLista;
  end;
  //CrearLista;
  inherited;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  //CrearLista;
end;
 
procedure TForm1.Timer1Timer(Sender: TObject);
begin
  CrearLista;
end;
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.

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

delphi

unit Unit1;
 
 
interface
 
uses
  Windows, Messages, Forms, Classes, Controls, StdCtrls;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
    Lista: set of Char;
    procedure CrearLista;
    procedure WMDEVICECHANGE(var Msg: TMessage); message WM_DEVICECHANGE;
  public
    { public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
{ TForm1 }
const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVAL = $8004;    // El dispositivo sale
 
procedure TForm1.CrearLista;
var
  Letra: Char;
begin
  Lista:= [];
  ListBox1.Clear;
  for Letra:= 'C' to 'Z' do
  begin
    if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
    begin
      Lista:= Lista + [Letra];
      ListBox1.Items.Add(Letra + ':\');
    end;
  end;
end;
 
procedure TForm1.WMDEVICECHANGE(var Msg: TMessage);
var
  Letra: Char;
begin
  if (Msg.WParam = DBT_DEVICEARRIVAL) or (Msg.WParam = DBT_DEVICEREMOVAL) then
    CrearLista;
  inherited;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  CrearLista;
end;
 
end.

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:

delphi

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ì:

delphi

procedure TformMenuPrincipal.FormActivate(Sender: TObject);
begin
  lsListaDispositivos.Clear;
  listaDispositivos(lsListaDispositivos.Items, DRIVE_REMOVABLE);
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 realizarlo 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:

delphi

unit Unit1;
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Windows, Messages, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls;
 
type
 
  { TForm1 }
TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    PrevWndProc: WNDPROC;
    procedure CrearLista;
  public
    { public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVAL = $8004;    // El dispositivo sale
 
function TForm1_WndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
begin
  if uMsg = WM_DEVICECHANGE then
    if(WParam = DBT_DEVICEARRIVAL) or (WParam = DBT_DEVICEREMOVAL) then
      Form1.CrearLista;
  Result:=CallWindowProc(Form1.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  PrevWndProc:= Windows.WNDPROC(SetWindowLong(Self.Handle, GWL_WNDPROC, PtrInt(@TForm1_WndProc)));
  CrearLista;
end;
 
procedure TForm1.CrearLista;
var
    Letra: Char;
begin
  ListBox1.Clear;
  for Letra:= 'C' to 'Z' do
  begin
    if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
    begin
      ListBox1.Items.Add(Letra + ':\');
    end;
  end;
end;
 
end.

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):

delphi

function GetDriveName(Drive: String): String;
var
   Desk: ISHELLFOLDER;
   pidl: PITEMIDLIST;
   StrRet: TSTRRET;
begin
   Result:= '';
   if SUCCEEDED(SHGetDesktopFolder(Desk)) then
   begin
      Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
      Desk.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);    // si estoy bien aca marca el error
      case StrRet.uType of
        STRRET_WSTR:
          Result:= StrRet.pOleStr;
        STRRET_OFFSET:
          Result:= PCHAR(pidl) + StrRet.uOffset;
        STRRET_CSTR:
          Result:= StrRet.cStr;
      end;
      Desk._Release();
   end;
end;

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

delphi

unit1.pas(43,47) Error: Incompatible type for arg no. 2: Got "SHGNO", expected "LongWord"
unit1.pas(44,12) Warning: Local variable "StrRet" does not seem to be initialized
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.

delphi

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

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:

delphi

unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  shlobj, windows;
 
type
 
  { TForm1 }
 
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    Label1: TLabel;
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    { private declarations }
  public
    { public declarations }
  end; 
 
const
  SHGDN_NORMAL = 0;
 
var
  Form1: TForm1; 
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
function GetDriveName(Drive: String): String;
var
   Desk: ISHELLFOLDER;
   pidl: PITEMIDLIST;
   StrRet: TSTRRET;
begin
   Result:= '';
   if SUCCEEDED(SHGetDesktopFolder(Desk)) then
   begin
      Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
      Desk.GetDisplayNameOf(pidl, SHGDN_NORMAL, StrRet);
      //Desk.GetDisplayNameOf(pidl, 0, StrRet);  // También lo use así, pero igual me sale el error
      case StrRet.uType of
        STRRET_WSTR:
          Result:= StrRet.pOleStr;
        STRRET_OFFSET:
          Result:= PCHAR(pidl) + StrRet.uOffset;
        STRRET_CSTR:
          Result:= StrRet.cStr;
      end;
      Desk._Release();
   end;
end;
 
procedure TForm1.FormCreate(Sender: TObject);
begin
 
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  Label1.Caption:= GetDriveName('C:\');
 
end;
 
procedure TForm1.Button2Click(Sender: TObject);
begin
  ShowMessage(GetDriveName('C:\'));
end;
 
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:

delphi

unit Unit1; 
 
{$mode objfpc}{$H+}
 
interface
 
uses
  Windows, Messages, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
  shlobj;
 
type
 
  { TForm1 }
 TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
  private
    PrevWndProc: WNDPROC;
    procedure CrearLista;
  public
    { public declarations }
  end; 
 
var
  Form1: TForm1; 
 
implementation
 
{$R *.lfm}
 
{ TForm1 }
 
function GetDriveName(Drive: String): String;
var
   Desk: ISHELLFOLDER;
   pidl: PITEMIDLIST;
   StrRet: TSTRRET;
begin
   Result:= '';
   if SUCCEEDED(SHGetDesktopFolder(Desk)) then
   begin
      Desk.ParseDisplayName(0, nil, StringToOleStr(Drive), ULONG(nil^), pidl, ULONG(nil^));
      Desk.GetDisplayNameOf(pidl, 0, StrRet);
      case StrRet.uType of
        STRRET_WSTR:
          Result:= StrRet.pOleStr;
        STRRET_OFFSET:
          Result:= PCHAR(pidl) + StrRet.uOffset;
        STRRET_CSTR:
          Result:= StrRet.cStr;
      end;
      //Desk._Release();    // si no lo comento entonces me sale error
   end;
end;
 
const
  DBT_DEVICEARRIVAL = $8000;
  DBT_DEVICEREMOVAL = $8004;     // El dispositivo sale
 
function TForm1_WndProc(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;
begin
  if uMsg = WM_DEVICECHANGE then
    if(WParam = DBT_DEVICEARRIVAL) or (WParam = DBT_DEVICEREMOVAL) then
      Form1.CrearLista;
  Result:=CallWindowProc(Form1.PrevWndProc, Ahwnd, uMsg, WParam, LParam);
end;
 
 
procedure TForm1.FormCreate(Sender: TObject);
begin
  PrevWndProc:= Windows.WNDPROC(SetWindowLong(Self.Handle, GWL_WNDPROC, PtrInt(@TForm1_WndProc)));
  CrearLista;
end;
 
procedure TForm1.CrearLista;
var
    Letra: Char;
begin
  ListBox1.Clear;
  for Letra:= 'C' to 'Z' do
  begin
    if GetDriveType(Pchar(Letra+':\')) = DRIVE_REMOVABLE  then
    begin
      //ListBox1.Items.Add(Letra + ':\');
      ListBox1.Items.Add(GetDriveName(Letra + ':\'));
    end;
  end;
end;
 
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]

delphi

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

Saludos.