USB'ye takılan diskin harfi, adı ve seri numarasını nasıl bulurum?

[adeministrator]

Merhaba,

TUSBDetector kullanarak usb disk takıldığında sürücü harfini buluyorum. Burada bulduğum fonksiyonlar yardımıyla da seri numarasını falan bulabiliyorum .

Ancak şöyle bir sorunum var:
TUSBDetector'un OnArrival ve OnRemovel olmak üzere iki olayı var. Takıldığında çalıştırılan OnArrival'dan diskin seri numarasını bulan metodu çağırdığımda şu hatayı alıyorum: "uygulama giriş zaman uyumlu bir çağrı gönderdiği için giden bir çağrı yapılamıyor." (Programda usb takıldığında ve çıkarıldığında yapılması gereken şeyler bulunuyor.)

Aşmam konusunda yardımcı olur musunuz?

[ertank]

Merhaba,

- Hangi Delphi sürümünü kullanıyorsunuz?
- TUSBDetector.OnArival() kodunu paylaşmanız mümkün mü?
- Varsa ingilizce orjinal hatayı paylaşabilir misiniz?

Mümkünse aynı soruyu aynı forumda iki defa sormamaya özen gösterin.

[adeministrator]

Merhaba,

Forumdaki mesajlar onaydan geçtiği için hangisi daha erken geçerse diye eklemek zorunda kaldım.

USBDetector bileşeni kodları:

Kod: Tümünü seç

unit USBDetect;

////////////////////////////////////////////////////
///                                              ///
///  USB Detector component     Ver 2.0.0.0      ///
///                                              ///
///  Written by Mojtaba Tajik ( Silversoft )     ///
///  Released on 10/13/2010                      ///
///  E-Mail : Tajik1991@gmail.com                ///
///                                              ///
////////////////////////////////////////////////////

interface

uses
  Windows, Forms, SysUtils, Classes, Messages, dialogs;

type
  TUSBEvent= Procedure (Sender: TObject; Drive: String) of Object;

type
  TUSBDetector = class(TComponent)
  private
    { Private declarations }
    FWindowHandle: HWND;
    FArrival, FRemoved: TUSBEvent;
    procedure WndProc(var Msg: TMessage);
  protected
    { Protected declarations }
    procedure WMDEVICECHANGE(Var Msg: TMessage); Message WM_DEVICECHANGE;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    Property OnArrival: TUSBEvent read FArrival write FArrival;
    Property OnRemoved: TUSBEvent read FRemoved write FRemoved;
  end;

procedure Register;

// Device constants
const
  DBT_DEVICEARRIVAL          =  $00008000;
  DBT_DEVICEREMOVECOMPLETE   =  $00008004;
  DBT_DEVTYP_VOLUME          =  $00000002;
// Device structs
type
  _DEV_BROADCAST_HDR         =  packed record
     dbch_size:              DWORD;
     dbch_devicetype:        DWORD;
     dbch_reserved:          DWORD;
  end;
  DEV_BROADCAST_HDR          =  _DEV_BROADCAST_HDR;
  TDevBroadcastHeader        =  DEV_BROADCAST_HDR;
  PDevBroadcastHeader        =  ^TDevBroadcastHeader;
type
  _DEV_BROADCAST_VOLUME      =  packed record
     dbch_size:              DWORD;
     dbch_devicetype:        DWORD;
     dbch_reserved:          DWORD;
     dbcv_unitmask:          DWORD;
     dbcv_flags:             WORD;
  end;
  DEV_BROADCAST_VOLUME       =  _DEV_BROADCAST_VOLUME;
  TDevBroadcastVolume        =  DEV_BROADCAST_VOLUME;
  PDevBroadcastVolume        =  ^TDevBroadcastVolume;

implementation

procedure Register;
begin
  RegisterComponents('Mojtaba', [TUSBDetector]);
end;

{ TUSBDetector }

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

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

procedure TUSBDetector.WMDEVICECHANGE(var Msg: TMessage);
var
  lpdbhHeader: PDevBroadcastHeader;
  lpdbvData:   PDevBroadcastVolume;
  dwIndex:     Integer;
  lpszDrive:   String;
