How to get current HDD type? - vb6

I've found a way to get hdd serial no in vb6. But it needs to select an option from
primary master
primary slave
secondary master
secondary slave
But I want to auto select an option. The auto select logic is,
suppose I've 4 HDD with the above 4 types. And the logic will select the hdd type, on which the current system is loaded.
I really have no idea how to detect the current system is on which HDD type. Please help.
Here is the class that I use to select HDD serial no. HDSN CLASS

The code below should help:
Option Explicit
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const IOCTL_VOLUME_BASE As Long = 86 ' Asc("V")
Private Const METHOD_BUFFERED As Long = 0
Private Const FILE_READ_ACCESS As Long = 1
Private Const FILE_ANY_ACCESS As Long = 0
'DEFINE IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS CTL_CODE(IOCTL_VOLUME_BASE, 0, METHOD_BUFFERED, FILE_ANY_ACCESS)
Private Const IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS = (((IOCTL_VOLUME_BASE) * (2& ^ 16&)) Or ((FILE_ANY_ACCESS) * (2& ^ 14&)) Or ((0&) * (2& ^ 2&)) Or (METHOD_BUFFERED))
Private Type DISK_EXTENT
DiskNumber As Long
StartingOffset As Currency
ExtentLength As Currency
End Type
Private Type VOLUME_DISK_EXTENTS
NumberOfDiskExtents As Currency
Extents(1 To 4) As DISK_EXTENT
End Type
Private Declare Function CreateFile _
Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle _
Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetWindowsDirectory Lib "Kernel32.dll" Alias "GetWindowsDirectoryW" ( _
ByVal lpBuffer As Long, _
ByVal uSize As Long _
) As Long
Private Declare Function DeviceIoControlNoInput _
Lib "kernel32" Alias "DeviceIoControl" _
(ByVal hDevice As Long, _
ByVal dwIoControlCode As Long, _
ByVal lpInBuffer As Long, _
ByVal nInBufferSize As Long, _
ByRef lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
ByRef lpBytesReturned As Long, _
ByVal lpOverlapped As Long) As Long
' Return the index of the physical drive from which we've booted into Windows.
Public Function GetBootPhysicalDrive() As Long
Dim sWindowsPath As String
Dim nRet As Long
Dim sDevicePath As String
Dim hLogicalBootDrive As Long
Dim sVolumeDevice As String
Dim uVolumeDiskExtents As VOLUME_DISK_EXTENTS
Dim nBytesReturned As Long
' Allocate space and retrieve the windows directory.
sWindowsPath = Space$(64)
nRet = GetWindowsDirectory(StrPtr(sWindowsPath), 64)
' This gives us the volume that Windows is on. Open it.
sVolumeDevice = "\\.\" & Left$(sWindowsPath, 2)
hLogicalBootDrive = CreateFile(sVolumeDevice, GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, 0&, OPEN_EXISTING, 0&, 0&)
' Find out information about this volume.
nRet = DeviceIoControlNoInput(hLogicalBootDrive, IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, 0&, 0&, uVolumeDiskExtents, LenB(uVolumeDiskExtents), nBytesReturned, 0&)
If nRet = 0 Then
' Something went wrong. Return error value.
GetBootPhysicalDrive = -1
Else
' This is the physical disk number.
GetBootPhysicalDrive = uVolumeDiskExtents.Extents(1).DiskNumber
End If
' Close volume.
CloseHandle hLogicalBootDrive
End Function

