nResult = Shell(sFile, vbNormalFocus)

nResult = ShellExecute(hWnd, "", sFile, "", sWorkDir, SW_SHOWNORMAL)

Sub Main()
 
   Dim bExtAppIsRunning as Boolean
   Dim bStartOK as Boolean
 
   bStartOK = False
 
   bExtAppIsRunning =IsEXERunning(sFile)
 
   If Not bExtAppIsRunning Then
      bStartOK = EXEStartOK(sFile)
   End If
 
   If Not bStartOK Then
      If bExtAppIsRunning Then
         MsgBox "Externe Anwendung ist bereits gestartet!" 
      Else
         MsgBox "Beim Aufruf der externen Anwendung trat ein Fehler auf!"
      End If
   End If
 
   End
 
End Sub

Tschaui
Woellmi

Sub Main()
   Dim bExtAppIsRunning as Boolean
   Dim bStartOK as Boolean
 
   If Not App.PrevInstance Then
      bStartOK = False
 
      bExtAppIsRunning =IsEXERunning(sFile)
 
      If Not bExtAppIsRunning Then
         bStartOK = EXEStartOK(sFile)
      End If
 
      If Not bStartOK Then
         If bExtAppIsRunning Then
            MsgBox "Externe Anwendung ist bereits gestartet!" 
         Else
            MsgBox "Beim Aufruf der externen Anwendung trat ein Fehler auf!"
         End If
      End If
   End If
 
   End
 
End Sub

Tschaui
Woellmi

Tschaui
Woellmi

nResult = Shell(sFile, vbNormalFocus)
 
nResult = ShellExecute(hWnd, "", sFile, "", sWorkDir, SW_SHOWNORMAL)

EALA FREYA FRESENA

Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _
   (ByVal lpMutexAttributes As Long, _
    ByVal bInitialOwner As Long, _
    ByVal lpName As String) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As _
  Long
 
Private Const ERROR_ALREADY_EXISTS = 183&
 
Private m_hMutex As Long
Private Const s_NamedMutex As String = "MyExistAppCheck" 'Der Name des Mutex 
' ist eigentlich egal,
                                                         'soll aber in der App 
                                                         ' unikat sein
 
Public Sub Main()
    m_hMutex = CreateMutex(0&, 1, s_NamedMutex)
 
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
       MsgBox "Das ist der zweite Start der Anwendung"
       Exit Sub
    End If
 
    MsgBox "Das ist der erste Start der Anwendung"
 
    CloseHandle m_hMutex
    'CloaseHandle gibt den Mutex wieder frei, so dass ein dritter Versucht 
    ' wieder
    'erfolgreich die App starten kann. Der vierte Versuch wird wieder geblockt 
    ' usw.
 
End Sub

Tschaui
Woellmi

Tschaui
Woellmi

Tschaui
Woellmi

Tschaui
Woellmi

Sub Main()
    static nCounter as Long
 
    hMutex=CreateMutex(0&, 1&, "AufrufendesProg")
 
    nCounter = nCounter + 1
    If Is2ndProgStarted() Then
       MsgBox "Fehler: bitte 2ndProg beenden! (" & Cstr(nCounter) & ")"
    Else
       Start2ndProg() 
       'Hier fehlt eine Function die verhindert dass der Thread die If-Anweisung
       'nicht gleich verlassen kann. Es wird sofort CloseHandle hMutex 
       ' aufgerufen, sofern
       'das andere Programm asynchron gestartet wurde. Die Funktionen Shell und 
       ' ShellExecute()
       'sind asynchrone Funktionen!       
    End If
 
    CloseHandle hMutex
 
End Sub

Private Declare Function CreateMutex Lib "kernel32" Alias "CreateMutexA" _
   (ByVal lpMutexAttributes As Long, _
    ByVal bInitialOwner As Long, _
    ByVal lpName As String) As Long
 
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) 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 WaitForSingleObject Lib "kernel32.dll" ( _
     ByVal hHandle As Long, _
     ByVal dwMilliseconds As Long) As Long
 
