ANYONE? HOW DO I STOP AN APP?

[CGehlhausen]

How do I stop my own executable?

I have a small app running constantly - then when something happens, it opens another app using shell.

I do something, then I need to close the second app.

I have the Do Loop using a While x and y, so it exits the loop, but the app still runs.

I've tried End, Stop and Unload - but there's no forms opened. I check task manager and it's still running.

Any ideas? It seems simple, but WHAT DO I DO...

 

[CasperTFG]

have you tried using ShellEX instead.

Casper

There is room for all of gods creatures, "Right Beside the Mashed Potatoes".

 

[dwlerwill]

unload me does not work? you could try

Dim frm As Form

For Each frm In Forms
Unload frm
Next frm

David Lerwill
"If at first you don't succeed go to the pub"

 

[CasperTFG]

If he used End it would kill any forms in the project. I think it is this Shell that is doing this.

Could you post some code... How do you call this second app?

Casper

There is room for all of gods creatures, "Right Beside the Mashed Potatoes".

 

[HarleyQuinn]

This is the way I do it:

Get the Process ID when you shell to the app:

Dim ProcID as String

ProcID = Shell("YourSecond.exe")

Kill the process using this code in a module:

Option Explicit
Private Type LUID
   lowpart As Long
   highpart As Long
End Type
Private Type TOKEN_PRIVILEGES
    PrivilegeCount As Long
    LuidUDT As LUID
    Attributes As Long
End Type

Const TOKEN_ADJUST_PRIVILEGES = &H20
Const TOKEN_QUERY = &H8
Const SE_PRIVILEGE_ENABLED = &H2
Const PROCESS_ALL_ACCESS = &H1F0FFF

Private Declare Function GetVersion _
    Lib "kernel32" () As Long
Private Declare Function GetCurrentProcess _
    Lib "kernel32" () As Long
Private Declare Function CloseHandle _
    Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function OpenProcessToken _
    Lib "advapi32" (ByVal ProcessHandle As Long, _
    ByVal DesiredAccess As Long, _
    TokenHandle As Long) As Long
Private Declare Function LookupPrivilegeValue _
    Lib "advapi32" Alias "LookupPrivilegeValueA" _
    (ByVal lpSystemName As String, _
    ByVal lpName As String, _
    lpLuid As LUID) As Long
Private Declare Function AdjustTokenPrivileges _
    Lib "advapi32" (ByVal TokenHandle As Long, _
    ByVal DisableAllPrivileges As Long, _
    NewState As TOKEN_PRIVILEGES, _
    ByVal BufferLength As Long, _
    PreviousState As Any, ReturnLength As Any) As Long
Private Declare Function OpenProcess _
    Lib "kernel32" (ByVal dwDesiredAccess As Long, _
    ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
Private Declare Function TerminateProcess _
    Lib "kernel32" (ByVal hProcess As Long, _
    ByVal uExitCode As Long) As Long
'Terminate any application and return an exit code to Windows.
Public Function KillProcess(ByVal hProcessID As Long, Optional ByVal ExitCode As Long) As Boolean
    Dim hToken As Long
    Dim hProcess As Long
    Dim tp As TOKEN_PRIVILEGES

    If GetVersion() >= 0 Then
     
        If OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES Or TOKEN_QUERY, hToken) = 0 Then
            GoTo CleanUp
        End If
        
        If LookupPrivilegeValue("", "SeDebugPrivilege", tp.LuidUDT) = 0 Then
            GoTo CleanUp
        End If
    
        tp.PrivilegeCount = 1
        tp.Attributes = SE_PRIVILEGE_ENABLED

        If AdjustTokenPrivileges(hToken, False, tp, 0, ByVal 0&, ByVal 0&) = 0 Then
            GoTo CleanUp
        End If
    End If
    
    hProcess = OpenProcess(PROCESS_ALL_ACCESS, 0, hProcessID)
    If hProcess Then
        
        KillProcess = (TerminateProcess(hProcess, ExitCode) <> 0)
        ' close the process handle
        CloseHandle hProcess
    End If
    
    If GetVersion() >= 0 Then
        ' under NT restore original privileges
        tp.Attributes = 0
        AdjustTokenPrivileges hToken, False, tp, 0, ByVal 0&, ByVal 0&
        
CleanUp:
        If hToken Then CloseHandle hToken
    End If
End Function

And Kill the Process as follows:

If ProcID <> "" Then
    If KillProcess(ProcID, 0) Then
    'successful close
    End If
Else
'no process running
End If

Please note that I didn't write the majority of this code and I can't remember where it came from. But if anyone knows/wrote it I will give full credit to the original author.

