Bluetooth LE unter Windows 11 funktioniert nicht mehr

[elmar.faber]

Hallo,

bislang hat die Bluetooth LE Komponente unter Windows 10 keine Probleme gemacht. Unter Windows 11
jedoch funktioniert keines meiner Programme mit Bluetooth LE mehr.

Ich habe die Delphi Version 11.1 und die Community Version 11.3 getestet.

Verwenden tue ich ein HM-10 Bluetooth Modul mit der Firmware 5.40 und 7.09.
Wie gesagt unter Windows 10 funktioniert die Kommunikation einwandfrei.

Hier mein Code:

Delphi-Quellcode:

procedure TFrmPeltierController.BluetoothLE1EndDiscoverServices(const Sender: TObject;
  const AServiceList: TBluetoothGattServiceList);
Var
  Idx : Integer;
  cmd_Str : String;
  AService : TBluetoothGattService;
  ACharacteristic : TBluetoothGattCharacteristic;
begin
  FCurrentService := NIL;
  for AService IN AServiceList Do Begin
    DM.Protocol[1].Add(AService.UUIDName);
    If AService.UUIDName = ServiceName Then Begin
      FCurrentService := AService;
      laBluetoothStatus.BeginUpdate;
      laBluetoothStatus.Text := AService.UUIDName;
      laBluetoothStatus.EndUpdate;
      Application.ProcessMessages;
      Break;
    End;
  End;
  If Assigned(FCurrentService) Then Begin
    Try
      for ACharacteristic IN FCurrentService.Characteristics Do Begin                     <------ Hier hängt sich das Programm komplett auf
        DM.Protocol[2].Add(ACharacteristic.UUIDName);
        If ACharacteristic.UUIDName = CharacteristicName Then Begin
          FCurrentCharacteristic := ACharacteristic;
          laBluetoothStatus.BeginUpdate;
          laBluetoothStatus.Text := FCurrentCharacteristic.UUIDName;
          laBluetoothStatus.EndUpdate;
          If BluetoothLE1.SubscribeToCharacteristic(FCurrentDevice, FCurrentCharacteristic) Then Begin
            laBluetoothStatus.BeginUpdate;
            laBluetoothStatus.Text := 'Ready to send/receive data...';
            laBluetoothStatus.EndUpdate;
            Application.ProcessMessages;
            (*
            // <Command> | <Type of Value> | <Assignd Value> | <Value>
            cmd_Str := IntToStr(cct_Response)+'|'+IntToStr(cvt_Boolean)+'|'+
                       IntToStr(Ord(at_Response))+'|'+IntToStr(1)+'^';

            FCurrentCharacteristic.SetValueAsString(cmd_Str);
            BluetoothLE1.WriteCharacteristic(FCurrentDevice, FCurrentCharacteristic);
            *)
            SendCommand(ct_Response, vt_Boolean, at_Response, True);

            btn_Connect.Text := 'Verbunden';
            btn_Connect.Enabled := False;

            Circle1.Fill.Color := TAlphaColors.Chartreuse;
          End;
          Break;
        End;
      End;
    Except

    End;
  End;
End;

Das Demoprogramm "ExploreDevicesLE" hängt sich auch genau an diesem Punkt auf.

Kann mir hier jemand weiterhelfen?

Viele Grüße

Elmar

[rabatscher]

Hi!

Ich hatte auch Probleme beim Unstieg - prinzipiell musste ich sowieso
die Windows BTLE Klasse etwas umschreiben, um es für unsere
Anwendung fit zu machen...

Die Unit ist "System.Win.BluetoothWinRT.pas" und die kann ich hier nicht einfach posten....
Du kannst mir aber deine Mail geben, dann kann ich sie dir schicken - du musst sie dann
nur ins Porjekt einbinden - das sollte genügen.

Und... warum hast du ein ProcessMessages in deinem Code? Es wäre besser diesen los zu werden...

[Sherlock]

Hast Du dazu einen Call Eintrag bei Embarcadero aufgemacht @rabatscher? Immerhin hast Du zu einem erkannten Problem auch eine Lösung parat. Das führt öfter als ohne zu einer Lösung.

Sherlock

[rabatscher]

Nein habe ich nicht - ehrglich gesagt hab ich in das Portal schon lange nicht mehr reingesehen. Wenn jemand nen Bugreport erstellt,
kann ich gern das File dort anfügen...


Aber:
Ich habe "zu viel" geändert denke ich.
In der Win Implemetierung ziemlich einiges umgeschrieben - speziell das Threadhandling, das meiner Meinung nach ziemlich
"unoptimiert" ist... (es wird z.B. in jedem call read/write ein anonymer Thread erzeugt anstatt einem read, write thread der
das handelt)