begin
  inherited;
  // Get the device notification header
  lpdbhHeader:=PDevBroadcastHeader(Msg.lParam);
  // Handle the message
  case Msg.WParam of
     DBT_DEVICEARRIVAL:    {a USB drive was connected}
     begin
        if (lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then
        begin
           lpdbvData:=PDevBroadcastVolume(Msg.lParam);
           for dwIndex :=0 to 25 do
           begin
              if ((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then
              begin
                 lpszDrive:=lpszDrive+Chr(65+dwIndex)+ ':';
                 Break;
              end;
           end;
           if Assigned(OnArrival) then
            OnArrival(Self, lpszDrive);
        end;
     end;
     DBT_DEVICEREMOVECOMPLETE:    {a USB drive was removed}
     begin
        if (lpdbhHeader^.dbch_devicetype = DBT_DEVTYP_VOLUME) then
        begin
           lpdbvData:=PDevBroadcastVolume(Msg.lParam);
           for dwIndex:=0 to 25 do
           begin
              if ((lpdbvData^.dbcv_unitmask shr dwIndex) = 1) then
              begin
                 lpszDrive:=lpszDrive+Chr(65+dwIndex)+ ':';
                 Break;
              end;
           end;
           if Assigned(OnRemoved) then
            OnRemoved(Self, lpszDrive);
        end;
     end;
  end;
end;

procedure TUSBDetector.WndProc(var Msg: TMessage);
begin
  if (Msg.Msg = WM_DEVICECHANGE) then
  begin
    try
      WMDeviceChange(Msg);
    except
      Application.HandleException(Self);
    end;
  end
end;

end.

Benim bileşeni kullanarak yazdığım kodlar:

Kod: Tümünü seç

unit Unit1;

interface

uses
  System.SysUtils, System.Variants, Vcl.Graphics,
  Vcl.Controls, Vcl.Forms, Vcl.Dialogs, USBDetect, Vcl.StdCtrls, ActiveX, WbemScripting_TLB,
  System.Classes;

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Label2: TLabel;
    USBDetector1: TUSBDetector;
    Button1: TButton;

    procedure USBDetector1Arrival(Sender: TObject; Drive: string);
    procedure Button1Click(Sender: TObject);
    procedure ac(surucu:string);
    procedure GetUSBDiskDriveInfo(surucu:string);
//    procedure GetUSBDiskDriveInfo(surucu:string; out serial:string);

  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;
  //cihaz: variant;
  pnp: string;
implementation

{$R *.dfm}
procedure TForm1.GetUSBDiskDriveInfo(surucu:string);
var
  WMIServices  : ISWbemServices;
  Root,a,b     : ISWbemObjectSet;
  Item,Item2   : Variant;
  i,ii,iii,iiii: Integer;
begin
  WMIServices := CoSWbemLocator.Create.ConnectServer('.', 'root\cimv2','', '', '', '', 0, nil);
  Root := WMIServices.ExecQuery('Select * From Win32_DiskDrive Where InterfaceType="USB"','WQL', 0, nil);
  for i := 0 to Root.Count - 1 do
  begin
    Item := Root.ItemIndex(i);
    for ii := VarArrayLowBound(Item.Capabilities, 1) to VarArrayHighBound(Item.Capabilities, 1) do if (Item.Capabilities[ii] = 7) then begin
(*      Writeln('Caption      '+VarToStr(Item.Caption));
      Writeln('Name         '+VarToStr(Item.Name));
      Writeln('DeviceID     '+VarToStr(Item.DeviceID));
      Writeln('Partitions   '+VarToStr(Item.Partitions));
      Writeln('PNPDeviceID  '+VarToStr(Item.PNPDeviceID));
      Writeln('SerialNumber '+VarToStr(Item.SerialNumber));
      Writeln('Signature    '+VarToStr(Item.Signature));
*)
      a := WMIServices.ExecQuery('ASSOCIATORS OF {Win32_DiskDrive.DeviceID=''' + VarToStr(Item.DeviceID) + '''} WHERE AssocClass = Win32_DiskDriveToDiskPartition','WQL', 0, nil);
      for iiii := 0 to a.Count - 1 do begin
        b := WMIServices.ExecQuery('ASSOCIATORS OF {Win32_DiskPartition.DeviceID=''' + VarToStr(Variant(a.ItemIndex(iiii)).DeviceID) + '''} WHERE AssocClass = Win32_LogicalDiskToPartition','WQL', 0, nil);
        for iii := 0 to b.Count - 1 do begin
          Item2 := b.ItemIndex(iii);
          if (Item2.Caption = surucu) then pnp:=Item.PNPDeviceID;
        end;
      end;
//      Writeln;
//      Writeln;
    end;
  end;
end;
procedure TForm1.ac(surucu:string);
begin
label1.Caption := surucu;
GetUSBDiskDriveInfo(surucu);
label2.Caption := pnp;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
GetUSBDiskDriveInfo(label1.Caption);
label2.Caption := pnp;
end;

procedure TForm1.USBDetector1Arrival(Sender: TObject; Drive: string); //Flash disk takıldığında
begin
label1.Caption := Drive;
GetUSBDiskDriveInfo(Drive);
label2.Caption := pnp;
end;

end.

Hatanın ingilizcesi: An outgoing call can not be made because the application sends a synchronous call
Ama bende Türkçe olarak hata veriyor. Sanırım işletim sistemi kaynaklı da olabilir.

[ertank]

Aşağıdaki uygulama ile sürücü harfi şeklinde sisteme bağlanan usb cihazların seri numarası okumasını yapabilirsiniz. Windows bir sebepten seri numarası bilgilerini oluşturmak için 5 saniye gibi bir bekleme süresine ihtiyaç duyuyor. Seri numarası okumadan önce bu kadar bir süre beklemek gerekiyor.

USB ile ilgili ünite:

Kod: Tümünü seç

unit MahUSB;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Registry,
  Masks;

type
  { Event Types }
  TOnDevVolumeEvent = procedure(const bInserted : boolean;
                                const sDrive : string) of object;
  TOnUsbChangeEvent = procedure(const bInserted : boolean;
                                const ADevType,ADriverName,
                                      AFriendlyName : string) of object;

  { USB Class }
  TUsbClass = class(TObject)
  private
    FHandle : HWND;
    FOnUsbChangeEvent : TOnUsbChangeEvent;
    FOnDevVolumeEvent : TOnDevVolumeEvent;
    procedure GetUsbInfo(const ADeviceString : string;
                         out ADevType,ADriverDesc,
                            AFriendlyName : string);
    function DriverLetter(const aUM:Cardinal) : string;
    procedure WinMethod(var AMessage : TMessage);
    procedure RegisterUsbHandler;
    procedure WMDeviceChange(var AMessage : TMessage);
  public
    constructor Create;
    destructor Destroy; override;
    property OnUsbChange : TOnUsbChangeEvent read FOnUsbChangeEvent
                                           write FOnUsbChangeEvent;
    property OnDevVolume : TOnDevVolumeEvent read FOnDevVolumeEvent
                                          write FOnDevVolumeEvent;
  end;



// -----------------------------------------------------------------------------
implementation

type
  // Win API Definitions
  PDevBroadcastDeviceInterface  = ^DEV_BROADCAST_DEVICEINTERFACE;
  DEV_BROADCAST_DEVICEINTERFACE = record
    dbcc_size : DWORD;
    dbcc_devicetype : DWORD;
    dbcc_reserved : DWORD;
    dbcc_classguid : TGUID;
    dbcc_name : char;
  end;

  PDEV_BROADCAST_VOLUME = ^DEV_BROADCAST_VOLUME;
  DEV_BROADCAST_VOLUME = record
    dbcv_size : DWORD;
    dbcv_devicetype : DWORD;
    dbcv_reserved : DWORD;
    dbcv_unitmask : DWORD;
    dbcv_flags : WORD;
  end;
{
dbcv_flags ->

DBTF_MEDIA   0x0001
Change affects media in drive. If not set, change affects physical device or drive.

DBTF_NET   0x0002
Indicated logical volume is a network volume.
}



const
{
http://msdn.microsoft.com/en-us/library/aa363431%28VS.85%29.aspx

RegisterDeviceNotification


http://msdn.microsoft.com/en-us/library/aa363246%28VS.85%29.aspx

DBT_DEVTYP_DEVICEINTERFACE   0x00000005
Class of devices. This structure is a DEV_BROADCAST_DEVICEINTERFACE structure.

DBT_DEVTYP_HANDLE   0x00000006
File system handle. This structure is a DEV_BROADCAST_HANDLE structure.

DBT_DEVTYP_OEM   0x00000000
OEM- or IHV-defined device type. This structure is a DEV_BROADCAST_OEM structure.

DBT_DEVTYP_PORT   0x00000003
Port device (serial or parallel). This structure is a DEV_BROADCAST_PORT structure.

DBT_DEVTYP_VOLUME   0x00000002
Logical volume. This structure is a DEV_BROADCAST_VOLUME structure.
}
  // Miscellaneous
  GUID_DEVINTF_USB_DEVICE : TGUID = '{A5DCBF10-6530-11D2-901F-00C04FB951ED}';
  USB_VOLUME                   = $00000002; // Device interface class
  USB_INTERFACE                = $00000005; // Device interface class
  USB_INSERTION                = $8000;     // System detected a new device
  USB_REMOVAL                  = $8004;     // Device is gone
  DBTF_MEDIA =  $0001;
  DBTF_NET   =  $0002;

  // Registry Keys
  USBKEY  = 'SYSTEM\CurrentControlSet\Enum\USB\%s\%s';
  USBSTORKEY = 'SYSTEM\CurrentControlSet\Enum\USBSTOR';
  SUBKEY1  = USBSTORKEY + '\%s';
  SUBKEY2  = SUBKEY1 + '\%s';


constructor TUsbClass.Create;
begin
  inherited Create;
  FHandle := AllocateHWnd(WinMethod);
  RegisterUsbHandler;
end;


destructor TUsbClass.Destroy;
begin
  DeallocateHWnd(FHandle);
  inherited Destroy;
end;


procedure TUsbClass.GetUsbInfo(const ADeviceString : string;
                               out ADevType,ADriverDesc,
                                   AFriendlyName : string);
var sWork,sKey1,sKey2 : string;
    oKeys,oSubKeys : TStringList;
    oReg : TRegistry;
    i,ii : integer;
    bFound : boolean;
begin
  ADevType := '';
  ADriverDesc := '';
  AFriendlyName := '';

  if ADeviceString <> '' then begin
    bFound := false;
    oReg := TRegistry.Create;
    oReg.RootKey := HKEY_LOCAL_MACHINE;

    // Extract the portions of the string we need for registry. eg.
    // \\?\USB#Vid_4146&Pid_d2b5#0005050400044#{a5dcbf10- ..... -54334fb951ed}
    // We need sKey1='Vid_4146&Pid_d2b5' and sKey2='0005050400044'
    sWork := copy(ADeviceString,pos('#',ADeviceString) + 1,1026);
    sKey1 := copy(sWork,1,pos('#',sWork) - 1);
    sWork := copy(sWork,pos('#',sWork) + 1,1026);
    sKey2 := copy(sWork,1,pos('#',sWork) - 1);

    // Get the Device type description from \USB key
    if oReg.OpenKeyReadOnly(Format(USBKEY,[skey1,sKey2])) then begin
      ADevType := oReg.ReadString('DeviceDesc');
      oReg.CloseKey;
      oKeys := TStringList.Create;
      oSubKeys := TStringList.Create;

      // Get list of keys in \USBSTOR and enumerate each key
      // for a key that matches our sKey2='0005050400044'
      // NOTE : The entry we are looking for normally has '&0'
      // appended to it eg. '0005050400044&0'
      if oReg.OpenKeyReadOnly(USBSTORKEY) then begin
        oReg.GetKeyNames(oKeys);
        oReg.CloseKey;

        // Iterate through list to find our sKey2
        for i := 0 to oKeys.Count - 1 do begin
          if oReg.OpenKeyReadOnly(Format(SUBKEY1,[oKeys[i]])) then begin
            oReg.GetKeyNames(oSubKeys);
            oReg.CloseKey;

            for ii := 0 to oSubKeys.Count - 1 do begin
              if MatchesMask(oSubKeys[ii],sKey2 + '*') then begin
                // Got a match?, get the actual desc and friendly name
                if oReg.OpenKeyReadOnly(Format(SUBKEY2,[oKeys[i],
                                        oSubKeys[ii]])) then begin
                  ADriverDesc := oReg.ReadString('DeviceDesc');
                  AFriendlyName := oReg.ReadString('FriendlyName');
                  oReg.CloseKey;
                end;

                bFound := true;
              end;
            end;
          end;

          if bFound then break;
        end;
      end;

      FreeAndNil(oKeys);
      FreeAndNil(oSubKeys);
    end;

    FreeAndNil(oReg);
  end;
end;


procedure TUsbClass.WMDeviceChange(var AMessage : TMessage);
var iDevType : integer;
    sDevString,sDevType,
    sDriverName,sFriendlyName : string;
    pData : PDevBroadcastDeviceInterface;
    pVol : PDEV_BROADCAST_VOLUME;
begin
  if (AMessage.wParam = USB_INSERTION) or
     (AMessage.wParam = USB_REMOVAL) then begin
    pData := PDevBroadcastDeviceInterface(AMessage.LParam);
    iDevType := pData^.dbcc_devicetype;

    if iDevType = USB_VOLUME then
      if Assigned(FOnDevVolumeEvent) then begin
        pVol := PDEV_BROADCAST_VOLUME(AMessage.LParam);
        FOnDevVolumeEvent((AMessage.wParam = USB_INSERTION),
                          DriverLetter(pVol.dbcv_unitmask));
      end
      else
    else
    // Is it a USB Interface Device ?
    if iDevType = USB_INTERFACE then begin
      sDevString := PChar(@pData^.dbcc_name);
      GetUsbInfo(sDevString,sDevType,sDriverName,sFriendlyName);
      // Trigger Events if assigned
      if Assigned(FOnUsbChangeEvent) then
         FOnUsbChangeEvent((AMessage.wParam = USB_INSERTION),
                           sDevType,sDriverName,sFriendlyName);
    end;
  end;
end;



procedure TUsbClass.WinMethod(var AMessage : TMessage);
begin
  if (AMessage.Msg = WM_DEVICECHANGE) then
    WMDeviceChange(AMessage)
  else
    AMessage.Result := DefWindowProc(FHandle,AMessage.Msg,
                                     AMessage.wParam,AMessage.lParam);
end;


procedure TUsbClass.RegisterUsbHandler;
var rDbi : DEV_BROADCAST_DEVICEINTERFACE;
    iSize : integer;
begin
  iSize := SizeOf(DEV_BROADCAST_DEVICEINTERFACE);
  ZeroMemory(@rDbi,iSize);
  rDbi.dbcc_size := iSize;
  rDbi.dbcc_devicetype := USB_INTERFACE;
  rDbi.dbcc_reserved := 0;
  rDbi.dbcc_classguid  := GUID_DEVINTF_USB_DEVICE;
  rDbi.dbcc_name := #0;
  RegisterDeviceNotification(FHandle,@rDbi,DEVICE_NOTIFY_WINDOW_HANDLE);
end;


function TUsbClass.DriverLetter(const aUM: Cardinal): string;
begin
  case aUM of
          1:  result :=  'A:';
          2:  result :=  'B:';
          4:  result :=  'C:';
          8:  result :=  'D:';
         16:  result :=  'E:';
         32:  result :=  'F:';
         64:  result :=  'G:';
        128:  result :=  'H:';
        256:  result :=  'I:';
        512:  result :=  'J:';
       1024:  result :=  'K:';
       2048:  result :=  'L:';
       4096:  result :=  'M:';
       8192:  result :=  'N:';
      16384:  result :=  'O:';
      32768:  result :=  'P:';
      65536:  result :=  'Q:';
     131072:  result :=  'R:';
     262144:  result :=  'S:';
     524288:  result :=  'T:';
    1048576:  result :=  'U:';
    2097152:  result :=  'V:';
    4194304:  result :=  'W:';
    8388608:  result :=  'X:';
   16777216:  result :=  'Y:';
   33554432:  result :=  'Z:';
  end;
end;

end.

Uygulama kodu:

Kod: Tümünü seç

unit Unit1;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  MahUSB,  // usb ile ilgili unite
  Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    USB: TUsbClass;
    procedure VolumeEvent(const bInserted : boolean; const sDrive : string);
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  ActiveX,            // IEnumvariant
  System.Win.ComObj;  // CreateOleObject()
//  System.Variants,    // VarIsNull()

procedure TForm1.FormCreate(Sender: TObject);
begin
  USB := TUsbClass.Create();
//  USB.OnUsbChange:= Self.ChangeEvent;
  USB.OnDevVolume:= Self.VolumeEvent;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if Assigned(USB) then USB.Free();
end;


// Sürücü harfinden fiziki disk numarası bulunuyor
function GetPhysicalDiskNumber(Drive: Char): Byte;

  function GetLD(Drive: Char): Cardinal;
  var
    Buffer : string;
  begin
    Buffer := Format('\\.\%s:',[Drive]);
//    Result := CreateFile(PChar(Buffer), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
    Result := CreateFile(PChar(Buffer), FILE_SHARE_READ or FILE_SHARE_WRITE, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
    If Result = INVALID_HANDLE_VALUE then
    begin
      Result := CreateFile(PChar(Buffer), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, 0, 0);
    end;
  end;

type
  PDiskInfo = ^TDiskInfo;
  TDiskInfo = record
    BootStatus,
    StartHead    : Byte;
    StartSecClu  : Array[0..1]  Of Byte;
    ParitionType,
    LastHead     : Byte;
    LastSecClu   : Array[0..1]  Of Byte;
    ABSSector,
    TTLSector    : Integer;
    Reserved     : Array[0..47] Of Byte;
    Signature    : Array[0..1]  Of Byte;
  end;
  TDiskExtent = record
    DiskNumber: Cardinal;
    StartingOffset: Int64;
    ExtentLength: Int64;
  end;
  DISK_EXTENT = TDiskExtent;
  PDiskExtent = ^TDiskExtent;
  TVolumeDiskExtents = record
    NumberOfDiskExtents: Cardinal;
    Extents: array[0..0] of TDiskExtent;
  end;
  VOLUME_DISK_EXTENTS = TVolumeDiskExtents;
  PVolumeDiskExtents = ^TVolumeDiskExtents;

const
  FILE_DEVICE_DISK                     = $00000007;
  METHOD_BUFFERED                      = 0;
  FILE_ANY_ACCESS                      = 0;
  IOCTL_DISK_BASE                      = FILE_DEVICE_DISK;
  IOCTL_VOLUME_BASE                    = DWORD('V');
  IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS = ((IOCTL_VOLUME_BASE shl 16) or (FILE_ANY_ACCESS shl 14) or (0 shl 2) or METHOD_BUFFERED);

var
  LD : DWORD;
  DiskExtents : PVolumeDiskExtents;
  DiskExtent : TDiskExtent;
  BytesReturned : Cardinal;
begin
  Result := 0;
  LD := GetLD(Drive);
  If LD = INVALID_HANDLE_VALUE then Exit();
  try
    DiskExtents := AllocMem(Max_Path);
    DeviceIOControl(LD, IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, nil, 0, DiskExtents, Max_Path, BytesReturned, nil);
    if DiskExtents^.NumberOfDiskExtents > 0 then
    begin
      DiskExtent := DiskExtents^.Extents[0];
      Result := DiskExtent.DiskNumber;
    end;
  finally
    CloseHandle(LD);
  end;
end;


function GetHDDPhysicalSerialNumber(const PhysicalDriveIndex: Integer): string;
const
  wbemFlagForwardOnly = $00000020;
var
  SWbemLocator: OLEVariant;
  WMIService: OLEVariant;
  CommandText: string;
  WbemObjectSet: OLEVariant;
  WbemObject: OLEVariant;
  oEnum: IEnumvariant;
  iValue: LongWord;
  Value: Variant;
begin
  Result := '';
  SWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
  WMIService := SWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
  CommandText := Format('SELECT SerialNumber FROM Win32_PhysicalMedia WHERE (Tag = "\\\\.\\PHYSICALDRIVE%d")', [PhysicalDriveIndex]);
  WbemObjectSet := WMIService.ExecQuery(CommandText, 'WQL', wbemFlagForwardOnly);
  oEnum := IUnknown(WbemObjectSet._NewEnum) as IEnumVARIANT;
  if (oEnum.Next(1, WbemObject, iValue) = 0) then
  begin
    Value := WbemObject.Properties_.Item('SerialNumber').Value;
    if (not VarIsNull(Value)) then
      Result := Value;
  end;
  WbemObject := Unassigned;
  WMIService := Unassigned;
  SWbemLocator := Unassigned;
  Result := Trim(Result);
end;

procedure TForm1.VolumeEvent(const bInserted: boolean;
  const sDrive: string);
var
  TempInt: Integer;
  TempStr: string;
begin
  if bInserted then
  begin
    Memo1.Lines.Add('Drive: ' + sDrive);
    Memo1.Update();
    TempInt := GetPhysicalDiskNumber(sDrive[1]);
    Memo1.Lines.Add(TempInt.ToString());
    Memo1.Update();
    // Aşağıdaki satır olmadığı veya süresi 4 saniye olduğu zaman hata oluşuyor.
    // Muhtemelen Windows kendi içinde bazı bilgileri oluşturmak için bu civarda bir süreye ihtiyç duyuyor.
    Sleep(5000);
    TempStr := GetHDDPhysicalSerialNumber(TempInt);
    Memo1.Lines.Add(TempStr);
  end;
end;

end.

Form kodu text olarak:

Kod: Tümünü seç

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 289
  ClientWidth = 554
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Memo1: TMemo
    Left = 0
    Top = 0
    Width = 554
    Height = 289
    Align = alClient
    ScrollBars = ssBoth
    TabOrder = 0
    WordWrap = False
  end
end

NOT: Mesajlara "Dosya ekleri" eklemek mümkün olmuyor. "Mesaj panosu dosya eki kotası aşıldı" şeklinde bir hata mesajı veriyor. Düzeltilmesi gereken bir hata mı? Yoksa belirlenen limitlere mi ulaşıldı bilemiyorum.

[adeministrator]

teşekkürler. cevap gelmeyecek diye ümidi kesmiştim. yine de girip bir bakayım dedim ki cevabınızı gördüm. Stackoverflow'da buna benzer bir yorum okumuştum. sizin dediğiniz gibi deneye deneye 5 saniyeyi buldum. Bendeki kodlara da seri numarasını istemeden önce 5 saniye beklettim ancak nedense sürücü harfini de 5 saniye sonra göstermeye başladı. bir de sizin kodu deneyeyim. Bir de wmi kodları için Type Script Library 'i ekleyince dosya boyutu 11 mb 'a fırlıyor.

[ertank]

Yukarıdaki cevabı verdikten sonra biraz daha araştırma yapınca sorunun USB için dinleme modunda iken (Cihaz bağlandığını algılayan prosedür içinde) WMI talebi yapılamıyor. Ancak farklı bir thread içinde veya USB bağlandığını algılayan prosedür dışında bu sorgulamanın yapılması gerekiyor.

Doğru çalışan proje aşağıda. Bu projede 5 saniye bekleme süresi yok.

Ancak, denediğim bazı USB memory sticklerin seri numarası yoktu. Bunun yerine karışık anlamsız ifadeler geliyor ve her defasında farklı karışık ifadeler geliyor. Eğer seri numarası bilgisi şifreleme için kullanılacak ise, bu bilgiye güvenmek hatalı bir yaklaşım olabilir.

Exe boyutu düşürme ile ilgili aşağıdaki linkleri inceleyebilirsiniz.
Ücretsiz: https://upx.github.io/
Ücretli: https://bitsum.com/pecompact.htm

Ben ikincisini kullanıyorum. UPX'e oranda daha küçük exe dosyalar üretiyor. UPX'e göre işlemi daha hızlı tamamlıyor.

KODLAR:
Yukarıdaki MahUSB unit aynen kullanılıyor.

Unit için kod:

Kod: Tümünü seç

unit Unit1;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  MahUSB,  // usb ile ilgili unite
  Vcl.StdCtrls;

const
  CM_USB_INSERTED = WM_APP + 1;

type
  TForm1 = class(TForm)
    Memo1: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    USB: TUsbClass;

    procedure CMUsbInserted(var Msg: TMessage); message CM_USB_INSERTED;
    procedure VolumeEvent(const bInserted : boolean; const sDrive : string);
  public
    { Public declarations }
  end;


type
  PDISK_EXTENT = ^DISK_EXTENT;
  _DISK_EXTENT = record
    DiskNumber: DWORD;
    StartingOffset: LARGE_INTEGER;
    ExtentLength: LARGE_INTEGER;
  end;
  DISK_EXTENT = _DISK_EXTENT;
  TDiskExtent = DISK_EXTENT;
  PDiskExtent = PDISK_EXTENT;

  PVOLUME_DISK_EXTENTS = ^VOLUME_DISK_EXTENTS;
  _VOLUME_DISK_EXTENTS = record
    NumberOfDiskExtents: DWORD;
    Extents: array [0..0] of DISK_EXTENT;
  end;
  VOLUME_DISK_EXTENTS = _VOLUME_DISK_EXTENTS;
  TVolumeDiskExtents = VOLUME_DISK_EXTENTS;
  PVolumeDiskExtents = PVOLUME_DISK_EXTENTS;


var
  Form1: TForm1;

implementation

{$R *.dfm}

uses
  ActiveX,            // IEnumvariant
  System.Win.ComObj;  // CreateOleObject()

procedure TForm1.FormCreate(Sender: TObject);
begin
  USB := TUsbClass.Create();
  USB.OnDevVolume:= Self.VolumeEvent;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  USB.Free();
end;



function GetVolumeExtent(const DriveLetter: Char; out DiskExtent: TDiskExtent): Boolean;
var
  DiskExtents: PVolumeDiskExtents;
  dwOutBytes: Cardinal;
  hVolume: THandle;
begin
  Result := False;
  hVolume := CreateFile(PChar('\\.\' + DriveLetter + ':'), GENERIC_READ or GENERIC_WRITE, FILE_SHARE_READ or FILE_SHARE_WRITE, nil, OPEN_EXISTING, 0, 0);
  if (hVolume <> INVALID_HANDLE_VALUE) then
  begin
    DiskExtents := AllocMem(MAX_PATH);
    if (DeviceIoControl(hVolume, IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, nil, 0, DiskExtents, MAX_PATH, dwOutBytes, nil)) then
    begin
      if (DiskExtents^.NumberOfDiskExtents > 0) then
      begin
        DiskExtent := DiskExtents^.Extents[0];
        Result := True;
      end;
    end;
    FreeMem(DiskExtents);
    CloseHandle(hVolume);
  end;
end;

function GetHDDPhysicalSerialNumber(const PhysicalDriveIndex: Integer): string;
const
  wbemFlagForwardOnly = $00000020;
var
  SWbemLocator: OLEVariant;
  WMIService: OLEVariant;
  CommandText: string;
  WbemObjectSet: OLEVariant;
  WbemObject: OLEVariant;
  oEnum: IEnumvariant;
  iValue: LongWord;
  Value: Variant;
  I, H: Integer;
  Delimiter: string;
begin
  try
    Result := EmptyStr;
    SWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    WMIService := SWbemLocator.ConnectServer('localhost', 'root\CIMV2', '', '');
    CommandText := Format('SELECT SerialNumber FROM Win32_PhysicalMedia WHERE (Tag = "\\\\.\\PHYSICALDRIVE%d")', [PhysicalDriveIndex]);
    WbemObjectSet := WMIService.ExecQuery(CommandText, 'WQL', wbemFlagForwardOnly);
    oEnum := IUnknown(WbemObjectSet._NewEnum) as IEnumVARIANT;
    if (oEnum.Next(1, WbemObject, iValue) = 0) then
    begin
      Value := WbemObject.Properties_.Item('SerialNumber').Value;
      if (not VarIsNull(Value)) then
      begin
        if (not VarIsArray(Value)) then
        begin
          Result := Trim(string(Value));
        end
        else
        begin
          Delimiter := ';';
          H := VarArrayHighBound(Value, 1);
          for I := VarArrayLowBound(Value, 1) to H do
          begin
            if (I >= H) then
            begin
              Delimiter := '';
            end;
            Result := Result + VarArrayGet(Value, [I]) + Delimiter;
          end;
        end;
      end;
    end;
    WbemObject := Unassigned;
    WMIService := Unassigned;
    SWbemLocator := Unassigned;
    if Result.IsEmpty then
    begin
      Result := '#GEÇERSİZ#';
    end;
  except
    on E: Exception do
    begin
      Result := '#HATA#';
    end;
  end;
end;

procedure TForm1.VolumeEvent(const bInserted: boolean;
  const sDrive: string);
begin
  if bInserted then
  begin
    if not sDrive.IsEmpty() then
    begin
      // PostMessage() asenkron mesaj gönderir. Bu prosedür dışında çalışacaktır kod. Dolayısı ile WMI request sırasında sorun yaşanmayacaktır.
      // SendMessage() ise senkron mesaj gönderir. Aşağıda kullanılması halinde WMI ile ilgili isteklerde hata alınacaktır.
      PostMessage(Self.Handle, CM_USB_INSERTED, 0, Ord(sDrive[1]));  
    end;
  end;
end;

procedure TForm1.CMUsbInserted(var Msg: TMessage);
var
  Drive: Char;
  DiskExtent: TDiskExtent;
  Serial: string;
begin
  Drive := Char(Msg.LParam);
  Memo1.Lines.Add('Drive: ' + Chr(Msg.LParam));
  if (not GetVolumeExtent(Drive, DiskExtent)) then
  begin
    Memo1.Lines.Add('Hata: Volume bilgisi yok.');
  end
  else
  begin
//    Sleep(5000);
    Serial := GetHDDPhysicalSerialNumber(DiskExtent.DiskNumber);
    Memo1.Lines.Add(Serial);
  end;
end;

end.

Form kodu:

Kod: Tümünü seç

object Form1: TForm1
  Left = 0
  Top = 0
  Caption = 'Form1'
  ClientHeight = 289
  ClientWidth = 554
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnCreate = FormCreate
  OnDestroy = FormDestroy
  PixelsPerInch = 96
  TextHeight = 13
  object Memo1: TMemo
    Left = 0
    Top = 0
    Width = 554
    Height = 289
    Align = alClient
    ScrollBars = ssBoth
    TabOrder = 0
    WordWrap = False
  end
end