1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
| '-------------------------------------------------------------------------------
' System Structures
'-------------------------------------------------------------------------------
Private Declare PtrSafe Function WSAStartup Lib "Ws2_32.dll" (ByVal wVersionRequested As Integer, ByRef lpWSAData As WSADATA) As Long
' renvoie la structure lData
' En cas d'erreur WSAStartup renvoie un code d'erreur
Private Declare PtrSafe Function WSALookupServiceBeginA Lib "Ws2_32.dll" (ByRef lpqsRestrictions As WSAQUERYSET, ByVal dwControlFlags, ByVal lphLookup As Long) As Long
Private Declare PtrSafe Function WSALookupServiceNextA Lib "Ws2_32.dll" (ByVal lphLookup As Long, ByVal dwControlFlags, ByVal lBufferLenght, ByRef lpqsResult As WSAQUERYSET) As Long
Private Declare PtrSafe Function WSALookupServiceEnd Lib "Ws2_32.dll" (ByVal lphLookup As Long) As Long
Private Declare PtrSafe Function WSACleanup Lib "Ws2_32.dll" () As Long
Private Const LUP_RETURN_NAME As Integer = 16
Private Const LUP_RETURN_ADDR As Integer = 256
Private Const LUP_CONTAINERS As Integer = 2
Private Const NS_BTH As Long = 16
'Define socket return codes
Private Const INVALID_SOCKET = &HFFFF
Private Const SOCKET_ERROR = -1
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription As String * 256
szSystemStatus As String * 128
iMaxSockets As Integer
iMaxUdpDg As Integer
#If VBA7 Then
lpVendorInfo As LongPtr
#Else
lpVendorInfo As Long
#End If
End Type
' Pour retrouver la version à partir d'un entier long :Pour 514 => version 2.2.
' - m = version mod 256
' - n = version \ 256
Private Type SOCKADDR
sin_family As Integer
sin_port(1 To 2) As Byte ' équivalent de u_short
#If Win64 Then
sin_addr As Long 'structure IN_ADDR
#Else
sin_addr As Long 'structure IN_ADDR
#End If
sin_zero As String * 7
End Type
Private Type SOCKET_ADDRESS
lpSockaddr As SOCKADDR
iSockaddrLength As Integer
End Type
Private Type LPCSADDR_INFO
LocalAddr As SOCKET_ADDRESS
RemoteAddr As SOCKET_ADDRESS
iProtocol As Long
iSocketType As Long
End Type
Private Type LPAFPROTOCOLS
iAddressFamily As Long
iProtocol As Long
End Type
Private Type LPWSAVERSION
dwVersion As Long
ecHow As Long ': TWSAEComparator;
End Type
Private Type WSAQUERYSET
dwSize As Integer
lpszServiceInstanceName As String
lpServiceClassId As String 'As GUID
pVersion As LPWSAVERSION
lpszComment As String
dwNameSpace As Long
lpNSProviderId As String 'GUID
lpszContext As String
dwNumberOfProtocols As Long
lpafpProtocols As LPAFPROTOCOLS
lpszQueryString As String
dwNumberOfCsAddrs As Long
lpcsaBuffer As LPCSADDR_INFO
dwOutputFlags As Long
lpBlob As LongPtr 'Byte
End Type
Private Type SOCKADDR_BTH
AddressFamily As Integer
btAddr As Long
serviceClassId As String 'GUID
port As Long
End Type
Private Type BTH_SET_SERVICE
pSdpVersion As LongPtr
pRecordHandle As Long 'Handle
fCodService As Long
Reserved(5) As Long
ulRecordLength As Long
pRecord(1) As String
End Type
'private Type BTH_QUERY_SERVICE
' type As Long
' serviceHandle As Long
' uuids (MAX_UUIDS_IN_QUERY) 'SdpQueryUuid
' numRange As Long
' pRange (1) 'SdpAttributeRange
'End Type
Private Type BTH_QUERY_DEVICE
LAP As Long
length As Long
End Type
Private Function MakeWord(Lo As Byte, Hi As Byte) As Integer
MakeWord = Lo + Hi * 256& Or 32768 * (Hi > 127)
End Function
Sub Tuto2()
'https://www.winsocketdotnetworkprogramming.com/winsock2programming/winsock2advancedotherprotocol4j.html
Dim lngStatus As Long
' Initialisation de Winsock===================================OK===========================================
'La fonction WSAStartup doit être la première fonction Windows Sockets appelée par une application ou une DLL.
'Elle permet à une application ou à une DLL de spécifier la version des sockets Windows requis et de récupérer les détails de l’implémentation de Windows Sockets spécifique.
Dim lData As WSADATA, hLookup As Long, wVersionRequested As Integer
wVersionRequested = MakeWord(0, 2)
lngStatus = WSAStartup(wVersionRequested, lData) 'ça ca marche
Debug.Print lData.iMaxSockets, lData.iMaxUdpDg, lData.lpVendorInfo, lData.wHighVersion, lData.wVersion
Debug.Print lData.szDescription
Debug.Print lData.szSystemStatus
'retourne 0 si OK
'WSASYSNOTREADY Le sous-système réseau sous-jacent n’est pas prêt pour la communication réseau.
'WSAVERNOTSUPPORTED La version de la prise en charge de Windows Sockets demandée n’est pas fournie par cette implémentation windows sockets particulière.
'WSAEINPROGRESS Une opération windows sockets 1.1 bloquante est en cours.
'WSAEPROCLIM Une limite du nombre de tâches prises en charge par l’implémentation de Windows Sockets a été atteinte.
'WSAEFAULT Le paramètre lpWSAData n’est pas un pointeur valide.
' WSALookupServiceBegin========================ICI ERREUR =====================================
'To start an device inquiry, call the WSALookupServiceBegin() function by passing the WSAQUERYSET variable
'LUP_CONTAINERS is passed in the dwFlags parameter. This enables Service Discovery Protocol (SDP) to search for other Bluetooth devices within range.
'Passing zero (0) in the dwFlags parameter performs a service search.
'The WSALookupServiceBegin() function returns a handle in the hLookup parameter
Dim lQuer As WSAQUERYSET
lQuer.dwNameSpace = NS_BTH
lQuer.dwSize = LenB(lQuer)
lngStatus = WSALookupServiceBeginA(lQuer, LUP_CONTAINERS, hLookup)
'LUP_CONTAINERS in dwFlags parameter enables Service Discovery Protocol (SDP) to search for other Bluetooth devices within range
'Passing zero (0) in the dwFlags parameter performs a service search.
'The WSALookupServiceBegin() function returns a handle in the hLookup parameter.
If lngStatus = SOCKET_ERROR Then MsgBox "erreur" 'WSAGetLastError()
'retourne 0 si OK
'WSA_NOT_ENOUGH_MEMORY La mémoire était insuffisante pour effectuer l’opération.
'WSAEINVAL Un ou plusieurs paramètres étaient manquants ou non valides pour ce fournisseur.
'WSANO_DATA Le nom a été trouvé dans la base de données, mais aucune donnée correspondant aux restrictions spécifiées n’a été trouvée.
'WSANOTINITIALISED Le WS2_32.DLL n’a pas été initialisé. L’application doit d’abord appeler WSAStartup avant d’appeler les fonctions Windows Sockets.
'WSASERVICE_NOT_FOUND Aucun service de ce type n’est connu. Le service est introuvable dans l’espace de nom spécifié.
'si erreur = hloopkup est zéro (pas de handle)
If hLookup <> 0 Then
'To enumerate devices that were scanned by WSALookupServiceBegin(), call the WSALookupServiceNext() function.
'by passing the handle returned by WSALookupServiceBegin() in the hLookUp parameter
'To improve performance, the call to WSALookupServiceBegin() returns only the addresses of the devices, and these addresses are stored in memory.
'To retrieve the name and address of the device, pass LUP_RETURN_NAME | LUP_RETURN_ADDR in the dwFlags parameter.
'This function returns a pointer to a buffer that stores the result set in a WSAQUERYSET structure
'To enumerate the devices, loop through the list of devices, by calling WSALookupServiceNext() repetitively.
Dim WSAresult As WSAQUERYSET
Dim dwSize
WSAresult.dwNameSpace = NS_BTH
Do While (WSALookupServiceNextA(hLookup, LUP_RETURN_NAME Or LUP_RETURN_ADDR, dwSize, WSAresult) = 0)
'Set btAddr = WSAresult.lpcsaBuffer.RemoteAddr.lpSockaddr '(SOCKADDR_BTH *)pwsaResults->lpcsaBuffer->;
bHaveName = WSAresult.lpszServiceInstanceName
dwNameSpace = WSAresult.dwNameSpace
'tNAP Address = GET_NAP(btAddr)
'tSAP Address = GET_SAP(btAddr)
Loop
End If
'To terminate the device discovery process, call the WSALookupServiceEnd() function
'This function releases the lookup handle created by WSALookupServiceBegin()
lngStatus = WSALookupServiceEnd(hLookup)
If lngStatus <> 0 Then MsgBox "erreur" 'WSAGetLastError()
WSACleanup
End Sub |
VBA et winsock bluetooth
Répondre avec citation
Partager