look here:
http://bbs.vbstreets.ru/viewtopic.php?f=1&t=50509
Printable View
@cliv Indeed the same Chinese relay card..!
Issue with your code is that it doesn't work in VB6 IDE. So debugging is only possible by making an .exe, since that executes fine.
One interesting point is that any function without parameters, like the enumerate function, only returning a long as result, does work in VB6 IDE.
So I'll stick with the solution that Olaf has provided, using a 'cdecl' wrapper.
_Wim_
Using the code from your posts, I was able to create a working program for my USB Relay. I'm attaching it for anyone who would like to see.
Thanks for the help!
P.S. This is my first post here, so I might be doing it wrong.
Code includes:
UsbRelay.VBP
UsbRelay.vbw
Form1.frm (Has 2 buttons, RelayOnBtn RelayOffBtn)
UsbRelay.bas
CdeclCall.bas
usb_relay_device.dll (Looks like I can not attach this file)
UsbRelay.VBP
Code:Type=Exe
Form=Form1.frm
Module=CdeclCall; CdeclCall.bas
Module=UsbRelay; UsbRelay.bas
IconForm="Form1"
Startup="Form1"
HelpFile=""
Title="UsbRelay"
ExeName32="UsbRelay.exe"
Command32=""
Name="UsbRelayVB6"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
DebugStartupOption=0
UsbRelay.vbw
Code:Form1 = 64, 46, 799, 913, , 32, 32, 433, 295, C
CdeclCall = 558, 18, 1317, 1017,
UsbRelay = 878, 16, 1616, 1048,
Form1.frm
Code:VERSION 5.00
Begin VB.Form Form1
Caption = "USB Relay Board"
ClientHeight = 1536
ClientLeft = 60
ClientTop = 420
ClientWidth = 4068
LinkTopic = "Form1"
ScaleHeight = 1536
ScaleWidth = 4068
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton RelayOffBtn
Caption = "Relay 1 OFF"
Height = 495
Left = 2100
TabIndex = 1
Top = 240
Width = 1575
End
Begin VB.CommandButton RelayOnBtn
Caption = "Relay 1 ON"
Height = 495
Left = 240
TabIndex = 0
Top = 240
Width = 1575
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim RlyHnd&
Dim RlySN$ ' 5 chars
Dim DeviceInfo As USB_Relay_Device_Info
'========================================================
Private Sub Form_Load()
Dim stat&
Dim bstr(4) As Byte ' for 5 charater RlySN$
' Initialize the DLL
stat& = RelayInit
' Get all devices pluged into pc ??? (may need work)
' Get Device Serial_Number (5 characters)
DeviceInfo = EnumerateDevice()
If DeviceInfo.Serial_Number <> 0 Then
Call CopyMemory(bstr(0), ByVal DeviceInfo.Serial_Number, 5)
RlySN$ = StrConv(bstr, vbUnicode)
End If
' Get Device Handle
RlyHnd& = OpenDeviceWithSerial(RlySN$)
stat& = RelayOpen(VarPtr(DeviceInfo))
End Sub
'========================================================
Private Sub Form_Unload(cancel As Integer)
Dim stat&
Call CloseDevice(RlyHnd&)
stat& = RelayExit
stat& = FreeEnumerate(VarPtr(DeviceInfo))
''Set DeviceInfo = Nothing ' Release the object.
End Sub
'========================================================
Private Sub RelayOnBtn_Click()
Dim stat&
'stat& = OpenAllChannels(RlyHnd&)
stat& = OpenOneChannel(RlyHnd&, 1) ' #1 On
End Sub
'========================================================
Private Sub RelayOffBtn_Click()
Dim stat&
'stat& = CloseAllChannels(RlyHnd&)
stat& = CloseOneChannel(RlyHnd&, 1) ' #1 Off
End Sub
' Call GetStatus(hnd, Status)
' MsgBox Status
UsbRelay.bas
Code:Attribute VB_Name = "UsbRelay"
Option Explicit
Public Declare Sub CopyMemory _
Lib "kernel32" Alias "RtlMoveMemory" ( _
ByRef Destination As Any, _
ByRef Source As Any, _
ByVal length&)
Public Enum USB_Relay_Device_Type
USB_RELAY_DEVICE_ONE_CHANNEL = 1
USB_RELAY_DEVICE_TWO_CHANNEL = 2
USB_RELAY_DEVICE_FOUR_CHANNEL = 4
USB_RELAY_DEVICE_EIGHT_CHANNEL = 8
End Enum
Public Type USB_Relay_Device_Info
Serial_Number As Long ' Pointer to 5 digits serial number
Device_Path As Long ' I assume this is not implemented..!?
Type As USB_Relay_Device_Type
Next As Long ' type is USB_Relay_Device_Info - RECURSIVE!
End Type
'========================================================
Public Static Function OpenDeviceWithSerial&(serialNumber$)
' returns handle to device!
' usage: hnd=OpenDeviceWithSerial("ABCDE")
OpenDeviceWithSerial = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_open_with_serial_number", _
vbLong, serialNumber, Len(serialNumber$))
End Function
'========================================================
Public Sub CloseDevice(ByVal handle&)
' Close entire relay board
If handle& <> 0 Then
Call cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_close", vbEmpty, handle&)
End If
End Sub
'========================================================
Public Static Function EnumerateDevice() As USB_Relay_Device_Info
' TODO add another wrapper on top of EnumerateDevice to collect all
' devices in an array, and serial nr translated into string(s)
' Get device info, return as "USB_Relay_Device_Info"
Dim lPtr&
Dim uRetVal As USB_Relay_Device_Info
lPtr& = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_enumerate", _
vbLong)
If lPtr& <> 0 Then
Call CopyMemory(uRetVal, ByVal lPtr&, LenB(uRetVal))
EnumerateDevice = uRetVal
End If
End Function
'========================================================
Public Static Function GetStatus&(ByVal handle&, ByRef status&)
' Get open/close status of the relay switches.
' Although long is returned, only LSB byte is used
' '3' = two switches are open
If handle& <> 0 Then
Call cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_get_status", _
vbLong, handle&, VarPtr(status&))
End If
End Function
'========================================================
Public Static Function RelayInit&()
' Supposed to start the application with RelayInit,
' but appears not really necessary...!?
RelayInit& = cdeclCallA("usb_relay_device.dll", "usb_relay_init", vbEmpty)
End Function
'========================================================
Public Static Function RelayExit&()
' Call on Form_Unload
Call cdeclCallA("usb_relay_device.dll", "usb_relay_exit", vbEmpty)
End Function
'========================================================
Public Static Function RelayOpen&(devInfo&)
' Open device using Device_Info obtained via EnumerateDevice
If devInfo& <> 0 Then
RelayOpen = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_open", vbLong, devInfo&)
End If
End Function
'========================================================
Public Static Function OpenAllChannels(ByVal handle&)
' Activates all relay switches..
' CLOSE all the relay contacts
If handle& <> 0 Then
OpenAllChannels = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_open_all_relay_channel", _
vbLong, handle&)
End If
End Function
'========================================================
Public Static Function OpenOneChannel(ByVal handle&, ByVal indx&)
' Activates one relay contact, index = 1, 2, etc
If handle& <> 0 Then
OpenOneChannel = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_open_one_relay_channel", _
vbLong, handle&, indx&)
End If
End Function
'========================================================
Public Static Function CloseOneChannel(ByVal handle&, ByVal indx&)
' Deactivate one relay contact, index = 1, 2, etc
If handle& <> 0 Then
CloseOneChannel = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_close_one_relay_channel", _
vbLong, handle&, indx&)
End If
End Function
'========================================================
Public Static Function CloseAllChannels(ByVal handle&)
' Deactivates all relay switches.
' OPEN all the relay contacts
If handle& <> 0 Then
CloseAllChannels = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_close_all_relay_channel", _
vbLong, handle&)
End If
End Function
'========================================================
Public Static Function FreeEnumerate&(ByVal devInfo&)
If devInfo& <> 0 Then
FreeEnumerate = cdeclCallA("usb_relay_device.dll", _
"usb_relay_device_free_enumerate", _
vbLong, devInfo&)
End If
End Function
CdeclCall.bas
Code:Attribute VB_Name = "CdeclCall"
Option Explicit
' Some DLL's are compiled for C using "cdecl". These DLL's must be
' re-compiled using the "StdCall" convention to be used with VB6.
' You can call cdecl-defined functions without re-compiling the DLL
' when you use this DispCallFunc-API
'
' Using the drop-in-module below, your code could then look like:
'
' Function OpenDeviceWithSerial(SerialNumber$)&
' OpenDeviceWithSerial = CdeclCallA(YourDllFilePath, _
' "usb_relay_device_open_with_serial_number", _
' vbLong, SerialNumber, Len(SerialNumber))
' End Function
Private Declare Function DispCallFunc& _
Lib "oleaut32" ( _
ByVal pvInstance&, _
ByVal offsetinVft&, _
ByVal CallConv&, _
ByVal retTYP As Integer, _
ByVal paCNT&, _
ByRef paTypes As Integer, _
ByRef paValues&, _
ByRef retVAR As Variant)
Private Declare Function GetProcAddress& _
Lib "kernel32" ( _
ByVal hModule&, _
ByVal lpProcName$)
Private Declare Function LoadLibrary& _
Lib "kernel32" Alias "LoadLibraryA" ( _
ByVal lpLibFileName$)
Private Declare Function FreeLibrary& _
Lib "kernel32" ( _
ByVal hLibModule&)
Private Declare Function lstrlenA& _
Lib "kernel32" ( _
ByVal lpString&)
Private Declare Function lstrlenW& _
Lib "kernel32" ( _
ByVal lpString&)
Private Declare Sub RtlMoveMemory _
Lib "kernel32" ( _
ByRef dst As Any, _
ByRef src As Any, _
ByVal bLen&)
Private Enum CallingConventionEnum
CC_FASTCALL
CC_CDECL
CC_PASCAL
CC_MACPASCAL
CC_STDCALL
CC_FPFASTCALL
CC_SYSCALL
CC_MPWCDECL
CC_MPWPASCAL
End Enum
Private LibHdls As New Collection, _
VType%(0 To 63), _
VPtr&(0 To 63)
'========================================================
Public Static Function CdeclCallA(sDll$, sFunc$, _
ByVal retType As VbVarType, ParamArray p() As Variant)
Dim i&, pFunc&, v(), hRes&
' Make a copy of the params, to prevent problems with
' VT_Byref-Members in the ParamArray
v = p
For i& = 0 To UBound(v)
If VarType(p(i&)) = vbString Then
p(i&) = StrConv(p(i&), vbFromUnicode)
v(i&) = StrPtr(p(i))
End If
VType(i&) = VarType(v(i&))
VPtr(i&) = VarPtr(v(i&))
Next i&
hRes& = DispCallFunc(0, GetFuncPtr(sDll$, sFunc$), CC_CDECL, retType, _
i&, VType(0), VPtr(0), CdeclCallA)
For i& = 0 To UBound(p) 'back-conversion of the ANSI-String-Results
If VarType(p(i&)) = vbString Then p(i&) = StrConv(p(i&), vbUnicode)
Next i&
If hRes& Then Err.Raise hRes&
End Function
'========================================================
Public Static Function StdCallA(sDll$, sFunc$, ByVal retType As VbVarType, _
ParamArray p() As Variant)
Dim i&, pFunc&, v(), hRes&
' Make a copy of the params, to prevent problems with
' VT_Byref-Members in the ParamArray
v = p
For i& = 0 To UBound(v)
If VarType(p(i&)) = vbString Then
p(i&) = StrConv(p(i&), vbFromUnicode)
v(i&) = StrPtr(p(i&))
End If
VType(i&) = VarType(v(i&))
VPtr(i&) = VarPtr(v(i&))
Next i&
hRes& = DispCallFunc(0, GetFuncPtr(sDll$, sFunc$), CC_STDCALL, retType, _
i&, VType(0), VPtr(0), StdCallA)
For i& = 0 To UBound(p) 'back-conversion of the ANSI-String-Results
If VarType(p(i&)) = vbString Then p(i&) = StrConv(p(i&), vbUnicode)
Next i&
If hRes& Then Err.Raise hRes&
End Function
'========================================================
Public Static Function StdCallW(sDll$, sFunc$, ByVal retType As VbVarType, _
ParamArray p() As Variant)
Dim i&, v(), hRes&
' Make a copy of the params, to prevent problems with
' VT_Byref-Members in the ParamArray
v = p
For i& = 0 To UBound(v)
If VarType(p(i&)) = vbString Then v(i&) = StrPtr(p(i&))
VType(i&) = VarType(v(i&))
VPtr(i&) = VarPtr(v(i&))
Next i&
hRes& = DispCallFunc(0, GetFuncPtr(sDll$, sFunc$), CC_STDCALL, _
retType, i&, VType(0), VPtr(0), StdCallW)
If hRes& Then Err.Raise hRes&
End Function
'========================================================
Public Static Function CdeclCallW(sDll$, sFunc$, ByVal retType As VbVarType, _
ParamArray p() As Variant)
Dim i&, v(), hRes&
' Make a copy of the params, to prevent problems with
' VT_Byref-Members in the ParamArray
v = p
For i& = 0 To UBound(v)
If VarType(p(i&)) = vbString Then v(i&) = StrPtr(p(i&))
VType(i&) = VarType(v(i&))
VPtr(i&) = VarPtr(v(i&))
Next i&
hRes& = DispCallFunc(0, GetFuncPtr(sDll$, sFunc$), CC_CDECL, retType, _
i&, VType(0), VPtr(0), CdeclCallW)
If hRes& Then Err.Raise hRes&
End Function
'========================================================
Public Static Function VtblCall(pUnk&, ByVal vtblIdx&, _
ParamArray p() As Variant)
Dim i&, v(), hRes&
If pUnk = 0 Then Exit Function
' Make a copy of the params, to prevent problems with
' VT_Byref-Members in the ParamArray
v = p
For i& = 0 To UBound(v)
VType(i&) = VarType(v(i&))
VPtr(i&) = VarPtr(v(i&))
Next i&
hRes& = DispCallFunc(pUnk&, vtblIdx& * 4, CC_STDCALL, vbLong, _
i&, VType(0), VPtr(0), VtblCall)
If hRes& Then Err.Raise hRes&
End Function
'========================================================
Public Static Function GetFuncPtr&(sDll$, sFunc$)
Dim hLib&, sLib$
If sLib$ <> sDll$ Then ' Caching, to make resolving libHdls faster
sLib$ = sDll$
On Error Resume Next
hLib& = 0
hLib& = LibHdls(sLib$)
On Error GoTo 0
If hLib& = 0 Then
hLib& = LoadLibrary(sLib$)
If hLib& = 0 Then
Err.Raise vbObjectError, , "Dll not found (or loadable): " & sLib$
End If
LibHdls.Add hLib&, sLib$ '<- cache under the dll-name for the next call
End If
End If
GetFuncPtr& = GetProcAddress(hLib&, sFunc$)
If GetFuncPtr& = 0 Then
Err.Raise 453, , "EntryPoint not found: " & sFunc$ & " in: " & sLib
End If
End Function
'========================================================
Public Static Function GetBStrFromPtr$(lpSrc&, _
Optional ByVal ANSI As Boolean)
Dim sLen&
If lpSrc& = 0 Then Exit Function
If ANSI Then
sLen& = lstrlenA(lpSrc&)
Else
sLen = lstrlenW(lpSrc&)
End If
If sLen Then
GetBStrFromPtr = Space$(sLen&)
Else
Exit Function
End If
Select Case ANSI
Case True: RtlMoveMemory ByVal GetBStrFromPtr, ByVal lpSrc&, sLen&
Case Else: RtlMoveMemory ByVal StrPtr(GetBStrFromPtr), _
ByVal lpSrc&, sLen& * 2
End Select
End Function
'========================================================
Public Static Sub CleanupLibHandles()
' Not really needed - but callable (usually at process-shutdown) to
' clear things up
Dim libHdl
For Each libHdl In LibHdls
FreeLibrary libHdl
Next
Set LibHdls = Nothing
End Sub
Glad to see that the efforts of the experts here, and my humble efforts helped you (and me) to use these Chinese relays..!
Note only the .bas and .frm are needed.
Given time, I want to enhance the enumerate function, since the .dll supports multiple relay cards. Also I would like to return the actual serial number as (array of) strings, instead of a pointer. But bottomline it works! :)
And thanks to Olaf Schmidt...
_Wim_
Here is another way to get the String from a cdecl string pointer.
Code:Private Declare Function SysAllocStringByteLen$ _
Lib "oleaut32.dll" ( _
Optional ByVal pszStrPtr&, _
Optional ByVal strLength&)
'========================================================
Private Sub Form_Load()
Dim stat&
' Initialize the DLL
stat& = RelayInit
' Enumerate all devices
DeviceInfo = EnumerateDevice()
' Get Device Serial_Number (5 characters)
If DeviceInfo.Serial_Number <> 0 Then
' Got pointer to string, now get string
RlySN$ = SysAllocStringByteLen$(DeviceInfo.Serial_Number, 5)
Label1 = "Serial Number " & RlySN$
End If
' Get Device Handle
RlyHnd& = OpenDeviceWithSerial(RlySN$)
stat& = RelayOpen(VarPtr(DeviceInfo))
End Sub
Not sure whether you noticed... but I've already included a nice helper-function in the cdecl-call-module:
GetBStrFromPtr(lpSrc&, Optional ByVal ANSI As Boolean) As String
In the concrete case of this relais-device-dll, you'll probably need to specify the Optional param as True..
HTH
Olaf
Yea,
I'm using your GetBStrFromPtr because it can handle both single and dual byte characters. (ANSI and Unicode)
Thanks again!
vb6 call by cdecl dll api:
how to Fast Call cdecl api like sqlite3.dll? - Page 2-VBForums
https://www.vbforums.com/showthread....ighlight=CDECL
call methodCode:Option Explicit
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function VirtualProtect Lib "kernel32" (ByVal lpAddress As Long, ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long
Public Function CallCdecl(ByVal Pfn As Long, Optional ByVal Spacer As Long) As Long
pvPatchTrampoline AddressOf Module1.CallCdecl, 0
CallCdecl = CallCdecl(Pfn)
End Function
Public Function CallCdecl1(ByVal Pfn As Long, ByVal Arg1 As Long, Optional ByVal Spacer As Long) As Long
pvPatchTrampoline AddressOf Module1.CallCdecl1, 1
CallCdecl1 = CallCdecl1(Pfn, Arg1)
End Function
Public Function CallCdecl2(ByVal Pfn As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, Optional ByVal Spacer As Long) As Long
pvPatchTrampoline AddressOf Module1.CallCdecl2, 2
CallCdecl2 = CallCdecl2(Pfn, Arg1, Arg2)
End Function
Public Function CallCdecl3(ByVal Pfn As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, ByVal Arg3 As Long, Optional ByVal Spacer As Long) As Long
pvPatchTrampoline AddressOf Module1.CallCdecl3, 3
CallCdecl3 = CallCdecl3(Pfn, Arg1, Arg2, Arg3)
End Function
Public Function CallCdecl4(ByVal Pfn As Long, ByVal Arg1 As Long, ByVal Arg2 As Long, ByVal Arg3 As Long, ByVal Arg4 As Long, Optional ByVal Spacer As Long) As Long
pvPatchTrampoline AddressOf Module1.CallCdecl4, 4
CallCdecl4 = CallCdecl4(Pfn, Arg1, Arg2, Arg3, Arg4)
End Function
Private Function pvPatchTrampoline(ByVal Pfn As Long, ByVal lNumParams As Long) As Boolean
Const PAGE_EXECUTE_READWRITE As Long = &H40
Const THUNK_SIZE As Long = 21
Dim bInIDE As Boolean
Dim aThunk(0 To 5) As Long
Debug.Assert pvSetTrue(bInIDE)
If bInIDE Then
Call CopyMemory(Pfn, ByVal Pfn + &H16, 4)
Else
Call VirtualProtect(Pfn, THUNK_SIZE, PAGE_EXECUTE_READWRITE, 0)
End If
' 0: 58 pop eax
' 1: 89 84 24 XX XX XX XX mov dword ptr [esp+Xh],eax
' 8: 58 pop eax
' 9: FF D0 call eax
' 11: 90 nop
' 12: 90 nop
' 13: 90 nop
' 14: 81 C4 XX XX XX XX add esp,Xh
' 20: C3 ret
aThunk(0) = &H24848958
aThunk(1) = lNumParams * 4 + 4
aThunk(2) = &H90D0FF58
aThunk(3) = &HC4819090
aThunk(4) = lNumParams * 4
aThunk(5) = &HC3
Call CopyMemory(ByVal Pfn, aThunk(0), THUNK_SIZE)
'--- success
pvPatchTrampoline = True
End Function
Private Function pvSetTrue(bValue As Boolean) As Boolean
bValue = True
pvSetTrue = True
End Function
but i think it's best like ,do anyone can do it?Code:pvPatchTrampoline AddressOf Module1.CallCdecl2,0
msgbox CallCdecl2(cdecl_sum,a,b)
how to fix like :pvPatchTrampoline module1.sum,cdecl_sum_address
Code:pvPatchTrampoline module1.sum,cdecl_sum_address
function sum(a as long ,b as long )
'***
end function
what about this?
GetMem4 ByVal GetAddr(AddresOf NeedFunc) + &H16, NeedAddr
what's this?
[VBCompiler]
LinkSwitches= "C:\Program Files\Microsoft Visual Studio\VB98\Projects\TestVB6StaticLink\Release\TestVB6StaticLink.lib" /EXPORT:_StrLen@4
Конференция VBStreets • Просмотр темы — Direct3D9 в VB6.
http://bbs.vbstreets.ru/viewtopic.ph...49733#p6780386
TestVB6StaticLink.zip
(44.92 Кб)
http://bbs.vbstreets.ru/download/file.php?id=10644
call Declare sub like call function address, it's jmp?
http://bbs.vbstreets.ru/viewtopic.php?f=28&t=42929
func_pointers_1.0.4.zip
http://bbs.vbstreets.ru/download/file.php?id=9542
Конференция VBStreets • Просмотр темы — cdecl
http://bbs.vbstreets.ru/viewtopic.ph...CDECL#p6758145
Code:Function PatchVBA4cdecl(Optional Enable As Boolean = True) As Boolean
' для вызовов dll с соглашением cdecl
'!Support only vba332.dll v.3.0.7019!
Const PAGE_EXECUTE_READWRITE = &H40
Const pCRC = &HD8, CRC = &H1928EA, pPatch1 = &H155E26, pPatch2 = &H155E6B
Const Original = "3B FC 0F 85 BB 6D 00 00", Patch = "8B E7 90 90 90 90 90
90"
Dim p&, i&, S$, er&
p = GetModuleHandle("vba332")
CopyMemory ByVal VarPtr(i), ByVal (p + pCRC), 4
If i <> CRC Then PatchVBA4cdecl = True: Exit Function
If Enable Then S = Hex2Bin(Patch) Else S = Hex2Bin(Original)
er = VirtualProtect(ByVal p + pPatch1, 77, PAGE_EXECUTE_READWRITE, i)
CopyMemory ByVal p + pPatch1, ByVal S, 8
CopyMemory ByVal p + pPatch2, ByVal S, 8
er = VirtualProtect(ByVal p + pPatch1, 77, ByVal i, i)
End Function
VBStreets会议•查看主题-cdecl
http://bbs.vbstreets.ru/viewtopic.ph...45&hilit=CDECL
Yes, you have to deallocate it but your SysAllocStringByteLen API declare does not allow this. It has to be tweaked to return a raw Long pointer so it can be invoked like this
Dim sText As String
lPtr = SysAllocStringByteLen(...)
Call CopyMemory(ByVal VarPtr(sText), lPtr, 4)
. . . and let VB call SysFreeString when local sText variable gets deallocated.
Having an API declare to return a String means that its C/C++ prototype is something like char *MyFunction(...), not BSTR MyFunction(...).
So the compiler emits code that expects a pointer to a null-terminated ANSI string to be returned and this automagically gets converted to a BSTR (String). So in the case of SysAllocStringByteLen the returned BSTR indeeds packs ANSI string which correctly gets converted to Unicode but it ultimately leaks.
Tweaking the API's return type to be Long switches off the ANSI->Unicode magic so the sText value in above snippet will look weird before being manually "unpacked" to Unicode with StrConv(sText, vbUnicode) or similar.
cheers,
</wqw>
I seems found out why VB6 crashes when we use cdecl declared APIs in a tlb. There is a bug (seems) in handling conventions and there is no cdecl call p-code. More precisely, the p-code exists but there is no handler (it returns internal error). Just i made a small tests and replace the missing p-code handler and... it works )))
I'm making the Add-in which fixes the bug in runtime.
So this will allow using typelib declared cdecl imports in both compiled executable and IDE project?
That would be the best solution if the compiler can save us the trouble of providing manual trampolines *and* the code works in IDE without modification.
What about compile to p-code (not native)? Is this already working with typelib declared cdecls?
cheers,
</wqw>
You might be interested in these ANSI/Unicode one-liners as well.
Typically, you don't need to use that API; simply letting the string go out of scope or setting it to vbNullString is enough to free the string.
Actually, it has been confirmed in the discussion here that that declaration doesn't cause any leaks.
Yes it will work both native (already works) and IDE. Just i'm creating the table where recognize the new undocumented p-codes. I also make new __cdecl handlers for the new p-codes because current stubs just generates 0x33 error.
It doesn't work because the bug in VB6 exe. To remove the bug you need only fix one byte and then it will compile successfully (without crashes) but the compiled executable will give 0x33 error because there is NO __cdecl p-code handles. My Add-in removes the bug in VB6.exe and places the new P-code handlers instead empty stubs. So if you want to use __cdecl in a p-code executable you only need to add those handlers (you can just insert Add-in's initialization code).Quote:
What about compile to p-code (not native)? Is this already working with typelib declared cdecls?
I'll plan to add the __cdecl support to Declare statement but i don't know exactly if it's possible because i inject to the codegeneration process which isn't documented.
Actually, yes. The analysis is correct!
The assembly emitted does call ANSI-to-Unicode *and* uses __vbaFreeStrList run-time function to cleanup the As String result from the API call which is mind-boggling.
Same happens for SysAllocString declare but it works correctly only if the ANSI string is double-zero terminated.
So it seems that for API declares with As String result the returned pointer is always ANSI-to-Unicode converted (which is expected) and SysStringFree'd just in case (which is weird).
Probably the reasoning is that if it's not a BSTR this does not hurt apparently and oleaut32 implementation bails out without corrupting internal strings allocator.
cheers,
</wqw>
Direct ZIP download from github garbles line endings, it looks like * text eol=crlf missing in .gitattributes but this still works:
c:> git clone https://github.com/thetrik/VBCDeclFix.git
cheers,
</wqw>