Private Const ERROR_ALREADY_EXISTS = 183&
Private Const PROCESS_SYNCHRONIZE = &H100000
Private Const INFINITE As Long = &HFFFFFFFF
 
 
Private m_hMutex As Long
Private Const s_NamedMutex As String = "MyExistAppCheck" 'Der Name des Mutex
                                                         ' ist eigentlich egal,
                                                         'soll aber in der App
                                                         ' unikat sein
Public Sub Main()
    Dim hProcessID As Long
    Dim hProcess As Long
 
    m_hMutex = CreateMutex(0&, 1, s_NamedMutex)
 
    If Err.LastDllError = ERROR_ALREADY_EXISTS Then
       MsgBox "Solange die andere Anwendung läuft kann das Programm nicht" & _
         "wieder gestartet werden"
       Exit Sub
    End If
 
    hProcessID = Shell("NotePad.EXE", 1)
    hProcess = OpenProcess(PROCESS_SYNCHRONIZE, True, hProcessID)
 
    'Warten bis der Prozess beendet wurde. VB-Programm startet Notepad.EXE und
    'es wird sich hier weiter nichts tun, bis Notepad.EXE geschlossen wurde.
    WaitForSingleObject hProcess, INFINITE
 
    MsgBox "Der zweite Prozess wurde geschlossen, jetzt das Mutex und das" & _
      "Process-Object freigeben"
 
    CloseHandle hProcess
    CloseHandle m_hMutex
 
End Sub

Tschaui
Woellmi