Using theAbove Solution of Mark Bertenshaw I wrote the following in a module and just called the GetDiskSerialNumber function to get serial of the HDD from which the current system is Booted. Here is my module code:
Option Explicit
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const OPEN_EXISTING = 3
Private Const IOCTL_VOLUME_BASE As Long = 86 ' Asc("V")
Private Const METHOD_BUFFERED As Long = 0
Private Const FILE_READ_ACCESS As Long = 1
Private Const FILE_ANY_ACCESS As Long = 0
'DEFINE IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS CTL_CODE(IOCTL_VOLUME_BASE, 0, METHOD_BUFFERED, FILE_ANY_ACCESS)
Private Const IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS = (((IOCTL_VOLUME_BASE) * (2& ^ 16&)) Or ((FILE_ANY_ACCESS) * (2& ^ 14&)) Or ((0&) * (2& ^ 2&)) Or (METHOD_BUFFERED))
Private Type DISK_EXTENT
DiskNumber As Long
StartingOffset As Currency
ExtentLength As Currency
End Type
Private Type VOLUME_DISK_EXTENTS
NumberOfDiskExtents As Currency
Extents(1 To 4) As DISK_EXTENT
End Type
Private Declare Function CreateFile _
Lib "kernel32" Alias "CreateFileA" _
(ByVal lpFileName As String, _
ByVal dwDesiredAccess As Long, _
ByVal dwShareMode As Long, _
ByVal lpSecurityAttributes As Long, _
ByVal dwCreationDisposition As Long, _
ByVal dwFlagsAndAttributes As Long, _
ByVal hTemplateFile As Long) As Long
Private Declare Function CloseHandle _
Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function GetWindowsDirectory Lib "Kernel32.dll" Alias "GetWindowsDirectoryW" ( _
ByVal lpBuffer As Long, _
ByVal uSize As Long _
) As Long
Private Declare Function DeviceIoControlNoInput _
Lib "kernel32" Alias "DeviceIoControl" _
(ByVal hDevice As Long, _
ByVal dwIoControlCode As Long, _
ByVal lpInBuffer As Long, _
ByVal nInBufferSize As Long, _
ByRef lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
ByRef lpBytesReturned As Long, _
ByVal lpOverlapped As Long) As Long
' Return the index of the physical drive from which we've booted into Windows.
Public Function GetBootPhysicalDrive() As Long
Dim sWindowsPath As String
Dim nRet As Long
Dim sDevicePath As String
Dim hLogicalBootDrive As Long
Dim sVolumeDevice As String
Dim uVolumeDiskExtents As VOLUME_DISK_EXTENTS
Dim nBytesReturned As Long
' Allocate space and retrieve the windows directory.
sWindowsPath = Space$(64)
nRet = GetWindowsDirectory(StrPtr(sWindowsPath), 64)
' This gives us the volume that Windows is on. Open it.
sVolumeDevice = "\\.\" & Left$(sWindowsPath, 2)
hLogicalBootDrive = CreateFile(sVolumeDevice, GENERIC_READ + GENERIC_WRITE, FILE_SHARE_READ + FILE_SHARE_WRITE, 0&, OPEN_EXISTING, 0&, 0&)
' Find out information about this volume.
nRet = DeviceIoControlNoInput(hLogicalBootDrive, IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS, 0&, 0&, uVolumeDiskExtents, LenB(uVolumeDiskExtents), nBytesReturned, 0&)
If nRet = 0 Then
' Something went wrong. Return error value.
GetBootPhysicalDrive = -1
Else
' This is the physical disk number.
GetBootPhysicalDrive = uVolumeDiskExtents.Extents(1).DiskNumber
End If
' Close volume.
CloseHandle hLogicalBootDrive
End Function
Public Function GetDiskSerialNumber() As String
Dim wmiObject As Object
Dim obj As Object
Set wmiObject = GetObject("WinMgmts:")
For Each obj In wmiObject.InstancesOf("Win32_PhysicalMedia")
If obj.Tag = "\\.\PHYSICALDRIVE" + CStr(GetBootPhysicalDrive) Then GetDiskSerialNumber = obj.Tag + " : " + obj.SerialNumber
Next obj
End Function
Many thanks to Mark Bertenshaw.

Related

Run an external process without freezing main UI in vb6

