【实验】VBS支持Type定义

Set Wrap=CreateObject("DynamicWrapper")
Wrap.Register "User32.dll","GetCursorPos","f=s","i=l","r=l"
 
Set POINT=New Struct
With POINT
	.Add "X", 4, 0
	.Add "Y", 4, 0
End With
Wrap.GetCursorPos(POINT.Ptr)
WScript.Echo(POINT.GetItem("X") & vbCrLf & POINT.GetItem("Y"))
 
Class Struct ' v1.1 allow typedef with dynawrap calls
	Public Property Get Ptr '******************************* Property Ptr
		Ptr=GetBSTRPtr(sBuf)
	End Property
	Private oMM,oSCat,oAnWi 'objets wrapper API
	Private dBuf,sBuf,iOffset
 
	Public Sub Add(sItem,iSize,Data) '********************** Method Add
		Dim lVSize,iD
		iD="0"
 
		lVSize = iSize
 
		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,"Method GetItem","The item " & sItem & "don't exist"
		End If
	End Function
 
	Public Function GetBSTRPtr(ByRef sData)
		'retun the TRUE address (variant long) of the sData string BSTR
		Dim pSource
		Dim pDest
 
		If VarType(sData)<>vbString Then 'little check
			GetBSTRPtr=0
			err.raise 10000, "GetBSTRPtr", "The variable is not a string"
			Exit Function
		End If
 
		pSource=oSCat.lstrcat(sData,"") 'trick to return sData pointer
		pDest=oSCat.lstrcat(GetBSTRPtr,"") 'idem
		GetBSTRPtr=CLng(0) 'cast function variable
		'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 Sub Class_Initialize 'Constructeur
		Set oMM=CreateObject("DynamicWrapper")
		oMM.Register "kernel32.dll","RtlMoveMemory","f=s","i=lll","r=l"
 
		Set oSCat=CreateObject("DynamicWrapper")
		oSCat.Register "kernel32.dll","lstrcat","f=s","i=ws","r=l"
 
		Set oAnWi=CreateObject("DynamicWrapper")
		oAnWi.Register "kernel32.dll","MultiByteToWideChar","f=s","i=llllll","r=l"
 
		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 'bytes array, size 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)
		'Read an iSize data to lpData+iOffset address
		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 'a little bit more complicated with string data...
				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 'don't forget conversion Ansi->Wide
			GetDataBSTR=Replace(GetDataBSTR,Chr(0),"")
			'clean the trailer
		End If
	End Function
End Class