I'm investigating a memory leak in some old VB6 code that seems to be related to recordset objects, so I'm trying to get the reference counts on the objects. I found some code online that will give a count of references to an object, and it works for a home-grown class. But when I try to apply it to ADODB recordset objects, the count is always 1492925242. I've tried this in the existing app and then in a dummy app - always comes back with the same number (unless there are no references, then it's 0).
Here's the code that gets the reference count:
Private Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, src As Any, ByVal nbytes As Long)
Function objRefCnt(obj As IUnknown) As Long
If Not obj Is Nothing Then
RtlMoveMemory objRefCnt, ByVal ObjPtr(obj) + 4, 4
objRefCnt = objRefCnt - 2
Else
objRefCnt = 0
End If
End Function
Here's the code that calls it on ADODB recordsets:
Sub main()
Dim obj_1 As ADODB.Recordset
Dim obj_2 As ADODB.Recordset
Debug.Print objRefCnt(obj_1) ' 0
Set obj_1 = New ADODB.Recordset
Debug.Print objRefCnt(obj_1) ' 1
Set obj_2 = obj_1
Debug.Print objRefCnt(obj_1) ' 2
Debug.Print objRefCnt(obj_2) ' 2
Set obj_2 = New ADODB.Recordset
Debug.Print objRefCnt(obj_1) ' 1
Debug.Print objRefCnt(obj_2) ' 1
End Sub
This returns the following:
0
1492925242
1492925242
1492925242
1492925242
1492925242
But when I added a dummy class called Class1 that has a single property (an integer), and create obj_1 and obj_2 as Class1 objects, I get this:
0
1
2
2
1
1
Any ideas on how I can get a reference count on the ADODB recordsets?
Thanks in advance.
The code you found assumes the reference count is stored inside the object at offset 4. There is no such requirement. IUnknown defines methods, not where private variables must be stored (and the reference count is a private variable of an object).
The way to get the reference count (for testing purposes only) is to call IUnknown.Release.
In order to do that from VB6, find olelib.tlb on the Internet (Edanmo's OLE interfaces & functions), reference it, and have
Public Function GetRefCount(ByVal obj As olelib.IUnknown) As Long
obj.AddRef
GetRefCount = obj.Release - 2
End Function
Dim r1 As ADODB.Recordset
Dim r2 As ADODB.Recordset
Set r1 = New ADODB.Recordset
Set r2 = r1
MsgBox GetRefCount(r1) ' 2
It appears m_dwRefCount member variable of ADODB.Recordset instances is at offset 16.
Try this objRefCnt replacement:
Private Declare Sub RtlMoveMemory Lib "kernel32" (dest As Any, src As Any, ByVal nbytes As Long)
Function RecordsetRefCnt(rs As Recordset) As Long
If Not rs Is Nothing Then
RtlMoveMemory RecordsetRefCnt, ByVal ObjPtr(rs) + 16, 4
RecordsetRefCnt = RecordsetRefCnt - 1
Else
RecordsetRefCnt = 0
End If
End Function
JFYI, here is a AddRef/Release based GetRefCount impl without additional typelibs
Private Declare Function DispCallFunc Lib "oleaut32" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal lCc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, prgVt As Any, prgpVarg As Any, pvargResult As Variant) As Long
Public Function GetRefCount(pUnk As IUnknown) As Long
Const CC_STDCALL As Long = 4
Dim vResult As Variant
Call DispCallFunc(ObjPtr(pUnk), 1 * 4, CC_STDCALL, vbLong, 0, ByVal 0, ByVal 0, 0)
Call DispCallFunc(ObjPtr(pUnk), 2 * 4, CC_STDCALL, vbLong, 0, ByVal 0, ByVal 0, vResult)
GetRefCount = vResult - 2
End Function
And here is the AddRef/Release based GetRefCount implementation without additional typelibs which also works with 64-bit VBA:
#If VBA7 Then
Private Declare PtrSafe Function DispCallFunc Lib "oleAut32.dll" (ByVal pvInstance As LongPtr, ByVal oVft As LongPtr, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, ByRef prgVt As Any, ByRef prgpVarg As Any, ByRef pvargResult As Variant) As Long
#Else
Private Declare Function DispCallFunc Lib "oleaut32.dll" (ByVal pvInstance As Long, ByVal oVft As Long, ByVal cc As Long, ByVal vtReturn As VbVarType, ByVal cActuals As Long, ByRef prgVt As Any, ByRef prgpVarg As Any, ByRef pvargResult As Variant) As Long
#End If
Public Function GetRefCount(ByRef pUnk As IUnknown) As Long
Const CC_STDCALL As Long = 4
#If Win64 Then
Const PTR_SIZE As Long = 8
#Else
Const PTR_SIZE As Long = 4
#End If
If pUnk Is Nothing Then Exit Function
Dim vResult As Variant
Call DispCallFunc(ObjPtr(pUnk), 1 * PTR_SIZE, CC_STDCALL, vbLong, 0, ByVal 0, ByVal 0, 0)
Call DispCallFunc(ObjPtr(pUnk), 2 * PTR_SIZE, CC_STDCALL, vbLong, 0, ByVal 0, ByVal 0, vResult)
GetRefCount = vResult - 2
End Function
I have a base64 string which was generated from an image using another application. Now on my application I want to convert the base64 string to byte and display it on a PictureBox.
I already found a sample application which takes a byte input and sets a PictureBox image. Unfortunately the sample application gets the byte array from an image and just translates it back. Here's the function it uses.
Public Function PictureFromByteStream(b() As Byte) As IPicture
Dim LowerBound As Long
Dim ByteCount As Long
Dim hMem As Long
Dim lpMem As Long
Dim IID_IPicture(15)
Dim istm As stdole.IUnknown
On Error GoTo Err_Init
If UBound(b, 1) < 0 Then
Exit Function
End If
LowerBound = LBound(b)
ByteCount = (UBound(b) - LowerBound) + 1
hMem = GlobalAlloc(&H2, ByteCount)
If hMem <> 0 Then
lpMem = GlobalLock(hMem)
If lpMem <> 0 Then
MoveMemory ByVal lpMem, b(LowerBound), ByteCount
Call GlobalUnlock(hMem)
If CreateStreamOnHGlobal(hMem, 1, istm) = 0 Then
If CLSIDFromString(StrPtr("{7BF80980-BF32-101A-8BBB-00AA00300CAB}"), IID_IPicture(0)) = 0 Then
Call OleLoadPicture(ByVal ObjPtr(istm), ByteCount, 0, IID_IPicture(0), PictureFromByteStream)
End If
End If
End If
End If
Exit Function
Err_Init:
If Err.Number = 9 Then
'Uninitialized array
MsgBox "You must pass a non-empty byte array to this function!"
Else
MsgBox Err.Number & " - " & Err.Description
End If
End Function
Here's the function I found to convert a base64 string to a byte, it seems to be converting it but when I pass the byte data to the above function, no image appears.
Private Function DecodeBase64(ByVal strData As String) As Byte()
Dim objXML As MSXML2.DOMDocument
Dim objNode As MSXML2.IXMLDOMElement
' help from MSXML
Set objXML = New MSXML2.DOMDocument
Set objNode = objXML.createElement("b64")
objNode.dataType = "bin.base64"
objNode.Text = strData
DecodeBase64 = objNode.nodeTypedValue
' thanks, bye
Set objNode = Nothing
Set objXML = Nothing
End Function
And here's my code calling the functions.
Dim b() As Byte
b = DecodeBase64(Text1.Text)
Dim pic As StdPicture
Set pic = PictureFromByteStream(b)
Set Picture1.Picture = pic
Try this:
Option Explicit
Private Const CRYPT_STRING_BASE64 As Long = &H1&
Private Const STRING_IPICTURE_GUID As String = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Declare Function CryptStringToBinaryW Lib "Crypt32.dll" ( _
ByVal pszString As Long, _
ByVal cchString As Long, _
ByVal dwFlags As Long, _
ByVal pbBinary As Long, _
ByRef pcbBinary As Long, _
ByVal pdwSkip As Long, _
ByVal pdwFlags As Long) As Long
Private Declare Function CreateStreamOnHGlobal Lib "ole32.dll" ( _
ByRef hGlobal As Any, _
ByVal fDeleteOnResume As Long, _
ByRef ppstr As Any) As Long
Private Declare Function OleLoadPicture Lib "olepro32.dll" ( _
ByVal lpStream As IUnknown, _
ByVal lSize As Long, _
ByVal fRunMode As Long, _
ByRef riid As GUID, _
ByRef lplpObj As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Long, _
ByRef pclsid As GUID) As Long
Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Public Function DecodeBase64(ByVal strData As String) As Byte()
Dim Buffer() As Byte
Dim dwBinaryBytes As Long
dwBinaryBytes = LenB(strData)
ReDim Buffer(dwBinaryBytes - 1) As Byte
If CryptStringToBinaryW(StrPtr(strData), LenB(strData), CRYPT_STRING_BASE64, _
VarPtr(Buffer(0)), dwBinaryBytes, 0, 0) Then
ReDim Preserve Buffer(dwBinaryBytes - 1) As Byte
DecodeBase64 = Buffer
End If
Erase Buffer
End Function
Public Function PictureFromByteStream(ByRef b() As Byte) As IPicture
On Error GoTo errorHandler
Dim istrm As IUnknown
Dim tGuid As GUID
If Not CreateStreamOnHGlobal(b(LBound(b)), False, istrm) Then
CLSIDFromString StrPtr(STRING_IPICTURE_GUID), tGuid
OleLoadPicture istrm, UBound(b) - LBound(b) + 1, False, tGuid, PictureFromByteStream
End If
Set istrm = Nothing
Exit Function
errorHandler:
Debug.Print "Error in converting to IPicture."
End Function
I have a xls/csv list of images:
Name image url
test.jpg http://test.com/232dd.jpg
test2.jpg http://test.com/2390j.jpg
I have about 200 of these...is there a way to download the list and name them as identified in the xls file?
Here is my Excel VBA:
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim cell As Variant
Set rng = Range("A1:B10")
For Each cell In rng
' Download the file.
URLDownloadToFile 0, cell(rng, 2).Value, "C:\" & cell(rng, 1).Value, 0, 0
Next
End Sub
Running into type mismatch error with URLDownloadToFile
OK The type mismatch has to do with your iteration. You need to specify how you're iterating over rng with the For each cell in rng statement, like:
For each cell in rng.Rows
Otherwise, it treats that statement as For each cell in rng.Cells and that raises the mismatch error.
I made some modifications to the code (based on Sid's answer here), so it checks to ensure the file downloaded successfully, but mostly what you found was correct, you just need to implement it a little differently.
Private Declare Function URLDownloadToFile Lib "urlmon" _
Alias "URLDownloadToFileA" (ByVal pCaller As Long, _
ByVal szURL As String, ByVal szFileName As String, _
ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Private Sub download_pics()
Dim rng As Range
Dim myRow As Range
Dim imgName As String
Dim fileLocation As String
Dim Ret As Long 'return value from the URLDownloadToFile function
Set rng = Range("A1:B10")
For Each myRow In rng.Rows
With myRow
imgName = .Columns(2).Value
fileLocation = "C:\" & .Columns(1).Value
With .Columns(1).Offset(, 2)
If URLDownloadToFile(0, imgName, fileLocation, 0, 0) = 0 Then
.Value = "downloaded successfully"
Else:
.Value = "download failed!"
End If
End With
End With
Next
End Sub
I need to have my form-based application check stdin periodically for input, but still perform other processing. Scripting.TextStream.Read() and the ReadFile() API are blocking, is there a non-blocking method of reading stdin in VB6?
With Timer1 set to fire every 100 ms, I've tried:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Dim sin As Scripting.TextStream
Private Sub Form_Load()
AllocConsole
Dim FSO As New Scripting.FileSystemObject
Set sin = FSO.GetStandardStream(StdIn)
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim cmd As String
While Not sin.AtEndOfStream
cmd = sin.Read(1)
Select Case cmd
' Case statements to process each byte read...
End Select
Wend
End Sub
I've also tried:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function ReadFileA Lib "kernel32" Alias "ReadFile" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Const STD_INPUT_HANDLE = -10&
Dim hStdIn As Long
Private Sub Form_Load()
AllocConsole
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
Timer1.Enabled = True
End Sub
Private Sub Timer1_Timer()
Dim bytesRead as Long
Dim cmd As String
cmd = Space$(16)
cmd = ReadFile(hStdIn, ByVal cmd, Len(cmd), bytesRead, ByVal 0&)
' Statements to process each Line read...
End Sub
I've tried the ReadConsole() API, too, they all block.
Use vbAdvance add-in to compile following sample with "Build As Console Application" option checked.
Option Explicit
'--- for GetStdHandle
Private Const STD_INPUT_HANDLE As Long = -10&
Private Const STD_OUTPUT_HANDLE As Long = -11&
'--- for PeekConsoleInput
Private Const KEY_EVENT As Long = 1
'--- for GetFileType
Private Const FILE_TYPE_PIPE As Long = &H3
Private Const FILE_TYPE_DISK As Long = &H1
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function GetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, lpMode As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleHandle As Long, ByVal dwMode As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, ByVal lpBytesRead As Long, lpTotalBytesAvail As Long, ByVal lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function OemToCharBuff Lib "user32" Alias "OemToCharBuffA" (ByVal lpszSrc As String, ByVal lpszDst As String, ByVal cchDstLength As Long) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, lpOverlapped As Any) As Long
Private Declare Function CharToOemBuff Lib "user32" Alias "CharToOemBuffA" (ByVal lpszSrc As String, lpszDst As Any, ByVal cchDstLength As Long) As Long
Private Declare Function PeekConsoleInput Lib "kernel32" Alias "PeekConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadConsoleInput Lib "kernel32" Alias "ReadConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function GetFileType Lib "kernel32" (ByVal hFile As Long) As Long
Sub Main()
Dim hStdIn As Long
Dim sBuffer As String
Dim dblTimer As Double
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
Do
sBuffer = sBuffer & ConsoleReadAvailable(hStdIn)
If dblTimer + 1 < Timer Then
dblTimer = Timer
Call OemToCharBuff(sBuffer, sBuffer, Len(sBuffer))
ConsolePrint "%1: %2" & vbCrLf, Format$(Timer, "0.00"), sBuffer
sBuffer = vbNullString
End If
Loop
End Sub
Private Function ConsoleReadAvailable(ByVal hStdIn As Long) As String
Dim lType As Long
Dim sBuffer As String
Dim lChars As Long
Dim lMode As Long
Dim lAvailChars As Long
Dim baBuffer(0 To 512) As Byte
Dim lEvents As Long
lType = GetFileType(hStdIn)
If lType = FILE_TYPE_PIPE Then
If PeekNamedPipe(hStdIn, ByVal 0, 0, 0, lAvailChars, 0) = 0 Then
Exit Function
End If
End If
If lType = FILE_TYPE_DISK Or lAvailChars > 0 Then
sBuffer = Space(IIf(lAvailChars > 0, lAvailChars, 512))
Call ReadFile(hStdIn, ByVal sBuffer, Len(sBuffer), lChars, 0)
ConsoleReadAvailable = Left$(sBuffer, lChars)
End If
If GetConsoleMode(hStdIn, lMode) <> 0 Then
Call SetConsoleMode(hStdIn, 0)
Do While PeekConsoleInput(hStdIn, baBuffer(0), 1, lEvents) <> 0
If lEvents = 0 Then
Exit Do
End If
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then ' baBuffer(4) = INPUT_RECORD.bKeyDown
sBuffer = Space(1)
Call ReadFile(hStdIn, ByVal sBuffer, Len(sBuffer), lChars, 0)
ConsoleReadAvailable = ConsoleReadAvailable & Left$(sBuffer, lChars)
Else
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
End If
Loop
Call SetConsoleMode(hStdIn, lMode)
End If
End Function
Public Function ConsolePrint(ByVal sText As String, ParamArray A() As Variant) As String
' Const FUNC_NAME As String = "ConsolePrint"
Dim lI As Long
Dim sArg As String
Dim baBuffer() As Byte
Dim dwDummy As Long
'--- format
For lI = UBound(A) To LBound(A) Step -1
sArg = Replace(A(lI), "%", ChrW$(&H101))
sText = Replace(sText, "%" & (lI - LBound(A) + 1), sArg)
Next
ConsolePrint = Replace(sText, ChrW$(&H101), "%")
'--- output
ReDim baBuffer(1 To Len(ConsolePrint)) As Byte
If CharToOemBuff(ConsolePrint, baBuffer(1), UBound(baBuffer)) Then
Call WriteFile(GetStdHandle(STD_OUTPUT_HANDLE), baBuffer(1), UBound(baBuffer), dwDummy, ByVal 0&)
End If
End Function
I am afraid that I haven't managed to get this to work as of yet, however someone else might be able to have a go. The ideas was to use asynchronous I/O with the console std input (I assume the idea of your app is to allow people to write directly into the console window, and read the input as it comes).
I separated off all the API stuff into a module (MAsynchConsole):
Option Explicit
Private Const GENERIC_READ As Long = &H80000000
Private Const GENERIC_WRITE As Long = &H40000000
Private Const OPEN_EXISTING As Long = 3&
Private Const FILE_FLAG_OVERLAPPED As Long = &H40000000
Private Const FILE_SHARE_READ As Long = &H1
Private Const FILE_FLAG_NO_BUFFERING As Long = &H20000000
Private Type OVERLAPPED
Internal As Long
InternalHigh As Long
OffsetOrPointer As Long
OffsetHigh As Long
hEvent As Long
End Type
Private Type OVERLAPPED_ENTRY
lpCompletionKey As Long
lpOverlapped As Long ' pointer to OVERLAPPED
Internal As Long
dwNumberOfBytesTransferred As Long
End Type
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function CancelIo Lib "Kernel32.dll" ( _
ByVal hFile As Long _
) As Long
Private Declare Function CreateFile Lib "Kernel32.dll" Alias "CreateFileW" ( _
ByVal lpFileName As Long, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareModen As Long, _
ByRef lpSecurityAttributes As Any, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long _
) As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function GetStdHandle Lib "kernel32" ( _
ByVal nStdHandle As Long _
) As Long
Private Declare Function ReadFile Lib "Kernel32.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As Long, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpNumberOfBytesRead As Long, _
ByRef lpOverlapped As OVERLAPPED _
) As Long
Private Declare Function ReadFileEx Lib "Kernel32.dll" ( _
ByVal hFile As Long, _
ByVal lpBuffer As Long, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpOverlapped As OVERLAPPED, _
ByVal lpCompletionRoutine As Long _
) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private m_hStdIn As Long
Private m_uOverlapped As OVERLAPPED
Private m_sUnicodeBuffer As String
Private m_oReadCallback As IReadCallback
Public Sub CloseConsole()
CancelIo m_hStdIn
Set m_oReadCallback = Nothing
m_sUnicodeBuffer = vbNullString
CloseHandle m_hStdIn
FreeConsole
End Sub
Private Sub FileIOCompletionRoutine( _
ByVal dwErrorCode As Long, _
ByVal dwNumberOfBytesTransfered As Long, _
ByRef uOverlapped As OVERLAPPED _
)
On Error GoTo ErrorHandler
m_oReadCallback.DataRead "FileIOCompletionRoutine"
m_oReadCallback.DataRead "dwErrorCode = " & CStr(dwErrorCode)
If dwErrorCode Then
MsgBox "Error = " & CStr(dwErrorCode)
CloseConsole
Exit Sub
End If
m_oReadCallback.DataRead "dwNumberOfBytesTransfered = " & CStr(dwNumberOfBytesTransfered)
m_oReadCallback.DataRead Left$(m_sUnicodeBuffer, dwNumberOfBytesTransfered)
Exit Sub
ErrorHandler:
'
End Sub
Public Sub OpenConsoleForInput(ByRef the_oReadCallback As IReadCallback)
Dim sFileName As String
On Error GoTo ErrorHandler
Set m_oReadCallback = the_oReadCallback
AllocConsole
'm_hStdIn = GetStdHandle(-10&)
sFileName = "CONIN$"
'm_hStdIn = CreateFile(StrPtr(sFileName), GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0&, 0&)
m_hStdIn = CreateFile(StrPtr(sFileName), GENERIC_READ Or GENERIC_WRITE, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, FILE_FLAG_OVERLAPPED, 0&)
m_oReadCallback.DataRead "m_hStdIn = " & CStr(m_hStdIn)
m_oReadCallback.DataRead "LastError = " & CStr(Err.LastDllError)
m_sUnicodeBuffer = Space$(8192)
Exit Sub
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
Public Sub Read()
Dim nRet As Long
Dim nBytesRead As Long
On Error GoTo ErrorHandler
m_oReadCallback.DataRead "About to call ReadFileExe"
'm_uOverlapped.OffsetHigh = 0&
'm_uOverlapped.OffsetOrPointer = 0&
'nRet = ReadFile(m_hStdIn, StrPtr(m_sUnicodeBuffer), LenB(m_sUnicodeBuffer), nBytesRead, m_uOverlapped)
nRet = ReadFileEx(m_hStdIn, StrPtr(m_sUnicodeBuffer), LenB(m_sUnicodeBuffer), m_uOverlapped, AddressOf FileIOCompletionRoutine)
m_oReadCallback.DataRead "nRet = " & CStr(nRet)
m_oReadCallback.DataRead "nBytesRead = " & CStr(nBytesRead)
If nRet = 0 Then
m_oReadCallback.DataRead "Err.LastDllError = " & CStr(Err.LastDllError)
Else
m_oReadCallback.DataRead StrConv(Left$(m_sUnicodeBuffer, nBytesRead), vbUnicode)
End If
Exit Sub
ErrorHandler:
Err.Raise Err.Number, Err.Source, Err.Description
End Sub
This relies on an interface (IReadCallback) to communicate with the main GUI.
Option Explicit
Public Sub DataRead(ByRef out_sData As String)
'
End Sub
This is my sample form (FAsynchConsoleTest) - which uses a Timer (Timer) and RichTextBox (txtStdIn):
Option Explicit
Implements IReadCallback
Private Sub Form_Load()
MAsynchConsole.OpenConsoleForInput Me
Timer.Enabled = True
End Sub
Private Sub Form_Unload(Cancel As Integer)
MAsynchConsole.CloseConsole
End Sub
Private Sub IReadCallback_DataRead(out_sData As String)
txtStdIn.SelStart = Len(txtStdIn.Text)
txtStdIn.SelText = vbNewLine & out_sData
End Sub
Private Sub mnuTimerOff_Click()
Timer.Enabled = False
End Sub
Private Sub mnuTimerOn_Click()
Timer.Enabled = True
End Sub
Private Sub Timer_Timer()
MAsynchConsole.Read
End Sub
Unfortunately, whilst CreateFile() using FILE_FLAG_OVERLAPPED should create a file handle that can be used with async I/O, and the handle seems valid, ReadFileEx() returns 0, and GetLastError is 6, which is:
//
// MessageId: ERROR_INVALID_HANDLE
//
// MessageText:
//
// The handle is invalid.
//
#define ERROR_INVALID_HANDLE 6L
The console, interestingly, is frozen whilst this all happens.
Anyone else have any ideas? The docs seem to suggest that if you use CreateFile() with a console device name, the parameter is ignored.
wqw's answer doesn't work for a form-based application, but the prototypes given there for Peek/ReadConsoleInput allow for one that does:
Private Declare Function AllocConsole Lib "kernel32" () As Long
Private Declare Function FreeConsole Lib "kernel32" () As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function PeekConsoleInput Lib "kernel32" Alias "PeekConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadConsoleInput Lib "kernel32" Alias "ReadConsoleInputA" (ByVal hConsoleInput As Long, lpBuffer As Any, ByVal nLength As Long, lpNumberOfEventsRead As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function SetConsoleMode Lib "kernel32" (ByVal hConsoleInput As Long, dwMode As Long) As Long
Private Const STD_INPUT_HANDLE As Long = -10& ' GetStdHandle()
Private Const KEY_EVENT As Long = 1 ' PeekConsoleInput()
Private Const ENABLE_PROCESSED_INPUT As Long = &H1 ' SetConsoleMode()
Private Const ENABLE_ECHO_INPUT As Long = &H4
Dim hStdIn As Long
Private Sub Form_Load()
AllocConsole
hStdIn = GetStdHandle(STD_INPUT_HANDLE)
SetConsoleMode hStdIn, ENABLE_PROCESSED_INPUT ' Or ENABLE_ECHO_INPUT ' uncomment to see the characters typed (for debugging)
Timer1.Enabled = True
Exit Sub
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
CloseHandle hStdIn
FreeConsole
End Sub
Private Sub Timer1_Timer()
Dim bytesRead As Long
Dim buffer As String
Dim baBuffer(0 To 512) As Byte
Dim lEvents As Long
PeekConsoleInput hStdIn, baBuffer(0), 1, lEvents
If lEvents > 0 Then
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then ' baBuffer(4) = INPUT_RECORD.bKeyDown
buffer = Space$(1)
Call ReadFile(hStdIn, ByVal buffer, Len(buffer), bytesRead, 0)
' buffer now contains one byte read from console
' Statements to process go here.
Else
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
End If
End If
End Sub
PeekNamedPipe, GetConsoleMode and PeekConsoleInput will all return zero if your app isn't a true VB6 console app (though all that may be required is linking with the console subsystem, e.g., "C:\Program Files\Microsoft Visual Studio\vb98\LINK.EXE" /EDIT /SUBSYSTEM:CONSOLE MyApp.exe, I haven't tested it that far). They still work, however, at least Peek... does.
It is key that only one byte is read on each pass, as reading what is in baBuffer is problematic past the first record (INPUT_RECORD structure), but one byte at a time non-blocking is better than none at all. For me, Timer1 is set at 100 ms, but a better setting might be 55 ms, the events time slice.
Also key is that ReadConsoleInput is non-blocking if there is an event present on stdin, not just a key to be read. Using it when the recognized event isn't a key, effectively clears the event, allowing the application to proceed. It is possible to use this to read the bytes from the buffer without using ReadFile at all:
PeekConsoleInput hStdIn, baBuffer(0), 1, lEvents
If lEvents > 0 Then
Call ReadConsoleInput(hStdIn, baBuffer(0), 1, lEvents)
If baBuffer(0) = KEY_EVENT And baBuffer(4) <> 0 Then
' Chr(baBuffer(14)) now produces the character typed...
This hasn't been tested for reading true human input, except in the simplest debugging during construction, but it does work and should allow most VB6 form-based apps to effectively use a console. Thank you wqw!
can anyone help me convert this to autoit, or at least tell me how i can do this in autoit?
Private Const DC_PAPERNAMES = 16
Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesW" ( _
ByVal lpDeviceName As Long, _
ByVal lpPort As Long, _
ByVal iIndex As Long, _
ByVal lpOutput As Long, _
ByVal lpDevMode As Long) As Long
Private Sub Form_Load()
Dim P As Printer
For Each P In Printers
lstPrinters.AddItem P.DeviceName
Next
End Sub
Private Sub lstPrinters_Click()
Dim P As Printer
Dim lngPapers As Long
Dim strPaperNames As String
Dim lngPaper As Long
Dim strPaperName As String
Dim lngActualLength As Long
Set P = Printers(lstPrinters.ListIndex)
lngPapers = DeviceCapabilities(StrPtr(P.DeviceName), _
StrPtr(P.Port), _
DC_PAPERNAMES, _
0, _
0)
strPaperNames = String$(lngPapers * 64, 0)
lngPapers = DeviceCapabilities(StrPtr(P.DeviceName), _
StrPtr(P.Port), _
DC_PAPERNAMES, _
StrPtr(strPaperNames), _
0)
lstPapers.Clear
For lngPaper = 0 To lngPapers - 1
strPaperName = Mid$(strPaperNames, 64 * lngPaper + 1, 64)
lngActualLength = InStr(strPaperName, vbNullChar) - 1
If lngActualLength > 1 Then strPaperName = Left$(strPaperName, lngActualLength)
lstPapers.AddItem strPaperName
Next
End Sub
Here's a thread where someone is trying to do the exact same thing: http://www.autoitscript.com/forum/topic/25857-need-a-help-from-the-pros-on-making-api-call/
There is also a guide which will help you write windows API calls: http://www.autoitscript.com/forum/topic/7072-dllcall/ it deals mainly with finding the correct type conversion which is the only hard part.