[rabatscher]

Nur kurz zur Info - es scheint, dass das Enumerieren der Characteristiken in Win11 IN einem Thread sein sollt - nicht im Haupthread...
(Message loop und BTLE stehen sowieso auf "Kriegsfuß". Manche Dinge müssen im Haupthread gemacht werden, manche eben nicht).

Der Fix ist im Endefekt in der Datei System.Win.BluetoothWinRT.pas in den Routinen "DoDiscoverServices" und
"DoGetCharacteristics" und "DoGetIncludedServices" einzubauen (Ich habe auch noch eine Art "Timeout" hinzugefügt...):

Hier mein Code:

Code:

function TWinRTBluetoothLEDevice.DoDiscoverServices: Boolean;
var
  I: Integer;
  LGattService: GenericAttributeProfile_IGattDeviceService;
  dev3 : IBluetoothLEDevice3;
  res3 : IAsyncOperation_1__GenericAttributeProfile_IGattDeviceServicesResult;
  serviceRes : GenericAttributeProfile_IGattDeviceServicesResult;
  LGattServices: IVectorView_1__GenericAttributeProfile_IGattDeviceService;
begin
  Result := True;
  FServices.Clear;
  CheckInitialized;
  if FID = 0 then
  begin
       if not Supports(FBluetoothLEDevice, IBluetoothLEDevice3, dev3) then
          raise EBluetoothDeviceException.CreateRes(@SBluetoothLEDeviceNotPaired);

       if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_IGattDeviceServicesResult>.Wait(
          dev3.GetGattServicesAsync(BluetoothCacheMode.Uncached), res3 ) = AsyncStatus.Completed then
       begin
            serviceRes := res3.GetResults;

            LGattServices := serviceRes.Services;

            if LGattServices.Size > 0 then
            begin
                 for I := 0 to LGattServices.Size - 1 do
                 begin
                      LGattService := LGattServices.GetAt(I);
                      FServices.Add(TWinRTBluetoothGattService.Create(Self, LGattService, TBluetoothServiceType.Primary));
                 end;
            end;
       end;
  end
  else
  begin
  if FBluetoothLEDevice.GattServices.Size > 0 then
    for I := 0 to FBluetoothLEDevice.GattServices.Size - 1 do
    begin
      LGattService := FBluetoothLEDevice.GattServices.GetAt(I);
      FServices.Add(TWinRTBluetoothGattService.Create(Self, LGattService, TBluetoothServiceType.Primary));
    end;
  end;

  // ###########################################
  // #### enumerate the characteristics at once: note on windows 11 it seems
  // that the enumeration of characteristics NEED to be in a thread and
  // we trigger the characteristics fetch
  for i := 0 to fServices.Count - 1 do
  begin
       TWinRTBluetoothGattService(fServices[i]).FTimeout := fOperationTimeout;
       TWinRTBluetoothGattService(fServices[i]).DoGetCharacteristics;
  end;

  DoOnServicesDiscovered(Self, FServices);
end;

tion TWinRTBluetoothGattService.DoGetCharacteristics: TBluetoothGattCharacteristicList;
var I: Integer;
    service3 : GenericAttributeProfile_IGattDeviceService3;
    LGattCharacteristics: IVectorView_1__GenericAttributeProfile_IGattCharacteristic;
    res3 : IAsyncOperation_1__GenericAttributeProfile_IGattCharacteristicsResult;
    status1 : IAsyncOperation_1__GenericAttributeProfile_GattOpenStatus;
    charactersRes : GenericAttributeProfile_IGattCharacteristicsResult;
    characteristic : GenericAttributeProfile_IGattCharacteristic;