Option Explicit
Public sg__File As String   '//Übergabe aus oFr
Private oFrm As frmMain     '//Dummy-For
Private n__hMutex As Long 
Sub Main()
 Dim nCopyResult As Long
 Dim sDestKeyFile As String
 Dim nMainResult As Long
 Dim sFileToStart As String
 Dim hProcessID As Long
 Dim hProcess As Long
 n__hMutex = CreateMutex(0&, 1, "MeinAufrufProgName")
 If Err.LastDllError = ERROR_ALREADY_EXISTS Then
   'sub_ShowMessage 0&                  '//Hier die "BÖSE" Meldung ( _
     auskommentiert)
   Exit Sub
 End If
 'IsEXERunning => nach Tipp aus vb@rchiv
 If IsEXERunning("MeinZielProg") Then
   sub_ShowMessage 1&    '//Fehlermeldung
 Else
   'Hier versuche ich es nochmal, ob's Sinn macht?
   If App.PrevInstance Then
      sub_ShowMessage 0&      '//Fehlermeldung
   Else
     'Startumgebung ermitteln/festlegen
      bg_RegistratorOK = False
      bg_INIFileExists = False
      bg_ExeFileExists = False
      bg_KeyFileExists = False
      bg_RegisterFile = False
      'es wird sich der Installationsort der Aufgerufenen Datei aus einer INI 
      ' geholt,
      'welche bei der Installation (InnoSetup) ausgefuellt wird.
      '[FileInfo]
      'EXEFolder=C:\Prgramme\MeineZielanwendung\
      'Keine Registry-Nutzung
      sg_PT32AppDataDir = B_GETSPECFOLDER(MEW_SSF_COMMONAPPDATA) & _
        "\MeinAppDataFolder\")
      sg_AppDIR = VB_GetPath2Dir(App.Path)
      sg_PT32INIFile = sg_PT32AppDataDir & "MeineINIDatei.INI"
      bg_INIFileExists = VB_FileExistsEx(sg_PT32INIFile)
      'Aufrufparameter prüfen (csg_KEYFILENAME = PT32SEVL.KEY)
      sg_KeyFile = VB_GetPath2Dir(App.Path) & csg_KEYFILENAME
      'wurde ggf. ein Kommandoparameter übergeben?
      sg_Command = f_sGetParameterFile(Command)
      If sg_Command <> "Error" Then
         sg_KeyFile = sg_Command          'z.B. 
         ' C:\Users\ICH\Desktop\PT32SELV.KEY
      End If          
      If bg_INIFileExists Then
         sg_PT32EXEFolder = VB_ReadINIStr(csg_INIKEY_EXEFOLDER, _
                            csg_INISEC_FILEINFO, sg_PT32INIFile)
         If Len(sg_PT32EXEFolder) > 0& Then
             bg_ExeFileExists = VB_FileExistsEx(VB_GetPath2Dir( _
                                sg_PT32EXEFolder) & csg_PT32EXENAME)
             If bg_ExeFileExists Then
                bg_KeyFileExists = VB_FileExistsEx(sg_KeyFile)
                If bg_KeyFileExists Then
                   bg_RegisterFile = True
                Else
                   'Dialog im Hintergrund öffnen ohne angezeigt zu werden.
                   ' Es erscheint nur der Eingabedialog
                   Set oFrm = New frmMain
                   oFrm.Show
                   Unload oFrm
                   Set oFrm = Nothing
                   If sg__File <> "Canceled" Then
                      sg_KeyFile = sg__File
                      bg_KeyFileExists = VB_FileExistsEx(sg_KeyFile)
                      If bg_KeyFileExists Then
                         bg_RegisterFile = True
                      Else
                         sub_ShowMessage 2&
                      End If
                   Else
                      sub_ShowMessage 3&
                   End If
                End If
             Else
                sub_ShowMessage 4&
             End If
          Else
             sub_ShowMessage 5&
          End If
       Else
          sub_ShowMessage 6&
       End If          
       If bg_RegisterFile Then
          sDestKeyFile = VB_GetPath2Dir(VB_GetPath2Dir( _
                         VB_GETSPECFOLDER(MEW_SSF_COMMONAPPDATA)) & _
                         csg_PT32APPDATAFOLDER) & csg_KEYFILENAME
          nCopyResult = CopyFile(sg_KeyFile, sDestKeyFile, 0&)
          If VB_FileExistsEx(sDestKeyFile) Then
             sFileToStart = VB_GetPath2Dir(sg_PT32EXEFolder) & csg_PT32EXENAME
             If Len(sFileToStart) > 0& And VB_FileExistsEx(sFileToStart) Then
                hProcessID = Shell(sFileToStart, vbNormalFocus)                   
                If hProcessID > 0& Then
                   hProcess = OpenProcess(PROCESS_SYNCHRONIZE, True, hProcessID)
                   'Warten bis der Prozess beendet wurde. VB-Programm startet 
                   ' ZielProg und
                   'es wird sich hier weiter nichts tun, bis das ZielProg 
                   ' geschlossen wurde.
                   WaitForSingleObject hProcess, INFINITE                    
                   'Hier wird erst dann weitergemacht, wenn die ZielProg 
                   ' beendet wurde.
                   sub_ShowMessage 100&  '//Alles OK, fertig
                Else
                   sub_ShowMessage 7&
                End If
             Else
                sub_ShowMessage 8&
             End If
          Else
             sub_ShowMessage 9&
          End If
       End If
    End If
 End If   
 If hProcess <> 0& Then: CloseHandle hProcess
 CloseHandle n__hMutex
 Exit Sub
End Sub

Tschaui
Woellmi

Private Sub sub_ShowMessage(ByVal nMsg As Long)
  Dim sPrompt As String
  Dim sTitle As String
  Dim nKeys As String
  Select Case nMsg
    Case 0&: '.. Fehler 0
       sPrompt = "..."
       nKeys = vbInformation + vbOKOnly
       sTitle = "..."
       '...
    Case 100&
       sPrompt = "OK, Aktiviert."
       nKeys = vbInformation + vbOKOnly
       sTitle = App.Title
 End Select
 MsgBox sPrompt, nKeys, sTitle
End Sub

