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
| Class Struct ' v1.1
Public Property Get Ptr '***************************************************** Propriété Ptr
Ptr=GetBSTRPtr(sBuf)
End Property
Public Sub Add(sItem,sType,Data) '******************************************** Méthode Add
Dim lVSize,iA,iB,iD
iA=InStr(1,sType,"[",1)
iB=InStr(1,sType,"]",1)
iD="0"
If iA>0 And iB>0 Then
iD=Mid(sType,iA+1,iB-iA-1)
If isNumeric(iD) Then
sType=Left(sType,iA-1)
Else
Err.raise 10000,"Méthode Add","L'indice " & iD & " doit être numérique"
Exit Sub
End If
End If
Select Case UCase(sType)'************************************************* A COMPLETER AVEC D'AUTRES TYPES WIN32
'OS 32bits...
Case "DWORD","LONG","WPARAM","LPARAM","POINTX","POINTY","ULONG","HANDLE","HWND","HINSTANCE","HDC","WNDPROC","HICON","HCURSOR","HBRUSH"
lVSize=4
Case "LPBYTE","LPCTSTR","LPSTR","LPTSTR","LPPRINTHOOKPROC","LPSETUPHOOKPROC","LPOFNHOOKPROC","LPVOID","INT","UINT","LPARAM"
lVSize=4
Case "WORD"
lVSize=2
Case "BYTE"
lVSize=1
Case "TCHAR"
If CLng(iD)<1 Then lVSize="254" Else lVSize=iD
Case Else
Err.raise 10000,"Méthode Add","Le type " & sType & " n'est pas un type Win32"
Exit Sub
End Select
dBuf.Add sItem,lVSize
sBuf=sBuf & String(lVSize/2+1,Chr(0))
SetDataBSTR GetBSTRPtr(sBuf),lVSize,Data,iOffset
End Sub
Public Function GetItem(sItem) '********************************************** Méthode GetItem
Dim lOf,lSi,aItems,aKeys,i
If dBuf.Exists(sItem) then
lSi=CLng(dBuf.Item(sItem))
aKeys=dBuf.Keys
aItems=dBuf.Items
lOf=0
For i=0 To dBuf.Count-1
If aKeys(i)=sItem Then Exit For
lOf=lOf+aItems(i)
Next
GetItem=GetDataBSTR(Ptr,lSi,lOf)
Else
GetItem=""
err.raise 10000,"Méthode GetItem","L'item " & sItem & " n'existe pas"
End If
End Function
Public Function GetBSTRPtr(ByRef sData)
'renvoie la VRAIE adresse (variant long) de la chaine sData sans tenir compte du format variant BSTR
Dim pSource
Dim pDest
If VarType(sData)<>vbString Then 'vérification avant d'aller + loin
GetBSTRPtr=0
err.raise 10000, "GetBSTRPtr", "La variable fournie n'est pas une chaine"
Exit Function
End If
'sData a été passée par référence, c'est donc en réalité sBuf
pSource=oSCat.lstrcat(sData,"") 'astuce qui renvoie le pointeur vers le début de sBuf
pDest=oSCat.lstrcat(GetBSTRPtr,"") 'idem renvoie le pointeur vers la variable fonction
GetBSTRPtr=CLng(0) 'cast de la variable fonction qui doit renvoyer un format long
'l'adresse du contenu réel de sBuf (4octets) écrase le contenu de la variable GetBSTPtr
'les valeurs sont incrémentées de 8 octets pour tenir compte du Type Descriptor
oMM.RtlMovememory pDest+8,pSource+8,4
End Function
'******************************************************************************************************* IMPLEMENTATION
Private oMM,oSCat,oAnWi 'objets wrapper API
Private dBuf,sBuf,iOffset
Private Sub Class_Initialize 'Constructeur
Set oMM=CreateObject("DynamicWrapper")
oMM.Register "kernel32.dll","RtlMoveMemory","f=s","i=lll","r=l" 'pour manipuler directement la mémoire
Set oSCat=CreateObject("DynamicWrapper")
oSCat.Register "kernel32.dll","lstrcat","f=s","i=ws","r=l" 'pour obtenir l'adresse d'une variable
Set oAnWi=CreateObject("DynamicWrapper")
oAnWi.Register "kernel32.dll","MultiByteToWideChar","f=s","i=llllll","r=l" 'gestion conversion ansi->wide
Set dBuf=CreateObject("Scripting.Dictionary")
sBuf=""
iOffset=0
End Sub
Private Sub SetDataBSTR(lpData,iSize,Data,ByRef iOfs)
'Place une valeur Data de taille iSize à l'adresse lpData+iOfs
Dim lW,hW,xBuf
Select Case iSize 'on commence par formater les valeurs numériques
Case 1
lW=Data mod 256 'formatage 8 bits
xBuf=ChrB(lW)
Case 2 'if any
lW=Data mod 65536 'formatage 16 bits
xBuf=ChrW(lW) 'formatage little-endian
Case 4
hW=Fix(Data/65536)'high word
lW=Data mod 65536 'low word
xBuf=ChrW(lW) & ChrW(hW) 'formatage little-endian
Case Else 'un tableau d'octets de taille iSize
xBuf=Data
End Select
oMM.RtlMovememory lpData+iOfs,GetBSTRPtr(xBuf),iSize
iOfs=iOfs+iSize 'maj l'offset
End Sub
Private Function GetDataBSTR(lpData,iSize,iOffset)
'Lit une valeur de taille iSize à l'adresse lpData+iOffset
Const CP_ACP=0 'code ANSI
Dim pDest,tdOffset
'valeurs pour les données numériques
pDest=oSCat.lstrcat(GetDataBSTR,"")
tdOffset=8
Select Case iSize ' cast de la variable fonction
Case 1
GetDataBSTR=CByte(0)
Case 2
GetDataBSTR=CInt(0)
Case 4
GetDataBSTR=CLng(0)
Case Else 'un peu + compliqué pour une donnée chaine...
GetDataBSTR=String(iSize/2,Chr(0))
'la chaine variant BSTR stocke ses données ailleurs
pDest=GetBSTRPtr(GetDataBSTR)
tdOffset=0
End Select
'le contenu de la structure à l'offset iOffset écrase le contenu de la variable GetDataBSTR (tenir compte du TD)
oMM.RtlMovememory pDest+tdOffset,lpData+iOffset,iSize
if tdOffset=0 Then
oAnWi.MultiByteToWideChar CP_ACP,0,lpData+iOffset,-1,pDest,iSize 'ne pas oublier la conversion Ansi->Wide
GetDataBSTR=Replace(GetDataBSTR,Chr(0),"") 'on nettoye le trailer
End If
End Function
End Class |