begin
  Result := FCharacteristics;
  if fCharacteristicsFetched then
     exit;

  CheckNotClosed;
  FCharacteristics.Clear;

  if Supports(FGattService, GenericAttributeProfile_IGattDeviceService3, service3) then
  begin
       if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_GattOpenStatus>.Wait(
              service3.OpenAsync(GenericAttributeProfile_GattSharingMode.SharedReadAndWrite), status1 ) <> AsyncStatus.Completed
       then
           exit(nil);

       if (status1.GetResults = GenericAttributeProfile_GattOpenStatus.Success) or
          (status1.GetResults = GenericAttributeProfile_GattOpenStatus.AlreadyOpened) then
       begin
            if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_IGattCharacteristicsResult>.Wait(
                   service3.GetCharacteristicsAsync(BluetoothCacheMode.Uncached), res3, FTimeout ) = AsyncStatus.Completed
            then
            begin
                 charactersRes := res3.GetResults;

                 LGattCharacteristics := charactersRes.Characteristics;

                 if LGattCharacteristics.Size > 0 then
                 begin
                      for I := LGattCharacteristics.Size - 1 downto 0 do
                      begin
                           characteristic := LGattCharacteristics.GetAt(I);
                           FCharacteristics.Add(TWinRTBluetoothGattCharacteristic.Create(Self, characteristic));
                      end;
                 end;
            end;
       end
       else
           OutputDebugString(PChar('RequestAccessAysync failed with code ' + Integer(status1.GetResults).tostring));
  end
  else
  begin
       // does not work any more -> need to do sync
       LGattCharacteristics := (FGattService as GenericAttributeProfile_IGattDeviceService2).GetAllCharacteristics;
       if LGattCharacteristics.Size > 0 then
         for I := 0 to LGattCharacteristics.Size - 1 do
           FCharacteristics.Add(TWinRTBluetoothGattCharacteristic.Create(Self, LGattCharacteristics.GetAt(I)));
  end;

  for i := 0 to FCharacteristics.Count - 1 do
  begin
       TWinRTBluetoothGattCharacteristic(fCharacteristics[i]).FTimeout := FTimeout;
       TWinRTBluetoothGattCharacteristic(fCharacteristics[i]).DoGetDescriptors;
  end;

  fCharacteristicsFetched := True;
  Result := FCharacteristics;
end;

function TWinRTBluetoothGattService.DoGetIncludedServices: TBluetoothGattServiceList;
var
  I: Integer;
  LGattServices: IVectorView_1__GenericAttributeProfile_IGattDeviceService;
  service3 : GenericAttributeProfile_IGattDeviceService3;
  res3 : IAsyncOperation_1__GenericAttributeProfile_IGattDeviceServicesResult;
  serviceRes : GenericAttributeProfile_IGattDeviceServicesResult;
  status1 : IAsyncOperation_1__GenericAttributeProfile_GattOpenStatus;
begin
  CheckNotClosed;
  FIncludedServices.Clear;

  if Supports(FGattService, GenericAttributeProfile_IGattDeviceService3, service3) then
  begin
       if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_GattOpenStatus>.Wait(
              service3.OpenAsync(GenericAttributeProfile_GattSharingMode.SharedReadAndWrite), status1 ) <> AsyncStatus.Completed
       then
           exit(nil);

       if (status1.GetResults = GenericAttributeProfile_GattOpenStatus.Success) or
          (status1.GetResults = GenericAttributeProfile_GattOpenStatus.AlreadyOpened) then
       begin
            if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_IGattDeviceServicesResult>.Wait(
                   service3.GetIncludedServicesAsync, res3, FTimeout ) = AsyncStatus.Completed
            then
            begin
                 serviceRes := res3.GetResults;

                 LGattServices := serviceRes.Services;

                 if LGattServices.Size > 0 then
                 begin
                      for I := LGattServices.Size - 1 downto 0 do
                          FIncludedServices.Add(TWinRTBluetoothGattService.Create(FDevice, LGattServices.GetAt(I), TBluetoothServiceType.Primary));
                 end;
            end;
       end
       else
           OutputDebugString(PChar('RequestAccessAysync failed with code ' + Integer(status1.GetResults).tostring));
  end
  else
  begin
       LGattServices := (FGattService as GenericAttributeProfile_IGattDeviceService2).GetAllIncludedServices;
       if LGattServices.Size > 0 then
         for I := 0 to LGattServices.Size - 1 do
           FIncludedServices.Add(TWinRTBluetoothGattService.Create(FDevice, LGattServices.GetAt(I), TBluetoothServiceType.Primary));
  end;

  Result := FIncludedServices;
end;

Bitte mal mit dem Snipplets probieren und für fTimeout = 10000 einsetzen. fCharacteristicsFetched ist auch von mir und sollte im TWinRTBluetoothGattService als private variable deklariert werden.

Falls wer noch interesse hat ich kann das File auch schicken - nur nicht ganz öffentlich machen...

[elmar.faber]

Hallo,

so ich habe mal versucht den Code umzusetzen, aber ich bekomme an der Stelle einen Integerüberlauf...

Delphi-Quellcode:

function TWinRTBluetoothGattCharacteristic.DoGetDescriptors: TBluetoothGattDescriptorList;
var
  LGattDescriptors: IVectorView_1__GenericAttributeProfile_IGattDescriptor;
  I: Integer;
  characteristic3 : GenericAttributeProfile_IGattCharacteristic3;
  descriptorRes3 : IAsyncOperation_1__GenericAttributeProfile_IGattDescriptorsResult;
  descrRes : GenericAttributeProfile_IGattDescriptorsResult;