Private Function f_sGetParameterFile(ByVal s_CMD As String) As String
  Dim nIdx As Long
  Dim asgCMDs() As String
  Dim nNumOfCMDs As Long
  Dim sData As String
  'Lizenzdatei im Parameter?
  f_sGetParameterFile = "Error"
  If Len(s_CMD) > 0 Then
    asgCMDs = Split(s_CMD, """")
    nNumOfCMDs = UBound(asgCMDs) + 1&
    For nIdx = 0 To nNumOfCMDs - 1&
      sData = asgCMDs(nIdx)
      asgCMDs(nIdx) = VB_Remove(sData, """")
      If InStr(UCase(asgCMDs(nIdx)), UCase(csg_KEYFILENAME)) > 0& Then
         f_sGetParameterFile = asgCMDs(nIdx)
         Exit For
       End If
    Next nIdx
 End If
End Function

Global Const OFN_ALLOWMULTISELECT As Long = &H200  
Global Const OFN_CREATEPROMPT As Long = &H2000     
Global Const OFN_EXPLORER As Long = &H80000         
Global Const OFN_EXTENSIONDIFFERENT As Long = &H400 
Global Const OFN_FILEMUSTEXIST As Long = &H1000     
Global Const OFN_HelpButton As Long = &H10          
Global Const OFN_HIDEREADONLY As Long = &H4           
Global Const OFN_LONGNAMES As Long = &H200000         
Global Const OFN_NOCHANGEDIR As Long = &H8            
Global Const OFN_NODEREFERENCELINKS As Long = &H100000
Global Const OFN_NOLONGNAMES As Long = &H40000    
Global Const OFN_NOREADONLYRETURN As Long = &H8000
Global Const OFN_NOVALIDATE As Long = &H100   
Global Const OFN_OVERWRITEPROMPT As Long = &H2
Global Const OFN_PATHMUSTEXIST As Long = &H800
Global Const OFN_READONLY As Long = &H1       
Global Const OFN_SHAREAWARE As Long = &H4000  
Global Const OFS_FILE_OPEN_FLAGS As Long = OFN_EXPLORER Or OFN_LONGNAMES Or _
  OFN_CREATEPROMPT Or OFN_NODEREFERENCELINKS
'Dateiauswahldialog
Type OPENFILENAME
  nStructSize     As Long
  hwndOwner       As Long
  hInstance       As Long
  sFilter         As String
  sCustomFilter   As String
  nCustFilterSize As Long
  nFilterIndex    As Long
  sFile           As String
  nFileSize       As Long
  sFileTitle      As String
  nTitleSize      As Long
  sInitDir        As String
  sDlgTitle       As String
  flags           As Long
  nFileOffset     As Integer
  nFileExt        As Integer
  sDefFileExt     As String
  nCustData       As Long
  fnHook          As Long
  sTemplateName   As String
End Type
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" ( _
  pOpenfilename As OPENFILENAME) As Long
 
Function fkt_sDelectKeyFile(Optional sPath As String) As String
 
    Dim sFilter As String
    Dim uOFN As OPENFILENAME
    uOFN.nStructSize = Len(uOFN)
    uOFN.hwndOwner = GetActiveWindow()
    sFilter = "Mein Key-File(PT32SEVL.key)" & vbNullChar & "PT32SEVL.key" & _
      vbNullChar
    sFilter = sFilter & vbNullChar & vbNullChar
    uOFN.sFilter = sFilter
    uOFN.nFilterIndex = 1
    uOFN.sDlgTitle = "Key File not automatically found. Please select manually:" 
    uOFN.flags = OFS_FILE_OPEN_FLAGS
    uOFN.sFile = Space$(256) & vbNullChar
    uOFN.nFileSize = Len(uOFN.sFile)
    uOFN.sFileTitle = Space$(256) & vbNullChar
    uOFN.nTitleSize = Len(uOFN.sFileTitle)
    If Not IsMissing(sPath) Then
       uOFN.sInitDir = sPath
    End If
    If GetOpenFileName(uOFN) Then
        fkt_sDelectKeyFile = Left(uOFN.sFile, InStr(uOFN.sFile, vbNullChar) - 1)
    Else
        fkt_sDelectKeyFile = "Canceled"
    End If
End Function

'Meine Geisterform:
Private Sub cmdExit_Click()
  Unload Me
End Sub
Private Sub Form_Load()
  sg__File = fkt_sDelectKeyFile(App.Path)
  Me.Hide
End Sub

Tschaui
Woellmi