'NOTE: In Visual Basic 5.0, change Stkit432.dll in the following
      'statement to Vb5stkit.dll. 
      'для VB6 - Vb6stkit.dll
      Private Declare Function fCreateShellLink Lib "STKIT432.DLL" (ByVal _
       lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal _
       lpstrLinkPath As String, ByVal lpstrLinkArgs As String) As Long
      Sub Command1_Click()
        Dim lReturn As Long
        'Add to Desktop
        lReturn = fCreateShellLink( "..\..\Desktop" , _
         "Shortcut to Calculator" ,  "c:\Winnt\system32\calc.exe" ,  "")
        'Add to Program Menu Group
        lReturn = fCreateShellLink("", "Shortcut to Calculator", _
        "c:\Winnt\system32\calc.exe", "")
        'Add to Startup Group
        'Note that on Windows NT, the shortcut will not actually appear
        'in the Startup group until your next reboot.
        lReturn = fCreateShellLink(" \Startup ", " Shortcut to Calculator ", _
        " c:\Winnt\system32\calc.exe ", " ")
      End Sub

Option Compare Database
Option Explicit

'************ Code Start **********



Private Declare Function apiShellExecute Lib "shell32.dll" _
                                         Alias "ShellExecuteA" _
                                         (ByVal hWnd As Long, _
                                          ByVal lpOperation As String, _
                                          ByVal lpFile As String, _
                                          ByVal lpParameters As String, _
                                          ByVal lpDirectory As String, _
                                          ByVal nShowCmd As Long) _
                                         As Long

'***App Window Constants***
Public Const WIN_NORMAL =  1     'Open Normal
Public Const WIN_MAX = 2    'Open Maximized
Public Const WIN_MIN =  3     'Open Minimized

'***Error Codes***
Private Const ERROR_SUCCESS =  32 &
Private Const ERROR_NO_ASSOC =  31 &
Private Const ERROR_OUT_OF_MEM =  0 &
Private Const ERROR_FILE_NOT_FOUND =  2 &
Private Const ERROR_PATH_NOT_FOUND =  3 &
Private Const ERROR_BAD_FORMAT =  11 &

'***************Usage Examples***********************
'Open a folder: ?ShellExecuteMy( "C:\TEMP\" ,WIN_NORMAL)
'Call Email app: ?ShellExecuteMy("mailto:dash10@hotmail.com",WIN_NORMAL)
'Open URL: ?ShellExecuteMy( "http://home.att.net/~dashish" , WIN_NORMAL)
'Handle Unknown extensions (call Open With Dialog):
' ?ShellExecuteMy( "C:\TEMP\TestThis" ,Win_Normal)
'Start Access instance:
' ?ShellExecuteMy( "I:\mdbs\CodeNStuff.mdb" , Win_NORMAL)
'****************************************************

Function ShellExecuteMy(stFile As String, lShowHow As Long)
    Dim lRet As Long, varTaskID    As Variant
    Dim stRet                      As String
    'First try ShellExecute
    lRet = apiShellExecute(hWndAccessApp, vbNullString, _
                           stFile, vbNullString, vbNullString, lShowHow)

    If lRet > ERROR_SUCCESS Then
        stRet = vbNullString
        lRet = - 1 
    Else
        Select Case lRet
            Case ERROR_NO_ASSOC:
                'Try the OpenWith dialog
                varTaskID = Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " _
                                & stFile, WIN_NORMAL)
                lRet = (varTaskID <> 0)
            Case ERROR_OUT_OF_MEM:
                stRet = "Error: Out of Memory/Resources. Couldn't Execute! "
            Case ERROR_FILE_NOT_FOUND:
                stRet = " Error: File not found. Couldn't Execute!"
            Case ERROR_PATH_NOT_FOUND:
                stRet = "Error: Path not found. Couldn't Execute! "
            Case ERROR_BAD_FORMAT:
                stRet = " Error: Bad File Format. Couldn't Execute!"
            Case Else:
        End Select
    End If
    ShellExecuteMy = lRet & _
                     IIf(stRet = "", vbNullString, ", " & stRet)
End Function
'************ Code End **********

Public Function IsLoadedExcel() As Boolean
' Dectects a running Excel '
    Dim hWnd                       As Long
    hWnd = FindWindow( "XLMAIN" ,  0 )
    If hWnd =  0  Then
        IsLoadedExcel = False
    Else
        IsLoadedExcel = True
    End If
End Function