I have VB6 Application which depends upon another EXE file which is invoked via CreateProcess from lib kernel32 and pipe connection to fetch the output.
How can I invoke it asynchronously in my main form without freezing the UI?
Currently, Form1 Freezes when the external application takes a longer time to respond.
Attribute VB_Name = "CmdOutput"
Option Explicit
''''''''''''''''''''''''''''''''''''''''
' Joacim Andersson, Brixoft Software
' http://www.brixoft.net
''''''''''''''''''''''''''''''''''''''''
' STARTUPINFO flags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100
' ShowWindow flags
Private Const SW_HIDE = 0
' DuplicateHandle flags
Private Const DUPLICATE_CLOSE_SOURCE = &H1
Private Const DUPLICATE_SAME_ACCESS = &H2
' Error codes
Private Const ERROR_BROKEN_PIPE = 109
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Declare Function CreatePipe _
Lib "kernel32" ( _
phReadPipe As Long, _
phWritePipe As Long, _
lpPipeAttributes As Any, _
ByVal nSize As Long) As Long
Private Declare Function ReadFile _
Lib "kernel32" ( _
ByVal hFile As Long, _
lpBuffer As Any, _
ByVal nNumberOfBytesToRead As Long, _
lpNumberOfBytesRead As Long, _
lpOverlapped As Any) As Long
Private Declare Function CreateProcess _
Lib "kernel32" Alias "CreateProcessA" ( _
ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
lpProcessAttributes As Any, _
lpThreadAttributes As Any, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
lpEnvironment As Any, _
ByVal lpCurrentDriectory As String, _
lpStartupInfo As STARTUPINFO, _
lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function GetCurrentProcess _
Lib "kernel32" () As Long
Private Declare Function DuplicateHandle _
Lib "kernel32" ( _
ByVal hSourceProcessHandle As Long, _
ByVal hSourceHandle As Long, _
ByVal hTargetProcessHandle As Long, _
lpTargetHandle As Long, _
ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, _
ByVal dwOptions As Long) As Long
Private Declare Function CloseHandle _
Lib "kernel32" ( _
ByVal hObject As Long) As Long
Private Declare Function OemToCharBuff _
Lib "user32" Alias "OemToCharBuffA" ( _
lpszSrc As Any, _
ByVal lpszDst As String, _
ByVal cchDstLength As Long) As Long
' Function GetCommandOutput
'
' sCommandLine: [in] Command line to launch
' blnStdOut [in,opt] True (defualt) to capture output to STDOUT
' blnStdErr [in,opt] True to capture output to STDERR. False is default.
' blnOEMConvert: [in,opt] True (default) to convert DOS characters to Windows, False to skip conversion
'
' Returns: String with STDOUT and/or STDERR output
'
Public Function GetCommandOutput( _
sCommandLine As String, _
Optional blnStdOut As Boolean = True, _
Optional blnStdErr As Boolean = False, _
Optional blnOEMConvert As Boolean = True _
) As String
Dim hPipeRead As Long, hPipeWrite1 As Long, hPipeWrite2 As Long
Dim hCurProcess As Long
Dim sa As SECURITY_ATTRIBUTES
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
Dim baOutput() As Byte
Dim sNewOutput As String
Dim lBytesRead As Long
Dim fTwoHandles As Boolean
Dim lRet As Long
Const BUFSIZE = 1024 ' pipe buffer size
' At least one of them should be True, otherwise there's no point in calling the function
If (Not blnStdOut) And (Not blnStdErr) Then
Err.Raise 5 ' Invalid Procedure call or Argument
End If
' If both are true, we need two write handles. If not, one is enough.
fTwoHandles = blnStdOut And blnStdErr
ReDim baOutput(BUFSIZE - 1) As Byte
With sa
.nLength = Len(sa)
.bInheritHandle = 1 ' get inheritable pipe handles
End With
If CreatePipe(hPipeRead, hPipeWrite1, sa, BUFSIZE) = 0 Then
Exit Function
End If
hCurProcess = GetCurrentProcess()
' Replace our inheritable read handle with an non-inheritable. Not that it
' seems to be necessary in this case, but the docs say we should.
Call DuplicateHandle(hCurProcess, hPipeRead, hCurProcess, hPipeRead, 0&, _
0&, DUPLICATE_SAME_ACCESS Or DUPLICATE_CLOSE_SOURCE)
' If both STDOUT and STDERR should be redirected, get an extra handle.
If fTwoHandles Then
Call DuplicateHandle(hCurProcess, hPipeWrite1, hCurProcess, hPipeWrite2, 0&, _
1&, DUPLICATE_SAME_ACCESS)
End If
With si
.cb = Len(si)
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.wShowWindow = SW_HIDE ' hide the window
If fTwoHandles Then
.hStdOutput = hPipeWrite1
.hStdError = hPipeWrite2
ElseIf blnStdOut Then
.hStdOutput = hPipeWrite1
Else
.hStdError = hPipeWrite1
End If
End With
If CreateProcess(vbNullString, sCommandLine, ByVal 0&, ByVal 0&, 1, 0&, _
ByVal 0&, vbNullString, si, pi) Then
' Close thread handle - we don't need it
Call CloseHandle(pi.hThread)
' Also close our handle(s) to the write end of the pipe. This is important, since
' ReadFile will *not* return until all write handles are closed or the buffer is full.
Call CloseHandle(hPipeWrite1)
hPipeWrite1 = 0
If hPipeWrite2 Then
Call CloseHandle(hPipeWrite2)
hPipeWrite2 = 0
End If
Do
' Add a DoEvents to allow more data to be written to the buffer for each call.
' This results in fewer, larger chunks to be read.
'DoEvents
If ReadFile(hPipeRead, baOutput(0), BUFSIZE, lBytesRead, ByVal 0&) = 0 Then
Exit Do
End If
If blnOEMConvert Then
' convert from "DOS" to "Windows" characters
sNewOutput = String$(lBytesRead, 0)
Call OemToCharBuff(baOutput(0), sNewOutput, lBytesRead)
Else
' perform no conversion (except to Unicode)
sNewOutput = Left$(StrConv(baOutput(), vbUnicode), lBytesRead)
End If
GetCommandOutput = GetCommandOutput & sNewOutput
' If you are executing an application that outputs data during a long time,
' and don't want to lock up your application, it might be a better idea to
' wrap this code in a class module in an ActiveX EXE and execute it asynchronously.
' Then you can raise an event here each time more data is available.
'RaiseEvent OutputAvailabele(sNewOutput)
Loop
' When the process terminates successfully, Err.LastDllError will be
' ERROR_BROKEN_PIPE (109). Other values indicates an error.
Call CloseHandle(pi.hProcess)
Else
GetCommandOutput = "Failed to create process, check the path of the command line."
End If
' clean up
Call CloseHandle(hPipeRead)
If hPipeWrite1 Then
Call CloseHandle(hPipeWrite1)
End If
If hPipeWrite2 Then
Call CloseHandle(hPipeWrite2)
End If
End Function
As the code comment in the code you linked suggests, you could pull this out-of-process into an ActiveX exe to wrap this.
To keep it in-process, you would need to use MsgWaitForMultipleObjects (https://learn.microsoft.com/en-us/windows/desktop/api/winuser/nf-winuser-msgwaitformultipleobjects).
Google located a VB6 sample: http://www.freevbcode.com/ShowCode.asp?ID=4322
The idea here is that the function will wait until either data is available on the handle OR there is a UI event (in which case DoEvents is used to dispatch).

Deleting a registry subkey in Visual Basic 6

I am working on an application that deletes registry subkeys, but I can't seem to find a solution for that problem... I know it is easier to do this with VB.NET but I want to know how to get this done using VB6
What I have tried...
DeleteRegKey HKEY_CURRENT_USER\Software\Test.
Take this for what it's worth. I haven't used this in a few years so it has not been tested on Windows 8, and I'm not at all sure about Windows 7 either. I pulled this from a utility class so hopefully I got all the declarations.
Private Const KEY_NOTIFY = &H10
Private Const KEY_QUERY_VALUE = &H1
Private Const KEY_CREATE_LINK = &H20
Private Const KEY_CREATE_SUB_KEY = &H4
Private Const KEY_ENUMERATE_SUB_KEYS = &H8
Private Const KEY_EVENT = &H1
Private Const KEY_SET_VALUE = &H2
Private Const KEY_ALL_ACCESS = ((STANDARD_RIGHTS_ALL Or KEY_QUERY_VALUE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY Or KEY_CREATE_LINK) And (Not SYNCHRONIZE))
Private Const KEY_READ = ((STANDARD_RIGHTS_READ Or KEY_QUERY_VALUE Or KEY_ENUMERATE_SUB_KEYS Or KEY_NOTIFY) And (Not SYNCHRONIZE))
Private Const KEY_EXECUTE = ((KEY_READ) And (Not SYNCHRONIZE))
Private Const KEY_WRITE = ((STANDARD_RIGHTS_WRITE Or KEY_SET_VALUE Or KEY_CREATE_SUB_KEY) And (Not SYNCHRONIZE))
Public Enum RegRootKey
HKEY_CLASSES_ROOT = &H80000000
HKEY_CURRENT_CONFIG = &H80000005
HKEY_CURRENT_USER = &H80000001
HKEY_DYN_DATA = &H80000006
HKEY_LOCAL_MACHINE = &H80000002
HKEY_PERFORMANCE_DATA = &H80000004
HKEY_USERS = &H80000003
End Enum
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegCreateKeyEx Lib "advapi32.dll" Alias "RegCreateKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal Reserved As Long, ByVal lpClass As String, ByVal dwOptions As Long, ByVal samDesired As Long, ByVal lpSecurityAttributes As Long, phkResult As Long, lpdwDisposition As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegEnumKeyEx Lib "advapi32.dll" Alias "RegEnumKeyExA" (ByVal hKey As Long, ByVal dwIndex As Long, ByVal lpName As String, lpcbName As Long, ByVal lpReserved As Long, ByVal lpClass As String, lpcbClass As Long, lpftLastWriteTime As FILETIME) As Long
Public Function DeleteRegKey(ByVal hKeyRoot As RegRootKey, ByVal hKeySubKey As String, ByVal KeyName As String) As Boolean
Dim lngRst As Long
Dim hKeyReturn As Long
Dim hKeyDisposition As Long
Dim strSubKeys() As String
Dim lngSubKeyCount As Long
Dim i As Long
On Error GoTo errDeleteRegKey
lngRst = RegOpenKeyEx(hKeyRoot, hKeySubKey, ByVal 0&, KEY_READ + KEY_WRITE, hKeyReturn)
If lngRst = 0 Then 'we can continue
' first need to find and delete sub keys
lngSubKeyCount = EnumSubKeys(hKeyRoot, hKeySubKey & "\" & KeyName, strSubKeys)
' recursively call this function to delete all sub keys
For i = 0 To lngSubKeyCount - 1
Call DeleteRegKey(hKeyRoot, hKeySubKey & "\" & KeyName, strSubKeys(i))
Next i
' finally down (up?) to the parent key
lngRst = RegDeleteKey(hKeyReturn, ByVal KeyName)
'close the handle
If hKeyReturn <> 0 Then
lngRst = RegCloseKey(hKeyReturn)
hKeyReturn = 0
End If
End If
If lngRst = 0 Then '0 = success
DeleteRegKey = True
Else
Err.Raise lngRst, App.EXEName, FormatClassError(lngRst)
End If
Exit Function
errDeleteRegKey:
'close the handle
If hKeyReturn <> 0 Then
lngRst = RegCloseKey(hKeyReturn)
hKeyReturn = 0
End If
Err.Raise Err.Number, Err.Source & ":DeleteRegKey", Err.Description
End Function
Add this function to a form, module, or class then
Call DeleteRegKey(HKEY_CURRENT_USER, "Software", "Test")
' or
DeleteRegKey HKEY_CURRENT_USER, "Software", "Test"
' or
Dim blnRst as Boolean
blnRst = DeleteRegKey(HKEY_CURRENT_USER, "Software", "Test")

Calling FindMimeFromData from VB6

Public Declare Function FindMimeFromData Lib "urlmon.dll" ( _
ByVal pbc As Long, _
ByVal pwzUrl As String, _
pBuffer As Any, _
cbSize As Long, _
ByVal pwzMimeProposed As String, _
dwMimeFlags As Long, _
ppwzMimeOut As Long, _
dwReserved As Long) As Long
In VB6, I can't seem to figure out how to pass the pBuffer parameter of the first 256 characters of a file. When I try to use a Dim buffer() As Byte and populate that, and pass it as the parameter, it throws the error of wrong param even those of the definition is Any.
I've tried to use this example, but passing the entire file name from a file system doesn't seem to work. so I have to try sending it like the C# example with the first 256 bytes of the file.
Can anyone help?
I played around with the following Declare, and built up some code around it. There are two wrappers, GetMimeTypeFromUrl() and GetMimeTypeFromData(). I found the former only worked when you used simple URLs such as http://host.com/file.xtn. You may have to play around with the other flags.
However, the other wrapper function sounds like what you need.
Note that all the string pointers are declared As Long, and I pass the underlying UTF-16 VB string as a pointer using StrPtr().
Also note that you have to use CoTaskMemFree() to free the output ppwzMimeOut string pointer, otherwise you will leak memory.
Option Explicit
Private Declare Function FindMimeFromData Lib "Urlmon.dll" ( _
ByVal pBC As Long, _
ByVal pwzUrl As Long, _
ByVal pBuffer As Long, _
ByVal cbSize As Long, _
ByVal pwzMimeProposed As Long, _
ByVal dwMimeFlags As Long, _
ByRef ppwzMimeOut As Long, _
ByVal dwReserved As Long _
) As Long
'
' Flags:
'
' Default
Private Const FMFD_DEFAULT As Long = &H0
' Treat the specified pwzUrl as a file name.
Private Const FMFD_URLASFILENAME As Long = &H1
' Internet Explorer 6 for Windows XP SP2 and later. Use MIME-type detection even if FEATURE_MIME_SNIFFING is detected. Usually, this feature control key would disable MIME-type detection.
Private Const FMFD_ENABLEMIMESNIFFING As Long = &H2
' Internet Explorer 6 for Windows XP SP2 and later. Perform MIME-type detection if "text/plain" is proposed, even if data sniffing is otherwise disabled. Plain text may be converted to text/html if HTML tags are detected.
Private Const FMFD_IGNOREMIMETEXTPLAIN As Long = &H4
' Internet Explorer 8. Use the authoritative MIME type specified in pwzMimeProposed. Unless FMFD_IGNOREMIMETEXTPLAIN is specified, no data sniffing is performed.
Private Const FMFD_SERVERMIME As Long = &H8
' Internet Explorer 9. Do not perform detection if "text/plain" is specified in pwzMimeProposed.
Private Const FMFD_RESPECTTEXTPLAIN As Long = &H10
' Internet Explorer 9. Returns image/png and image/jpeg instead of image/x-png and image/pjpeg.
Private Const FMFD_RETURNUPDATEDIMGMIMES As Long = &H20
'
' Return values:
'
' The operation completed successfully.
Private Const S_OK As Long = 0&
' The operation failed.
Private Const E_FAIL As Long = &H80000008
' One or more arguments are invalid.
Private Const E_INVALIDARG As Long = &H80000003
' There is insufficient memory to complete the operation.
Private Const E_OUTOFMEMORY As Long = &H80000002
'
' String routines
'
Private Declare Function lstrlen Lib "Kernel32.dll" Alias "lstrlenW" ( _
ByVal lpString As Long _
) As Long
Private Declare Sub CopyMemory Lib "Kernel32.dll" Alias "RtlMoveMemory" (ByVal pDest As Long, ByVal pSrc As Long, ByVal nCount As Long)
Private Declare Sub CoTaskMemFree Lib "Ole32.dll" ( _
ByVal pv As Long _
)
Private Function CopyPointerToString(ByVal in_pString As Long) As String
Dim nLen As Long
' Need to copy the data at the string pointer to a VB string buffer.
' Get the length of the string, allocate space, and copy to that buffer.
nLen = lstrlen(in_pString)
CopyPointerToString = Space$(nLen)
CopyMemory StrPtr(CopyPointerToString), in_pString, nLen * 2
End Function
Private Function GetMimeTypeFromUrl(ByRef in_sUrl As String, ByRef in_sProposedMimeType As String) As String
Dim pMimeTypeOut As Long
Dim nRet As Long
nRet = FindMimeFromData(0&, StrPtr(in_sUrl), 0&, 0&, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromUrl = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Function GetMimeTypeFromData(ByRef in_abytData() As Byte, ByRef in_sProposedMimeType As String) As String
Dim nLBound As Long
Dim nUBound As Long
Dim pMimeTypeOut As Long
Dim nRet As Long
nLBound = LBound(in_abytData)
nUBound = UBound(in_abytData)
nRet = FindMimeFromData(0&, 0&, VarPtr(in_abytData(nLBound)), nUBound - nLBound + 1, StrPtr(in_sProposedMimeType), FMFD_DEFAULT, pMimeTypeOut, 0&)
If nRet = S_OK Then
GetMimeTypeFromData = CopyPointerToString(pMimeTypeOut)
CoTaskMemFree pMimeTypeOut
Else
Err.Raise nRet
End If
End Function
Private Sub Command1_Click()
Dim sRet As String
Dim abytData() As Byte
sRet = GetMimeTypeFromUrl("http://msdn.microsoft.com/en-us/library/ms775107%28v=vs.85%29.aspx", vbNullString)
Debug.Print sRet
abytData() = StrConv("<HTML><HEAD><TITLE>Stuff</TITLE></HEAD><BODY>Test me</BODY></HTML>", vbFromUnicode)
sRet = GetMimeTypeFromData(abytData(), vbNullString)
Debug.Print sRet
End Sub

Non-blocking read of stdin?

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!

Redirect input / output console cmd

I have the following code of my authorship using "Pipes" to create a console, my question is is possible to use an alternative to the "Pipes"?
Greetings: D
' ****************************************************************************************************************************** '
'
' --- Autor: Jhonjhon_123 (Jhon Jairo Pro Developer)
' --- VersiĆ³n: 1.0
' --- DescripciĆ³n: Shell a nivel local en windows
' --- Fallos y Mejoras: MSN; j.j.g.p#hotmail.com
' --- Licencia: GNU General Public License
'
' ****************************************************************************************************************************** '
Option Explicit
Private Declare Function PeekNamedPipe Lib "kernel32" (ByVal hNamedPipe As Long, lpBuffer As Any, ByVal nBufferSize As Long, lpBytesRead As Long, lpTotalBytesAvail As Long, 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, lpOverlapped As Any) As Long
Private Declare Function WriteFile Lib "kernel32" (ByVal hFile As Long, lpBuffer As Any, ByVal nNumberOfBytesToWrite As Long, lpNumberOfBytesWritten As Long, ByVal lpOverlapped As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" (phReadPipe As Long, phWritePipe As Long, lpPipeAttributes As Any, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, lpProcessAttributes As Any, lpThreadAttributes As Any, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, lpEnvironment As Any, ByVal lpCurrentDriectory As String, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function DuplicateHandle Lib "kernel32" (ByVal hSourceProcessHandle As Long, ByVal hSourceHandle As Long, ByVal hTargetProcessHandle As Long, lpTargetHandle As Long, ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwOptions As Long) As Long
Private Declare Function GetCurrentProcess Lib "kernel32" () As Long
Private Const STARTF_USESTDHANDLES As Long = &H100
Private Const STARTF_USESHOWWINDOW As Long = &H1
Private Const DUPLICATE_SAME_ACCESS As Long = &H2
Private Const NORMAL_PRIORITY_CLASS As Long = &H20
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadId As Long
End Type
Dim lHInput As Long
Dim lHOutput As Long
Dim lCmdID As Long
Public Sub StopShell()
If lHInput > 0 Then Call CloseHandle(lHInput)
If lHOutput > 0 Then Call CloseHandle(lHOutput)
If lCmdID > 0 Then Call TerminateProcess(lCmdID, ByVal 0&): Call CloseHandle(lCmdID)
End Sub
Public Function GetOutTextShell(sOut As String) As Boolean
Dim bBuffer() As Byte
Dim lLen As Long
Dim bRes As Boolean
Dim lLenBuff As Long
bRes = CBool(PeekNamedPipe(lHOutput, 0&, 0&, 0&, lLen, 0&))
If Not bRes Then Exit Function
If lLen <= 0 Then Exit Function
ReDim bBuffer(lLen)
If ReadFile(lHOutput, bBuffer(0), lLen, lLenBuff, ByVal 0&) = 0 Then Exit Function
sOut = Left(StrConv(bBuffer, vbUnicode), lLenBuff)
GetOutTextShell = True
End Function
Public Sub SendToShell(sCMD As String)
Dim sBytes() As Byte
Dim BytesWritten As Long
If lHInput = 0 Then Exit Sub
sCMD = sCMD & vbNewLine
sBytes = StrConv(sCMD, vbFromUnicode)
If WriteFile(lHInput, ByVal sCMD, Len(sCMD), BytesWritten, 0&) = 0 Then
Exit Sub
End If
End Sub
Public Function StartShell() As Boolean
On Error GoTo Error
Dim tSecurityAttributes As SECURITY_ATTRIBUTES
Dim tStartInfo As STARTUPINFO
Dim tProcessInfo As PROCESS_INFORMATION
Dim lCurrentID As Long
lCurrentID = GetCurrentProcess()
With tStartInfo
.cb = Len(tStartInfo)
.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
End With
With tSecurityAttributes
.nLength = Len(tSecurityAttributes)
.bInheritHandle = 1
End With
If CreatePipe(lHOutput, tStartInfo.hStdOutput, tSecurityAttributes, 0) = 0 Then
GoTo Error
End If
If CreatePipe(tStartInfo.hStdInput, lHInput, tSecurityAttributes, 0) = 0 Then
GoTo Error
End If
If DuplicateHandle(lCurrentID, tStartInfo.hStdOutput, lCurrentID, tStartInfo.hStdError, 0&, True, DUPLICATE_SAME_ACCESS) = 0 Then
GoTo Error
End If
If CreateProcess(vbNullString, "cmd", tSecurityAttributes, tSecurityAttributes, 1, NORMAL_PRIORITY_CLASS, ByVal 0&, vbNullString, tStartInfo, tProcessInfo) = 0 Then
GoTo Error
End If
With tProcessInfo
Call CloseHandle(.hThread)
lCmdID = .hProcess
If .dwProcessID > 0 And .hProcess > 0 Then
StartShell = True
Else
GoTo Error
End If
End With
Exit Function
Error:
Call StopShell
StartShell = False
End Function
Code Full Example: http://www.multiupload.com/1NVDU8LZSP

Resources