Hope this helps

Harleyquinn

---------------------------------
For tsunami relief donations

 

[HughLerwill]

CGehlhausen, Harley

This the way I do it;

'following used in Function EndTask
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As String) As Long
Public Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Const GW_OWNER = 4
Const GWL_STYLE = (-16)
Const WS_DISABLED = &H8000000
Const WM_CLOSE = &H10
Const WM_CANCELMODE = &H1F

Function EndTask%(ByVal TargetHwnd&, ByVal MehWnd&)

If Not (TargetHwnd = MehWnd Or GetWindow(TargetHwnd, GW_OWNER) = MehWnd) Then
If IsWindow(TargetHwnd) Then
If Not (GetWindowLong(TargetHwnd, GWL_STYLE) And WS_DISABLED) Then
PostMessage TargetHwnd, WM_CANCELMODE, 0, 0&
PostMessage TargetHwnd, WM_CLOSE, 0, 0&
DoEvents
End If
EndTask = True
End If
End If

End Function

'Usage example in a form
TargHwnd = FindWindow(0&, App2sWindowCaption$)
EndTask TargHwnd, Me.hwnd

Please note that I didn't write the majority of this code and I can't remember where it came from. But if anyone knows/wrote it I will give full credit to the original author!

Looking at it now I wonder if Mehwnd really need be included ...

Hope this helps

regards Hugh

 

[CGehlhausen]

I'm back on this project, see what we can do today. Thanks for all the input.

When an operator prints from their database, it creates a file, either in a manual or auto folder. My main program then opens it and sends it to this proprietary Linx 6800 printer. If they choose Manual, there is a form that gives them more options, but the final send is the same as the auto module.

The main reason that I'm needing to do 2 applications is because this industrial jet printer only comes with VB code, which is only working once. If I close and re-load again when needed, it works fine.

So here's the small app that will always be running. I put in the 1 second pause otherwise it had 100% CPU usage!

PRINTLINX.EXE :

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public AReady As Boolean, MReady As Boolean
Public AutoFile
Public ManFile

Public Sub Main()
Dim LinxAppID

Do
Pause 1
Dim fso As New FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

