Create User Control Object at runtime Without form
Hi, I'm trying to load a user control at runtime. I am not using any form, everything will be done using a Module and classes.
I can do this if I have an ActiveX control or reference, but can't seem to figure out how to do this with a user control
The Below works fine, but I need to also have ShellPipe.ctl loaded as I will be running commands via cmd at set intervals.
Code:
Dim TimerAutomate As ccrpCountdown
Set TimerAutomate = New ccrpCountdown
TimerAutomate.Duration = 10000
TimerAutomate.Enabled = True
Do
Doevents
Loop While TimerAutomate.Enabled = True
msgbox "Timer has finished counting down"
Thanks in advance
Update: I managed to Declare ShellPipeMain as ShellPipe, and in my Class, set Public WithEvents ShellPipeMain As ShellPipe
Class:
Code:
Public WithEvents TimerAutomate As ccrpTimers6.ccrpCountdown
Public WithEvents ShellPipeMain As ShellPipe
Module:
Code:
Public ShellPipeMain As ShellPipe
Not I get an error: Object variable or With block variable not set
Is there something else I need to do/declare?
Re: Create User Control Object at runtime Without form
You should upload a complete test project. So that others can modify the code directly.
1 Attachment(s)
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
xiaoyao
You should upload a complete test project. So that others can modify the code directly.
Sure, here you go
Re: Create User Control Object at runtime Without form
An UserControl by definition is a control, and a control is a visual element that needs a window to show in. The window is a form, so a control needs a form, and a UserControl also needs a form to sit on.
If you need an UserControl without a form, then you don't need an UserControl, but you need a class module.
A class module can do exactly all that an UserControl can do, but without any visual element, thus not requiring a form.
Re: Create User Control Object at runtime Without form
Your ShellPipe-Control (which is a Windowless-Ctl, and "invisible at runtime") -
can be converted into a normal Class easily as well:
Code:
Option Explicit
'
'ShellPipe (version 3)
'=========
'
'Run a console program and communicate with it via the
'Standard I/O streams.
'
'Both StdOut and StdErr are piped to one stream reader here.
'
'NOTES
'-----
'
'Because overlapped I/O isn't available under Win9x, this
'control uses a Timer control and a "polling" model to
'process pipe reads and writes and detect process termination.
'
'Requires SmartBuffer class.
'
'ENUMS
'-----
'
'SP_RESULTS
' SP_SUCCESS = 0
' SP_CREATEPIPEFAILED = &H80042B00
' SP_CREATEPROCFAILED = &H80042B01
'
'SPEOF_TYPES
' SPEOF_NORMAL = 0
' SPEOF_BROKEN_PIPE = 109
'
'
'PROPERTIES
'----------
'
'Active Boolean, read-only.
'
' Returns a result telling whether or not the child
' process is currently active.
'
' If NOT, then FinishChild() should be called as
' soon as possible.
'
'HasLine Boolean, read-only.
'
' True if we have a buffered "line" from the child
' process buffered.
'
' Set appropriately by every call to GetData() and
' GetLine() as well as by DataArrival events so it
' is possible to loop on this property to retrieve
' lines of text.
'
'Length Long, read-only.
'
' Number of characters currently buffered from the
' child process.
'
'PollInterval Long, read/write. Default: 250.
'
' This is a value (in milliseconds) used to:
'
' * Look for data or EOF from the child process'
' OutPipe.
' * Send pending blocked output to the child
' process' InPipe.
' * Check for process termination.
'
'METHODS
'-------
'
'ClosePipe()
'
' Closes our output pipe to the child process' StdIn.
'
'FinishChild(Optional ByVal WaitMs As Long = 500, _
' Optional ByVal KillReturnCode = 666) As Long
'
' MUST be called after child process terminates
' (ChildFinished event is raised), or may be called
' to FORCE (kill) the process.
'
' Waits WaitMs milliseconds for the child process to
' complete. If the child doesn't finish, terminates
' the child process with KillReturnCode. Caller
' may check for KillReturnCode value to determine
' that the process was killed.
'
' Closes pipes and cleans up the process.
'
' Returns: Child process' return code. Returns -1
' if the child has already been "finished."
'
'GetData(Optional ByVal MaxLen As Long = -1) As String
'
' Get data from child process' OutPipe.
'
' Returns MaxLen characters (or as many as are
' available). When MaxLen is -1 returns all
' available characters. May return an empty string.
'
'GetLine() As String
'
' Get a line of data from child process' OutPipe.
'
' Should only be called when HasLine is True.
' May return an empty string.
'
' A "line" is defined as text delimited by a CR, but
' if CRLF occurs the LFs are consumed as well. Both
' conventions are used by StdIO programs.
'
'Interrupt(Optional ByVal Break As Boolean = False)
'
' Attempts to interrupt the child process. This is
' only effective if the parent has a console window,
' which will be inherited by the child. Note that
' the parent will also be interrupted, so a null
' handler must be installed or else the parent will
' also be terminated!
'
' Break sends a CTRL-C signal when False or a
' CTRL-Break signal when True.
'
'Run (ByVal CommandLine As String, _
' Optional ByVal CurrentDir As String = vbNullString) _
' As SP_RESULTS
'
' Runs the command line provided via CommandLine with
' standard streams redirected to the ShellPipe control.
' If the caller doesn't supply a CurrentDir string,
' the child process inherits the caller's current
' directory.
'
' Returns: SP_SUCCESS
' SP_CREATEPIPEFAILED
' SP_CREATEPROCFAILED
'
'SendData(ByVal Data As String)
'
' Pipes Data to child process' StdIn.
'
'SendLine(ByVal Line As String,
' Optional ByVal UseLFs As Boolean = True)
'
' Pipes Line and CR or CRLF to child process' StdIn.
'
'EVENTS
'------
'
'ChildFinished()
'
' Signals that the child process has completed. The
' program should call the FinishChild() method as
' soon as possible to clean up process handles and
' obtain the child process' return code.
'
'DataArrival(ByVal CharsTotal As Long)
'
' Signals that input data from the child process'
' OutPipe is available to be read via GetData().
'
' CharsTotal is the amount of data available to be
' read.
'
'EOF (ByVal EOFType As SPEOF_TYPES)
'
' Signals that an EOF or BROKEN_PIPE has occurred
' on the child process' OutPipe.
'
' EOFType: SPEOF_NORMAL
' SPEOF_BROKEN_PIPE
'
'Error (ByVal Number As Long, _
' ByVal Source As String, _
' ByRef CancelDisplay As Boolean)
'
' Signals that some sort of error occurred
' while performing an operation.
'
' Number is the error number, typically a pipe or
' other system error.
'
' Source is a string describing the source of the
' error, generally some operation internal to
' ShellPipe.
'
' CancelDisplay indicates whether to cancel the
' display. The default is False, which is to display
' the default error message box. If you do not want
' to use the default message box, set CancelDisplay
' to True.
'
'EXCEPTIONS
'----------
'
'&H80042B02 in ShellPipe.PollInterval
'
' PollInterval value supplied is outside the valid
' range 10 to 65535.
'
Private Const WIN32NULL As Long = 0&
Private Const WIN32FALSE As Long = 0&
Private Const WIN32TRUE As Long = 1&
Private Const WAIT_OBJECT_0 As Long = 0&
Private Const NORMAL_PRIORITY_CLASS As Long = &H20&
Private Const INFINITE As Long = -1&
Private Const STARTF_USESHOWWINDOW As Long = &H1&
Private Const STARTF_USESTDHANDLES As Long = &H100&
Private Const SW_HIDE As Long = 0&
Private Const STD_INPUT_HANDLE As Long = -10&
Private Const STD_OUTPUT_HANDLE As Long = -11&
Private Const STD_ERROR_HANDLE As Long = -12&
Private Const HANDLE_FLAG_INHERIT As Long = &H1&
Private Const CTRL_C_EVENT As Long = 0&
Private Const CTRL_BREAK_EVENT As Long = 1&
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_INVALID_HANDLE As Long = 6&
Private Const ERROR_HANDLE_EOF As Long = 38&
Private Const ERROR_BROKEN_PIPE As Long = 109&
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 PROCESSINFO
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" _
(ByRef phReadPipe As Long, _
ByRef phWritePipe As Long, _
ByRef lpPipeAttributes As Any, _
ByVal nSize As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESSINFO) As Long
Private Declare Function GenerateConsoleCtrlEvent Lib "kernel32" _
(ByVal dwCtrlEvent As Long, _
ByVal dwProcessGroupId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hHandle As Long, _
ByRef lpExitCode As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" _
(ByVal hNamedPipe As Long, _
ByVal lpBuf As String, _
ByVal nBufSize As Long, _
ByRef lpBytesRead As Long, _
ByRef lpTotalBytesAvail As Long, _
ByVal lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lpBuf As String, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Private Declare Function SetHandleInformation Lib "kernel32" _
(ByVal hObject As Long, _
ByVal dwMask As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function WriteFile Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lpBuf As String, _
ByVal cToWrite As Long, _
ByRef cWritten As Long, _
ByVal lpOverlapped As Any) As Long
Private piProc As PROCESSINFO
Private saPipe As SECURITY_ATTRIBUTES
Private hChildInPipeRd As Long
Private hChildInPipeWr As Long
Private hChildOutPipeRd As Long
Private hChildOutPipeWr As Long
Private blnFinishedChild As Boolean
Private blnProcessActive As Boolean
Private blnInPipeOpen As Boolean
Private sbInBuffer As SmartBuffer
Private sbOutBuffer As SmartBuffer
Public Enum SPEOF_TYPES
SPEOF_NORMAL = 0
SPEOF_BROKEN_PIPE = ERROR_BROKEN_PIPE
End Enum
Public Enum SP_RESULTS
SP_SUCCESS = 0
SP_CREATEPIPEFAILED = &H80042B00
SP_CREATEPROCFAILED = &H80042B01
End Enum
Public Event DataArrival(ByVal CharsTotal As Long)
Public Event EOF(ByVal EOFType As SPEOF_TYPES)
Public Event Error(ByVal Number As Long, _
ByVal Source As String, _
CancelDisplay As Boolean)
Public Event ChildFinished()
Private WithEvents tmrCheck As ccrpTimer
Private Sub Class_Initialize()
blnFinishedChild = True
Set sbInBuffer = New SmartBuffer
Set sbOutBuffer = New SmartBuffer
Set tmrCheck = New ccrpTimer
PollInterval = 15
End Sub
Public Property Get Active() As Boolean
If blnProcessActive Then 'Last we knew, it was active.
If WaitForSingleObject(piProc.hProcess, 0&) <> WAIT_OBJECT_0 Then
Active = True
Else
blnProcessActive = False
Active = False
End If
Else
Active = False
End If
End Property
Public Sub ClosePipe()
CloseHandle hChildInPipeWr
blnInPipeOpen = False
End Sub
Public Function FinishChild(Optional ByVal WaitMs As Long = 500, _
Optional ByVal KillReturnCode = 666) As Long
If blnFinishedChild Then
FinishChild = -1 'Already "Finished Child."
Else
If blnProcessActive Then
If WaitForSingleObject(piProc.hProcess, WaitMs) <> WAIT_OBJECT_0 Then
TerminateProcess piProc.hProcess, KillReturnCode
WaitForSingleObject piProc.hProcess, INFINITE
End If
blnProcessActive = False
tmrCheck.Enabled = False
End If
sbInBuffer.Flush
sbOutBuffer.Flush
GetExitCodeProcess piProc.hProcess, FinishChild
CloseHandle hChildOutPipeRd
If blnInPipeOpen Then ClosePipe
CloseHandle piProc.hThread
CloseHandle piProc.hProcess
blnFinishedChild = True
End If
End Function
Public Function GetData(Optional ByVal MaxLen As Long = -1) As String
GetData = sbInBuffer.GetData(MaxLen)
End Function
Public Function GetLine() As String
GetLine = sbInBuffer.GetLine()
End Function
Public Property Get HasLine() As Boolean
HasLine = sbInBuffer.HasLine
End Property
Public Sub Interrupt(Optional ByVal Break As Boolean = False)
Dim lngEvent As Long
Dim lngError As Long
Dim blnCancel As Boolean
lngEvent = IIf(Break, CTRL_BREAK_EVENT, CTRL_C_EVENT)
If GenerateConsoleCtrlEvent(lngEvent, 0&) = 0 Then
lngError = Err.LastDllError
RaiseEvent Error(lngError, "ShellPipe.Interrupt", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.Interrupt error"
End If
End If
End Sub
Public Property Get Length() As Long
Length = sbInBuffer.Length
End Property
Public Property Let PollInterval(ByVal PollMs As Long)
If 5 > PollMs Or PollMs > 65535 Then
Err.Raise &H80042B02, _
"ShellPipe.PollInterval", _
"PollInterval outside valid range 5-65535"
End If
tmrCheck.Interval = PollMs
End Property
Public Property Get PollInterval() As Long
PollInterval = tmrCheck.Interval
End Property
Public Function Run(ByVal CommandLine As String, _
Optional ByVal CurrentDir As String = vbNullString) _
As SP_RESULTS
Dim siStart As STARTUPINFO
With saPipe
.nLength = Len(saPipe)
.lpSecurityDescriptor = WIN32NULL
.bInheritHandle = WIN32TRUE
End With
If CreatePipe(hChildOutPipeRd, hChildOutPipeWr, saPipe, 0&) = WIN32FALSE Then
Run = SP_CREATEPIPEFAILED
Exit Function
End If
SetHandleInformation hChildOutPipeRd, HANDLE_FLAG_INHERIT, 0&
If CreatePipe(hChildInPipeRd, hChildInPipeWr, saPipe, 0&) = WIN32FALSE Then
CloseHandle hChildOutPipeRd
CloseHandle hChildOutPipeWr
Run = SP_CREATEPIPEFAILED
Exit Function
End If
SetHandleInformation hChildInPipeWr, HANDLE_FLAG_INHERIT, 0&
With siStart
.cb = Len(siStart)
.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
.wShowWindow = SW_HIDE
.hStdOutput = hChildOutPipeWr
.hStdError = hChildOutPipeWr
.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
'Leave other fields 0/Null.
End With
'Clear all fields, global UDT and we may have been used more than once.
With piProc
.hProcess = 0
.hThread = 0
.dwProcessID = 0
.dwThreadID = 0
End With
If CreateProcessA(vbNullString, CommandLine, WIN32NULL, WIN32NULL, WIN32TRUE, _
NORMAL_PRIORITY_CLASS, WIN32NULL, CurrentDir, _
siStart, piProc) = WIN32FALSE Then
blnProcessActive = False
Run = SP_CREATEPROCFAILED
Else
CloseHandle hChildOutPipeWr
CloseHandle hChildInPipeRd
blnProcessActive = True
blnFinishedChild = False
blnInPipeOpen = True
tmrCheck.Enabled = True
Run = SP_SUCCESS
End If
End Function
Public Sub SendData(ByVal Data As String)
sbOutBuffer.Append Data
WriteData
End Sub
Public Sub SendLine(ByVal Line As String, Optional ByVal UseLFs As Boolean = True)
If UseLFs Then
SendData Line & vbCrLf
Else
SendData Line & vbCr
End If
End Sub
Private Sub tmrCheck_Timer(ByVal Milliseconds As Long)
If Active Then
ReadData
' DoEvents 'Let events raised in ReadData be handled.
WriteData
Else
'Last gasp.
ReadData
' DoEvents 'Let events raised in ReadData be handled.
tmrCheck.Enabled = False
RaiseEvent ChildFinished
End If
End Sub
Private Sub ReadData()
Dim strBuf As String
Dim lngAvail As Long
Dim lngRead As Long
Dim lngError As Long
Dim blnCancel As Boolean
If PeekNamedPipe(hChildOutPipeRd, WIN32NULL, 0&, WIN32NULL, lngAvail, WIN32NULL) <> WIN32FALSE Then
If lngAvail > 0 Then
strBuf = String$(lngAvail, 0)
If ReadFile(hChildOutPipeRd, ByVal strBuf, lngAvail, lngRead, WIN32NULL) <> WIN32FALSE Then
If lngRead > 0 Then
sbInBuffer.Append Left$(strBuf, lngRead)
RaiseEvent DataArrival(sbInBuffer.Length)
Else
RaiseEvent EOF(SPEOF_NORMAL)
End If
Else
lngError = Err.LastDllError
If lngError = ERROR_BROKEN_PIPE Then
RaiseEvent EOF(SPEOF_BROKEN_PIPE)
Else
RaiseEvent Error(lngError, "ShellPipe.ReadData.ReadFile", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.ReadData.ReadFile error"
End If
End If
End If
End If
Else
lngError = Err.LastDllError
Select Case lngError
Case ERROR_BROKEN_PIPE
RaiseEvent EOF(SPEOF_BROKEN_PIPE)
Case ERROR_ACCESS_DENIED, ERROR_INVALID_HANDLE
'Ignore as "no input."
Case Else
RaiseEvent Error(lngError, "ShellPipe.ReadData.PeekNamedPipe", blnCancel)
If Not blnCancel Then
Err.Raise "ShellPipe.ReadData.PeeknamedPipe error"
End If
End Select
End If
End Sub
Private Sub WriteData()
Dim strBuffer As String
Dim lngWritten As Long
Dim lngError As Long
Dim blnCancel As Boolean
If blnInPipeOpen Then
If sbOutBuffer.Length > 0 Then
sbOutBuffer.PeekBuffer strBuffer
If WriteFile(hChildInPipeWr, ByVal strBuffer, Len(strBuffer), lngWritten, 0&) <> WIN32FALSE Then
sbOutBuffer.DeleteData lngWritten
Else
lngError = Err.LastDllError
RaiseEvent Error(lngError, "ShellPipe.WriteData", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.WriteData error"
End If
End If
End If
Else
sbOutBuffer.Flush
End If
End Sub
Private Sub Class_Terminate()
FinishChild
End Sub
Olaf
Re: Create User Control Object at runtime Without form
Without Forms how do you expect events to be handled? Static modules don't even support COM callbacks.
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
dilettante
Without Forms how do you expect events to be handled? Static modules don't even support COM callbacks.
Inside a class.
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
The trick
Inside a class.
I'm not sure how that's an answer.
As far as I can tell the code you execute from Sub Main never enters a wait state until control is transferred to a Form. So you've basically "hung" the UI thread.
I must be misunderstanding what you mean.
Re: Create User Control Object at runtime Without form
GetMessage/TranslateMessage/DispatchMessage loop should be implemented.
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
The trick
GetMessage/TranslateMessage/DispatchMessage loop should be implemented.
Or in the simplest case, a loop like:
Do: Sleep 15: Loop Until DoEvents()
...should work just fine in a "pure Sub Main()" to ensure Msg-Pumping...
(e.g. for "Class-based Services", which don't use any Forms or UserControls)
@dilettante
Besides, the "raising and receiving" of the COM-Events themselves does not require such a Message-Pump,
because they work entirely synchronous (without any "intermediate Win-Message-Queueing"),
as long as the "Raising- and Sinking-ClassInstances" run on the same thread (without marshalling).
It's "the extra-stuff within an Event-Raising Class", which sometimes requires Message-Pumping.
(like e.g. "polling-timers").
Olaf
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Maddis
Hi, I'm trying to load a user control at runtime. I am not using any form, everything will be done using a Module and classes.
I have to ask - why not use a Form?
Just because you load a Form doesn't mean anybody has to see it.
Back in 1999, I was writing Windows Services in VB6. Yes, really.
What made is possible was an ActiveX Control that interacted with the Windows Service Controller.
And yes; that control had to be placed on a Form.
But everybody said:
Quote:
You can't write Windows Services in VB6. They can't have any Forms. There's no Desktop for them to be shown on.
And they were almost right.
Services do have access to a Desktop but it's a virtual, pseudo-desktop that nobody can ever get to.
So, you have to be absolutely air-tight in your error handling, so that you don't get any stray MsgBox's popping up on that pseudo-Desktop, thereby locking up the entire process until you have to kill it. Other than that, though, the coding is business as usual.
Regards, Phill W.
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Phill.W
So, you have to be absolutely air-tight in your error handling,
so that you don't get any stray MsgBox's popping up on that pseudo-Desktop...
That's what the "Unattended Execution" CheckBox is for (in your Project-Settings)...
And well, ... that switch is only available (enabled) in the Project-Settings Dialogue of a Std-Exe,
when you have no Forms in your Project.
Olaf
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Schmidt
Code:
Do: Sleep 15: Loop Until DoEvents()
How is that supposed to work?
DoEvents returns the number of forms that are opened, I think it will always return 0 in that case.
I suggest to use a global flag:
Code:
Do: Sleep 15: DoEvents: Loop Until gEndFlag()
And set gEndFlag from the class when it is ready to exit the program.
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Eduardo-
How is that supposed to work?
DoEvents returns the number of forms that are opened, I think it will always return 0 in that case.
Guess, I wanted to keep a way open for a "take-over" of the Default-MessagePump
("for potentially later shown Forms, directly from a given Class-Model" - or "no Forms at all" if so choosen).
And sure, the loop was showing only the principle
(was missing the interaction with different "App-States" which might cause an early exit)
Code:
Public App As New cApp
Sub Main()
Do
If Not App.HandleWorkflowStates Then Exit Do
Sleep 15
Loop Until DoEvents()
Debug.Print IIf(Forms.Count, "the Default-Messagepump took over", "headless App-Exit")
End Sub
Olaf
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Schmidt
Your ShellPipe-Control (which is a Windowless-Ctl, and "invisible at runtime") -
can be converted into a normal Class easily as well:
Code:
Option Explicit
'
'ShellPipe (version 3)
'=========
'
'Run a console program and communicate with it via the
'Standard I/O streams.
'
'Both StdOut and StdErr are piped to one stream reader here.
'
'NOTES
'-----
'
'Because overlapped I/O isn't available under Win9x, this
'control uses a Timer control and a "polling" model to
'process pipe reads and writes and detect process termination.
'
'Requires SmartBuffer class.
'
'ENUMS
'-----
'
'SP_RESULTS
' SP_SUCCESS = 0
' SP_CREATEPIPEFAILED = &H80042B00
' SP_CREATEPROCFAILED = &H80042B01
'
'SPEOF_TYPES
' SPEOF_NORMAL = 0
' SPEOF_BROKEN_PIPE = 109
'
'
'PROPERTIES
'----------
'
'Active Boolean, read-only.
'
' Returns a result telling whether or not the child
' process is currently active.
'
' If NOT, then FinishChild() should be called as
' soon as possible.
'
'HasLine Boolean, read-only.
'
' True if we have a buffered "line" from the child
' process buffered.
'
' Set appropriately by every call to GetData() and
' GetLine() as well as by DataArrival events so it
' is possible to loop on this property to retrieve
' lines of text.
'
'Length Long, read-only.
'
' Number of characters currently buffered from the
' child process.
'
'PollInterval Long, read/write. Default: 250.
'
' This is a value (in milliseconds) used to:
'
' * Look for data or EOF from the child process'
' OutPipe.
' * Send pending blocked output to the child
' process' InPipe.
' * Check for process termination.
'
'METHODS
'-------
'
'ClosePipe()
'
' Closes our output pipe to the child process' StdIn.
'
'FinishChild(Optional ByVal WaitMs As Long = 500, _
' Optional ByVal KillReturnCode = 666) As Long
'
' MUST be called after child process terminates
' (ChildFinished event is raised), or may be called
' to FORCE (kill) the process.
'
' Waits WaitMs milliseconds for the child process to
' complete. If the child doesn't finish, terminates
' the child process with KillReturnCode. Caller
' may check for KillReturnCode value to determine
' that the process was killed.
'
' Closes pipes and cleans up the process.
'
' Returns: Child process' return code. Returns -1
' if the child has already been "finished."
'
'GetData(Optional ByVal MaxLen As Long = -1) As String
'
' Get data from child process' OutPipe.
'
' Returns MaxLen characters (or as many as are
' available). When MaxLen is -1 returns all
' available characters. May return an empty string.
'
'GetLine() As String
'
' Get a line of data from child process' OutPipe.
'
' Should only be called when HasLine is True.
' May return an empty string.
'
' A "line" is defined as text delimited by a CR, but
' if CRLF occurs the LFs are consumed as well. Both
' conventions are used by StdIO programs.
'
'Interrupt(Optional ByVal Break As Boolean = False)
'
' Attempts to interrupt the child process. This is
' only effective if the parent has a console window,
' which will be inherited by the child. Note that
' the parent will also be interrupted, so a null
' handler must be installed or else the parent will
' also be terminated!
'
' Break sends a CTRL-C signal when False or a
' CTRL-Break signal when True.
'
'Run (ByVal CommandLine As String, _
' Optional ByVal CurrentDir As String = vbNullString) _
' As SP_RESULTS
'
' Runs the command line provided via CommandLine with
' standard streams redirected to the ShellPipe control.
' If the caller doesn't supply a CurrentDir string,
' the child process inherits the caller's current
' directory.
'
' Returns: SP_SUCCESS
' SP_CREATEPIPEFAILED
' SP_CREATEPROCFAILED
'
'SendData(ByVal Data As String)
'
' Pipes Data to child process' StdIn.
'
'SendLine(ByVal Line As String,
' Optional ByVal UseLFs As Boolean = True)
'
' Pipes Line and CR or CRLF to child process' StdIn.
'
'EVENTS
'------
'
'ChildFinished()
'
' Signals that the child process has completed. The
' program should call the FinishChild() method as
' soon as possible to clean up process handles and
' obtain the child process' return code.
'
'DataArrival(ByVal CharsTotal As Long)
'
' Signals that input data from the child process'
' OutPipe is available to be read via GetData().
'
' CharsTotal is the amount of data available to be
' read.
'
'EOF (ByVal EOFType As SPEOF_TYPES)
'
' Signals that an EOF or BROKEN_PIPE has occurred
' on the child process' OutPipe.
'
' EOFType: SPEOF_NORMAL
' SPEOF_BROKEN_PIPE
'
'Error (ByVal Number As Long, _
' ByVal Source As String, _
' ByRef CancelDisplay As Boolean)
'
' Signals that some sort of error occurred
' while performing an operation.
'
' Number is the error number, typically a pipe or
' other system error.
'
' Source is a string describing the source of the
' error, generally some operation internal to
' ShellPipe.
'
' CancelDisplay indicates whether to cancel the
' display. The default is False, which is to display
' the default error message box. If you do not want
' to use the default message box, set CancelDisplay
' to True.
'
'EXCEPTIONS
'----------
'
'&H80042B02 in ShellPipe.PollInterval
'
' PollInterval value supplied is outside the valid
' range 10 to 65535.
'
Private Const WIN32NULL As Long = 0&
Private Const WIN32FALSE As Long = 0&
Private Const WIN32TRUE As Long = 1&
Private Const WAIT_OBJECT_0 As Long = 0&
Private Const NORMAL_PRIORITY_CLASS As Long = &H20&
Private Const INFINITE As Long = -1&
Private Const STARTF_USESHOWWINDOW As Long = &H1&
Private Const STARTF_USESTDHANDLES As Long = &H100&
Private Const SW_HIDE As Long = 0&
Private Const STD_INPUT_HANDLE As Long = -10&
Private Const STD_OUTPUT_HANDLE As Long = -11&
Private Const STD_ERROR_HANDLE As Long = -12&
Private Const HANDLE_FLAG_INHERIT As Long = &H1&
Private Const CTRL_C_EVENT As Long = 0&
Private Const CTRL_BREAK_EVENT As Long = 1&
Private Const ERROR_ACCESS_DENIED As Long = 5&
Private Const ERROR_INVALID_HANDLE As Long = 6&
Private Const ERROR_HANDLE_EOF As Long = 38&
Private Const ERROR_BROKEN_PIPE As Long = 109&
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 PROCESSINFO
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
Private Declare Function CreatePipe Lib "kernel32" _
(ByRef phReadPipe As Long, _
ByRef phWritePipe As Long, _
ByRef lpPipeAttributes As Any, _
ByVal nSize As Long) As Long
Private Declare Function CreateProcessA Lib "kernel32" _
(ByVal lpApplicationName As String, _
ByVal lpCommandLine As String, _
ByVal lpProcessAttributes As Long, _
ByVal lpThreadAttributes As Long, _
ByVal bInheritHandles As Long, _
ByVal dwCreationFlags As Long, _
ByVal lpEnvironment As Long, _
ByVal lpCurrentDirectory As String, _
ByRef lpStartupInfo As STARTUPINFO, _
ByRef lpProcessInformation As PROCESSINFO) As Long
Private Declare Function GenerateConsoleCtrlEvent Lib "kernel32" _
(ByVal dwCtrlEvent As Long, _
ByVal dwProcessGroupId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" _
(ByVal hHandle As Long, _
ByRef lpExitCode As Long) As Long
Private Declare Function GetStdHandle Lib "kernel32" (ByVal nStdHandle As Long) As Long
Private Declare Function PeekNamedPipe Lib "kernel32" _
(ByVal hNamedPipe As Long, _
ByVal lpBuf As String, _
ByVal nBufSize As Long, _
ByRef lpBytesRead As Long, _
ByRef lpTotalBytesAvail As Long, _
ByVal lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lpBuf As String, _
ByVal nNumberOfBytesToRead As Long, _
ByRef lpNumberOfBytesRead As Long, _
ByVal lpOverlapped As Any) As Long
Private Declare Function SetHandleInformation Lib "kernel32" _
(ByVal hObject As Long, _
ByVal dwMask As Long, _
ByVal dwFlags As Long) As Long
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal uExitCode As Long) As Long
Private Declare Function WaitForSingleObject Lib "kernel32" _
(ByVal hHandle As Long, _
ByVal dwMilliseconds As Long) As Long
Private Declare Function WriteFile Lib "kernel32" _
(ByVal hFile As Long, _
ByVal lpBuf As String, _
ByVal cToWrite As Long, _
ByRef cWritten As Long, _
ByVal lpOverlapped As Any) As Long
Private piProc As PROCESSINFO
Private saPipe As SECURITY_ATTRIBUTES
Private hChildInPipeRd As Long
Private hChildInPipeWr As Long
Private hChildOutPipeRd As Long
Private hChildOutPipeWr As Long
Private blnFinishedChild As Boolean
Private blnProcessActive As Boolean
Private blnInPipeOpen As Boolean
Private sbInBuffer As SmartBuffer
Private sbOutBuffer As SmartBuffer
Public Enum SPEOF_TYPES
SPEOF_NORMAL = 0
SPEOF_BROKEN_PIPE = ERROR_BROKEN_PIPE
End Enum
Public Enum SP_RESULTS
SP_SUCCESS = 0
SP_CREATEPIPEFAILED = &H80042B00
SP_CREATEPROCFAILED = &H80042B01
End Enum
Public Event DataArrival(ByVal CharsTotal As Long)
Public Event EOF(ByVal EOFType As SPEOF_TYPES)
Public Event Error(ByVal Number As Long, _
ByVal Source As String, _
CancelDisplay As Boolean)
Public Event ChildFinished()
Private WithEvents tmrCheck As ccrpTimer
Private Sub Class_Initialize()
blnFinishedChild = True
Set sbInBuffer = New SmartBuffer
Set sbOutBuffer = New SmartBuffer
Set tmrCheck = New ccrpTimer
PollInterval = 15
End Sub
Public Property Get Active() As Boolean
If blnProcessActive Then 'Last we knew, it was active.
If WaitForSingleObject(piProc.hProcess, 0&) <> WAIT_OBJECT_0 Then
Active = True
Else
blnProcessActive = False
Active = False
End If
Else
Active = False
End If
End Property
Public Sub ClosePipe()
CloseHandle hChildInPipeWr
blnInPipeOpen = False
End Sub
Public Function FinishChild(Optional ByVal WaitMs As Long = 500, _
Optional ByVal KillReturnCode = 666) As Long
If blnFinishedChild Then
FinishChild = -1 'Already "Finished Child."
Else
If blnProcessActive Then
If WaitForSingleObject(piProc.hProcess, WaitMs) <> WAIT_OBJECT_0 Then
TerminateProcess piProc.hProcess, KillReturnCode
WaitForSingleObject piProc.hProcess, INFINITE
End If
blnProcessActive = False
tmrCheck.Enabled = False
End If
sbInBuffer.Flush
sbOutBuffer.Flush
GetExitCodeProcess piProc.hProcess, FinishChild
CloseHandle hChildOutPipeRd
If blnInPipeOpen Then ClosePipe
CloseHandle piProc.hThread
CloseHandle piProc.hProcess
blnFinishedChild = True
End If
End Function
Public Function GetData(Optional ByVal MaxLen As Long = -1) As String
GetData = sbInBuffer.GetData(MaxLen)
End Function
Public Function GetLine() As String
GetLine = sbInBuffer.GetLine()
End Function
Public Property Get HasLine() As Boolean
HasLine = sbInBuffer.HasLine
End Property
Public Sub Interrupt(Optional ByVal Break As Boolean = False)
Dim lngEvent As Long
Dim lngError As Long
Dim blnCancel As Boolean
lngEvent = IIf(Break, CTRL_BREAK_EVENT, CTRL_C_EVENT)
If GenerateConsoleCtrlEvent(lngEvent, 0&) = 0 Then
lngError = Err.LastDllError
RaiseEvent Error(lngError, "ShellPipe.Interrupt", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.Interrupt error"
End If
End If
End Sub
Public Property Get Length() As Long
Length = sbInBuffer.Length
End Property
Public Property Let PollInterval(ByVal PollMs As Long)
If 5 > PollMs Or PollMs > 65535 Then
Err.Raise &H80042B02, _
"ShellPipe.PollInterval", _
"PollInterval outside valid range 5-65535"
End If
tmrCheck.Interval = PollMs
End Property
Public Property Get PollInterval() As Long
PollInterval = tmrCheck.Interval
End Property
Public Function Run(ByVal CommandLine As String, _
Optional ByVal CurrentDir As String = vbNullString) _
As SP_RESULTS
Dim siStart As STARTUPINFO
With saPipe
.nLength = Len(saPipe)
.lpSecurityDescriptor = WIN32NULL
.bInheritHandle = WIN32TRUE
End With
If CreatePipe(hChildOutPipeRd, hChildOutPipeWr, saPipe, 0&) = WIN32FALSE Then
Run = SP_CREATEPIPEFAILED
Exit Function
End If
SetHandleInformation hChildOutPipeRd, HANDLE_FLAG_INHERIT, 0&
If CreatePipe(hChildInPipeRd, hChildInPipeWr, saPipe, 0&) = WIN32FALSE Then
CloseHandle hChildOutPipeRd
CloseHandle hChildOutPipeWr
Run = SP_CREATEPIPEFAILED
Exit Function
End If
SetHandleInformation hChildInPipeWr, HANDLE_FLAG_INHERIT, 0&
With siStart
.cb = Len(siStart)
.dwFlags = STARTF_USESTDHANDLES Or STARTF_USESHOWWINDOW
.wShowWindow = SW_HIDE
.hStdOutput = hChildOutPipeWr
.hStdError = hChildOutPipeWr
.hStdInput = GetStdHandle(STD_INPUT_HANDLE)
'Leave other fields 0/Null.
End With
'Clear all fields, global UDT and we may have been used more than once.
With piProc
.hProcess = 0
.hThread = 0
.dwProcessID = 0
.dwThreadID = 0
End With
If CreateProcessA(vbNullString, CommandLine, WIN32NULL, WIN32NULL, WIN32TRUE, _
NORMAL_PRIORITY_CLASS, WIN32NULL, CurrentDir, _
siStart, piProc) = WIN32FALSE Then
blnProcessActive = False
Run = SP_CREATEPROCFAILED
Else
CloseHandle hChildOutPipeWr
CloseHandle hChildInPipeRd
blnProcessActive = True
blnFinishedChild = False
blnInPipeOpen = True
tmrCheck.Enabled = True
Run = SP_SUCCESS
End If
End Function
Public Sub SendData(ByVal Data As String)
sbOutBuffer.Append Data
WriteData
End Sub
Public Sub SendLine(ByVal Line As String, Optional ByVal UseLFs As Boolean = True)
If UseLFs Then
SendData Line & vbCrLf
Else
SendData Line & vbCr
End If
End Sub
Private Sub tmrCheck_Timer(ByVal Milliseconds As Long)
If Active Then
ReadData
' DoEvents 'Let events raised in ReadData be handled.
WriteData
Else
'Last gasp.
ReadData
' DoEvents 'Let events raised in ReadData be handled.
tmrCheck.Enabled = False
RaiseEvent ChildFinished
End If
End Sub
Private Sub ReadData()
Dim strBuf As String
Dim lngAvail As Long
Dim lngRead As Long
Dim lngError As Long
Dim blnCancel As Boolean
If PeekNamedPipe(hChildOutPipeRd, WIN32NULL, 0&, WIN32NULL, lngAvail, WIN32NULL) <> WIN32FALSE Then
If lngAvail > 0 Then
strBuf = String$(lngAvail, 0)
If ReadFile(hChildOutPipeRd, ByVal strBuf, lngAvail, lngRead, WIN32NULL) <> WIN32FALSE Then
If lngRead > 0 Then
sbInBuffer.Append Left$(strBuf, lngRead)
RaiseEvent DataArrival(sbInBuffer.Length)
Else
RaiseEvent EOF(SPEOF_NORMAL)
End If
Else
lngError = Err.LastDllError
If lngError = ERROR_BROKEN_PIPE Then
RaiseEvent EOF(SPEOF_BROKEN_PIPE)
Else
RaiseEvent Error(lngError, "ShellPipe.ReadData.ReadFile", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.ReadData.ReadFile error"
End If
End If
End If
End If
Else
lngError = Err.LastDllError
Select Case lngError
Case ERROR_BROKEN_PIPE
RaiseEvent EOF(SPEOF_BROKEN_PIPE)
Case ERROR_ACCESS_DENIED, ERROR_INVALID_HANDLE
'Ignore as "no input."
Case Else
RaiseEvent Error(lngError, "ShellPipe.ReadData.PeekNamedPipe", blnCancel)
If Not blnCancel Then
Err.Raise "ShellPipe.ReadData.PeeknamedPipe error"
End If
End Select
End If
End Sub
Private Sub WriteData()
Dim strBuffer As String
Dim lngWritten As Long
Dim lngError As Long
Dim blnCancel As Boolean
If blnInPipeOpen Then
If sbOutBuffer.Length > 0 Then
sbOutBuffer.PeekBuffer strBuffer
If WriteFile(hChildInPipeWr, ByVal strBuffer, Len(strBuffer), lngWritten, 0&) <> WIN32FALSE Then
sbOutBuffer.DeleteData lngWritten
Else
lngError = Err.LastDllError
RaiseEvent Error(lngError, "ShellPipe.WriteData", blnCancel)
If Not blnCancel Then
Err.Raise lngError, "ShellPipe.WriteData error"
End If
End If
End If
Else
sbOutBuffer.Flush
End If
End Sub
Private Sub Class_Terminate()
FinishChild
End Sub
Olaf
This did the trick. Thanks
Re: Create User Control Object at runtime Without form
Appreciate your help with this. Last bit I am struggling with is how to capture any raised event. I see in ShellPipe, now I have it as a Class, that the events are raised in the timer:
Code:
Private Sub tmrCheck_Timer(ByVal Milliseconds As Long)
If Active Then
ReadData
' DoEvents 'Let events raised in ReadData be handled.
WriteData
Else
'Last gasp.
ReadData
' DoEvents 'Let events raised in ReadData be handled.
tmrCheck.Enabled = False
RaiseEvent ChildFinished
End If
End Sub
How do I trigger this event in Sub Main() ?
Do I need to change the DataBindingBehaviour to Simple or Complex Bound?
Thanks
Re: Create User Control Object at runtime Without form
Quote:
Originally Posted by
Maddis
Appreciate your help with this. Last bit I am struggling with is how to capture any raised event. I see in ShellPipe, now I have it as a Class, that the events are raised in the timer:
...
How do I trigger this event in Sub Main() ?
If your App really does not contain any Forms at all, then you need to provide:
- a "global EventSink-Class" (e.g. named cApp)
- a "userdefined MessagePump" in Sub Main
Code:
Public App As New cApp 'globally reachable Class for "Event-Sinking"
Sub Main()
App.Init ..., ...
Do While App.StillRunning
Sleep 15
DoEvents
Loop
End Sub
So, this cApp defines your ShellPipe-Variable (+ whatever else) internally WithEvents -
(initialized e.g. from a Public Init-Method)...
And it Exports also a Public Property "StillRunning", which you can cApp-internally switch to False,
in case the ShellPipe signalizes in some Event (received in cApp), that it is done (StillRunning then switched to False)
Olaf