begin
  FDescriptors.Clear;

  if Supports(FGattCharacteristic, GenericAttributeProfile_IGattCharacteristic3, characteristic3) then
  begin
    if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_IGattDescriptorsResult>.Wait(
                    characteristic3.GetDescriptorsAsync(BluetoothCacheMode.Uncached), descriptorRes3) = AsyncStatus.Completed then
    begin
      descrRes := descriptorRes3.GetResults;
      LGattDescriptors := descrRes.Descriptors;
      for I := 0 to LGattDescriptors.Size - 1 do                                                         <--------------------------------  Hier gibt es einen Integerüberlauf
        FDescriptors.Add(TWinRTBluetoothGattDescriptor.Create(Self, LGattDescriptors.GetAt(I)));
    end;
  end

Ich bin mir allerdings nicht sicher, ob ich es korrekt umgesetzt habe... ich habe die Datei System.Win.BluetoothWinRT.pas in dem Ordner
C:\Program Files (x86)\Embarcadero\Studio\22.0\source\rtl\net ausgetauscht und das Ganze dann unter Delphi als Admin kompiliert und die
Komponente BluetoothLE im Hauptprogramm ausgetauscht...

[rabatscher]

Das Problem scheint hier Emba zu sein, die nicht auf Size = 0 testen - Size ist ein Cardinal und bei eingeschaltenem Range check gibts eine
Exception. Size ist 0 wenn keine solche Descriptors da sind oder was mit dem Pairing nicht passt (selbiges bei den Characteristics,
da hab ich auch schon öfters keine bekommen...)

Meine Implementierung ist hier:

Code:

function TWinRTBluetoothGattCharacteristic.DoGetDescriptors: TBluetoothGattDescriptorList;
var
  LGattDescriptors: IVectorView_1__GenericAttributeProfile_IGattDescriptor;
  I: Integer;
  characteristic3 : GenericAttributeProfile_IGattCharacteristic3;
  descriptorRes3 : IAsyncOperation_1__GenericAttributeProfile_IGattDescriptorsResult;
  descrRes : GenericAttributeProfile_IGattDescriptorsResult;
begin
  FDescriptors.Clear;

  if Supports(FGattCharacteristic, GenericAttributeProfile_IGattCharacteristic3, characteristic3) then
  begin
       // async
       if TAsyncOperation<IAsyncOperation_1__GenericAttributeProfile_IGattDescriptorsResult>.Wait(
                        characteristic3.GetDescriptorsAsync(BluetoothCacheMode.Uncached), descriptorRes3 ) = AsyncStatus.Completed then
       begin
            descrRes := descriptorRes3.GetResults;
            LGattDescriptors := descrRes.Descriptors;
            if LGattDescriptors.Size > 0 then
            begin
                 for I := 0 to LGattDescriptors.Size - 1 do
                     FDescriptors.Add(TWinRTBluetoothGattDescriptor.Create(Self, LGattDescriptors.GetAt(I)));
            end;
       end;
  end
  else
  begin
    // deprecated use only if not yet supported
    LGattDescriptors := (FGattCharacteristic as GenericAttributeProfile_IGattCharacteristic2).GetAllDescriptors;
    if LGattDescriptors.Size > 0 then
      for I := 0 to LGattDescriptors.Size - 1 do
        FDescriptors.Add(TWinRTBluetoothGattDescriptor.Create(Self, LGattDescriptors.GetAt(I)));
  end;
  Result := FDescriptors;
end;

[himitsu]

Size war aber nicht irgendwann mal ein Integer?

So ginge es auch

Delphi-Quellcode:

for I := 0 to Integer(LGattDescriptors.Size) - 1 do

, auch ohne das if > 0 davor.

Ohne Überlaufprüfung würde es beim Cardinal/LongWord dennoch knallen, auch wenn die Überlaufprüfung abgeschaltet wäre, denn das -1 würde ja zu einem $FFFFFFFF (~4 Milliarden).



Dann ist es ja gut, dass Embarcadero seit Kurzem die Bereichs- und Überlaufprüfungen in neuen Projekten standardmäßig aktiviert hat.
Den Scheiß, mit den standardmäßig aktiven DebugDCU, empfinde ich aber dennoch als Nötigung.

[rabatscher]

@Sherlock

gefunden... hab einen eintrag bei emba gemacht:
https://quality.embarcadero.com/browse/RSP-42149

mein File ist dort angehängt.


@himitsu:
soweit ich das gesehen hab war das immer ein LongWord. Allerdings ist es eher ein Fehlerfall, dass keine
Services/Characteristics enumeriert werden. Das geht nur, wenn irgendwas mit dem Pairing ist...

[elmar.faber]

So mittlerweile bleibt das Programm nicht mehr hängen, allerdings findet er auch nicht mehr den Service
"Key Service Characteristic" und somit kann ich nicht kommunizieren :(