AutoFile = Dir("C:\auto\*.TXT")
AReady = fso.FileExists("c:\auto\" & AutoFile)

ManFile = Dir("C:\manual\*.TXT")
MReady = fso.FileExists("c:\manual\" & ManFile)

If ((AReady = True) Or (MReady = True)) Then

LinxAppID = Shell("C:\Program Files\Linx\Linx6800.EXE", 0)

Do While LinxAppID > 0
DoEvents ' Yield to other processes.
Loop
LinxAppID = 0
End If
Loop

End Sub

Private Sub Pause(iSecs As Integer)
' Makes the program sleep for 1 seconds
Dim i As Integer
For i = 1 To iSecs * 10
Sleep 100
DoEvents
Next
End Sub





HERE'S THE AUTO MODULE CODE FOR THE MAIN APP, THE ONE I NEED TO STOP :


Public AReady As Boolean, MReady As Boolean
Dim CodeLot As String, CodeColor As String, CodeGrade As String
Dim CodeProduct As String, CodeMessage As String
Public AutoFile
Public ManFile

Public PrinterObj As New LINX6800PRINTERLib.Simple6800Printer
Public fso As New FileSystemObject
Public bConnected As Boolean

Public Sub Main()

Dim TheContents As String
Dim PrintStuff As String
Dim FirstComma As Integer
Dim SecondComma As Integer
Dim FLength As Integer
Dim WinOpen As Integer

Dim Lot As String, Color As String, Grade As String
Dim Product As String, Message As String
Dim RemoteLot As String, RemoteColor As String, RemoteGrade As String
Dim RemoteProduct As String, RemoteMessage As String

WinOpen = 0
RemoteGrade = "Grade"
RemoteColor = "Color"
RemoteLot = "Lot"
RemoteProduct = "Product"
RemoteMessage = "Message"


Do
Set PrinterObj = New LINX6800PRINTERLib.Simple6800Printer
Set fso = CreateObject("Scripting.FileSystemObject")

AutoFile = Dir("C:\auto\*.TXT")
AReady = fso.FileExists("c:\auto\" & AutoFile)

If AReady = True Then
Open "c:\auto\" & AutoFile For Input As #1
FLength = LOF(1)
TheContents = Input$(FLength, 1): Close #1
PrintStuff = Mid(TheContents, 13, (FLength - 16))

FLength = FLength - 16
FirstComma = InStr(1, PrintStuff, ",")
SecondComma = InStr((FirstComma + 1), PrintStuff, ",")
CodeLot = Mid(PrintStuff, 1, (FirstComma - 1))
CodeGrade = Mid(PrintStuff, (FirstComma + 1), (SecondComma - FirstComma - 1))
CodeColor = Mid(PrintStuff, (SecondComma + 1), (FLength - SecondComma))
CodeProduct = "ULTEM"
CodeMessage = "55#/25KG"

' Connect to remote device
' See if we are connected first, if so, disconnect
If bConnected = True Then
PrinterObj.Disconnect
bConnected = False
End If

' Now connect
bConnected = PrinterObj.InitComponent(RS232, "COM1")

' Register the Fields
CodeRegisterField RemoteGrade
CodeRegisterField RemoteColor
CodeRegisterField RemoteLot
CodeRegisterField RemoteProduct
CodeRegisterField RemoteMessage

'Send Field Data to Linx6800
CodeSendField RemoteGrade, CodeGrade
CodeSendField RemoteColor, CodeColor
CodeSendField RemoteLot, CodeLot
CodeSendField RemoteProduct, CodeProduct
CodeSendField RemoteMessage, CodeMessage

If bConnected = True Then
PrinterObj.Disconnect
End If

bConnected = False
Set PrinterObj = Nothing
'Kill "c:\auto\" & AutoFile
AutoFile.Delete
AutoFile = "X"

AReady = False

End If

ManFile = Dir("C:\manual\*.TXT")
MReady = fso.FileExists("c:\manual\" & ManFile)

If MReady = True Then
Open "c:\manual\" & ManFile For Input As #1
FLength = LOF(1)
TheContents = Input$(FLength, 1): Close #1
PrintStuff = Mid(TheContents, 13, (FLength - 16))

FLength = FLength - 16
FirstComma = InStr(1, PrintStuff, ",")
SecondComma = InStr((FirstComma + 1), PrintStuff, ",")
LinxForm.frmLot = Mid(PrintStuff, 1, (FirstComma - 1))
LinxForm.frmGrade = Mid(PrintStuff, (FirstComma + 1), (SecondComma - FirstComma - 1))
LinxForm.frmColor = Mid(PrintStuff, (SecondComma + 1), (FLength - SecondComma))

If WinOpen = 0 Then
LinxForm.Show
WinOpen = 1

Do While WinOpen = 1
DoEvents ' Yield to other processes.
Loop
End If

'ManFile.Delete
Kill "c:\manual\" & ManFile
ManFile = ""
MReady = False

End If
Loop Until ((AReady = False) And (MReady = False))
End
Stop
Unload linx6800.exe
End Sub

Private Sub CodeDisplay(Error As GPIError, TextType As String)

Dim ErrStr As String
Const ForReading = 1, ForWriting = 2, ForAppending = 8
Dim sLogFile As String, sLogPath As String
Dim fso, f

If Error.Code = NoError Then
ErrStr = "Ok"
Else
Dim ErrCode As String
Dim DevErrCode As String
Dim DevErrString As String

ErrCode = Error.Code
DevErrCode = Error.DeviceErrorCode
DevErrString = Error.DeviceErrorString

ErrStr = TextType + ", GPI Code = " + ErrCode + ", Dev ErrCode = " + DevErrCode + ", " + DevErrString

'Set the path and filename of the log
sLogPath = App.Path & "\" & App.EXEName
sLogFile = sLogPath & ".log"
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fspenTextFile(sLogFile, ForAppending, True)

'Append the log-entry to the file together with time and date
f.WriteLine Now() & vbTab & ErrStr

End If

End Sub

Private Sub CodeRegisterField(FieldName As String)
Dim Error As GPIError, TextType As String

If FieldName = "" Then
'Do nothing
Else
Error = PrinterObj.PrepareRemoteField(FieldName)
If ((Error.Code <> NoError) And (FieldName = "Message")) Then
MsgBox "Error encountered, please retry.", vbExclamation, "RegisterField Error"
TextType = "RegisterField Error"
CodeDisplay Error, TextType
End If
End If
End Sub

Private Sub CodeSendField(FieldName As String, FieldText As String)
Dim Error As GPIError, TextType As String

If FieldName = "" Then
'Do Nothing
Else
Error = PrinterObj.SetRemoteField(FieldText, FieldName)
If ((Error.Code <> NoError) And (FieldName = "Message")) Then
MsgBox "Error encountered, please retry.", vbExclamation, "SendField Error"
TextType = "SendField Error"
CodeDisplay Error, TextType
End If
End If
End Sub