VB Forum / General 2 / July 2004

And then... on that boring half drunken Saturday night, one can do
this to waste a couple of hours.. no, the wife still talks to me, she
is just a bit crook.. :-/  
If we're all lucky it's been properly debugged, but you'll have to
work out the controls needed and the layout and must set the consts to
the paths in modMain. Oh, startup is to be set to Sub Main as well.

ps: I'll probably be ashamed for doing this by the morning. :-)

Form code :
--------------
Option Explicit

Private Const FOLDER_C = 0
Private Const PROJECT_C = 1
Private Const SILENT_C = 0
Private Const CLIPBOARD_C = 1

Private Declare Function ShellExecute 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
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As _
Long)
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As _
Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long _
Private Declare Function SetForegroundWindow Lib "user32" (ByVal _
hwnd As Long) As Long

Dim tCount As Long
Dim IsStart As Boolean

Private Sub DisableTimer()
   Timer1.Enabled = False
   cmdStart.Caption = "Launch"
End Sub

Private Sub StartVB()
   Dim s As String, s1 As String, sClip As String
   Dim ret As Long, ct As Long, hCb As Long
   s = vbNullString: s1 = vbNullString
   If chkStart(FOLDER_C).Value = vbChecked Then
       cfg.lastFolder = Trim$(txtStart(FOLDER_C).Text)
       s = cfg.lastFolder
       IsConfigDirty = True
   End If
   If chkStart(PROJECT_C).Value = vbChecked Then
       cfg.lastProject = Trim$(txtStart(PROJECT_C).Text)
       s1 = cfg.lastProject
       IsConfigDirty = True
   End If
   If chkOpts(CLIPBOARD_C).Value = vbChecked Then
       If Clipboard.GetFormat(vbCFText) = True Then
           sClip = Clipboard.GetText
       End If
   End If
   ret = ShellExecute(0&, "open", VB_EXEPATH_C, s1, s, 1)
   If ret < 32 Then
       MsgBox ("Launch failed !")
       Else
           Call Sleep(6000)
           On Error Resume Next
           If Len(sClip) > 0 Then Clipboard.SetText sClip
           Call SetForegroundWindow(Me.hwnd)
           If Err.Number <> 0 Then
               MsgBox ("Failed to restore clipboard")
               Else
                   MsgBox ("Clipboard restored")
           End If
           Unload Me
   End If
End Sub

Private Sub chkOpts_Click(Index As Integer)
   IsConfigDirty = Not IsStart
End Sub

Private Sub chkStart_Click(Index As Integer)
   DisableTimer
   txtStart(Index).Enabled = chkStart(Index).Value = vbChecked
   cmdBrowse(Index).Enabled = chkStart(Index).Value = vbChecked
   IsConfigDirty = Not IsStart
End Sub

Private Sub cmdBrowse_Click(Index As Integer)
   Dim ret As Long
   DisableTimer
   Dim b As RET_OPENFILENAME_T
   If Index = 0 Then ' browse for folder
       Dim s As String
       s = BrowseForFolder(Me, "VBLauncher - Start in Folder")
       If s <> "" Then
           txtStart(FOLDER_C).Text = s
       End If
       Else  'browse for VBPs
           With b
               .dlgTitle = "VBLauncher"
               .sFilter = "VB project files" & Chr$(0) & "*.vbp" & _
Chr$(0) & "All files" & Chr$(0) & "*.*" & Chr$(0) & Chr$(0)
               .nFilter = 0
               .openOpts = 0
               .hwnd = Me.hwnd
           End With
           ret = OpenFiles(b)
           If ret > 0 And b.bResult = True Then
               txtStart(PROJECT_C).Text = b.retStr(0)
           End If
           Debug.Print ret
   End If
End Sub

Private Sub cmdStart_Click()
   DisableTimer
   StartVB
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
   If Timer1.Enabled = True Then
       DisableTimer
       KeyAscii = 0
   End If
End Sub

Private Sub Form_Load()
   IsStart = True
   Me.Caption = "VB Launcher <hit space to stop countdown>"
   KeyPreview = True
   DisableTimer
   Timer1.Interval = 1000
   txtStart(FOLDER_C).Text = cfg.lastFolder
   txtStart(PROJECT_C).Text = cfg.lastProject
   chkOpts(SILENT_C).Caption = "Silent"
   chkOpts(CLIPBOARD_C).Caption = "Keep clipboard"
   chkStart(FOLDER_C).Caption = "Start in"
   chkStart(PROJECT_C).Caption = "Project"
   chkStart(FOLDER_C).Value = (cfg.IsFolderChecked And 1)
   chkStart(PROJECT_C).Value = (cfg.IsProjectChecked And 1)
   Call chkStart_Click(FOLDER_C)
   Call chkStart_Click(PROJECT_C)
   chkOpts(SILENT_C).Value = (cfg.IsSilent And 1)
   chkOpts(CLIPBOARD_C).Value = (cfg.KeepClipBoard And 1)
   txtTimeout.Text = cfg.TimeOut \ 1000
   Timer1.Enabled = True
   IsStart = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
   If IsConfigDirty = True Then WriteConfig
End Sub

Private Sub Timer1_Timer()
   tCount = tCount + Timer1.Interval
   If tCount <= cfg.TimeOut Then
       cmdStart.Caption = "Start in : " & (cfg.TimeOut \ 1000) - _
(tCount \ 1000)
       If chkOpts(SILENT_C).Value = vbChecked Then Beep
       Else
           DisableTimer
           StartVB
   End If
End Sub

Private Sub txtTimeout_Change()
   Dim l As Long
   If IsStart = False Then
       l = Val(txtTimeout.Text) * 1000
       If (l < 0) Or (l >= 65536) Then
           MsgBox ("Values between 0 and 65.535 only")
           Else
               cfg.TimeOut = l
       End If
       IsConfigDirty = True
   End If
End Sub

Private Sub txtTimeout_KeyPress(KeyAscii As Integer)
   Dim s As String
   If Not IsNumeric(Chr$(KeyAscii)) Then
       If (KeyAscii <> vbKeyBack) And (KeyAscii <> vbKeyDelete) And _
          (KeyAscii <> vbKeyLeft) And (KeyAscii <> vbKeyRight) Then
          KeyAscii = 0
       End If
   End If
   IsConfigDirty = True
End Sub
---------------------

modMain
----------
Option Explicit

Private Const CFG_FILE_C = "c:\vbstart.cfg"
Public Const VB_EXEPATH_C = "c:\mvs\vb98\vb6.exe"

Public Type CONFIG_T
   IsSilent As Boolean
   KeepClipBoard As Boolean
   TimeOut As Long
   IsFolderChecked As Boolean
   IsProjectChecked As Boolean
   lastFolder As String
   lastProject As String
End Type

Public cfg As CONFIG_T
Public IsConfigDirty As Boolean

Sub main()
   LoadConfig
   frmMain.Show
End Sub

Private Sub DefConfig()
   With cfg
       .IsSilent = False
       .KeepClipBoard = True
       .TimeOut = 30000
       .IsFolderChecked = False
       .IsProjectChecked = False
       .lastFolder = ""
       .lastProject = ""
   End With
   IsConfigDirty = True
End Sub

Private Sub LoadConfig()
   Dim hFile As Integer
   hFile = FreeFile
   Open CFG_FILE_C For Binary As hFile
   If LOF(hFile) = 0 Then
       Close hFile
       DefConfig
       Else
           Get #hFile, , cfg
           Close hFile
   End If
End Sub

Public Sub WriteConfig()
   Dim hFile As Integer
   hFile = FreeFile
   On Error Resume Next
   Kill CFG_FILE_C
   On Error GoTo 0
   With frmMain
       cfg.IsFolderChecked = .chkStart(0).Value
       cfg.IsProjectChecked = .chkStart(1).Value
       cfg.IsSilent = .chkOpts(0)
       cfg.KeepClipBoard = .chkOpts(1)
   End With
   
   Open CFG_FILE_C For Binary As hFile
       Put #hFile, , cfg
   Close hFile
   IsConfigDirty = False
End Sub

------------
modFileIO
------------
Option Explicit

Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_VALIDATE = &H20

Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000
Public Const OFN_LONGNAMES = &H200000
Public Const OFN_PATHMUSTEXIST = &H800
Public Const OFN_READONLY = &H1
Public Const OFN_SHAREAWARE = &H4000

Private Type OPENFILENAME
   lStructSize As Long
   hwndOwner As Long
   hInstance As Long
   lpstrFilter As String
   lpstrCustomFilter As String
   nMaxCustFilter As Long
   nFilterIndex As Long
   lpstrFile As String
   nMaxFile As Long
   lpstrFileTitle As String
   nMaxFileTitle As Long
   lpstrInitialDir As String
   lpstrTitle As String
   flags As Long
   nFileOffset As Integer
   nFileExtension As Integer
   lpstrDefExt As String
   lCustData As Long
   lpfnHook As Long
   lpTemplateName As String
End Type

Public Type RET_OPENFILENAME_T
   'sender fill
   dlgTitle As String
   sFilter As String
   nFilter As Long
   openOpts As Long
   hwnd As Long
       
   'return fill
   bResult As Boolean
   retStr As Variant
End Type

Private Type BROWSEINFO
  hwndOwner As Long
  pidlRoot As Long
  pszDisplayName As String
  lpszTitle As String
  ulFlags As Long
  lpfnCallBack As Long
  lParam As Long
  iImage As Long
End Type

Private Type SHITEMID
  cbSize As Integer
  abID As String * 256
End Type

Private Type ITEMIDLIST
  mkid As SHITEMID
End Type

Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory"
(Destination As Any, ByVal Length As Long)
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As
BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias
"SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String)
As Long
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal pv As Long)

Public Function OpenFiles(retBuf As RET_OPENFILENAME_T) As Long
   Dim ofn As OPENFILENAME
   Dim ret As Long
   retBuf.openOpts = retBuf.openOpts Or (OFN_EXPLORER Or
OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST Or OFN_SHAREAWARE)
       
   ZeroMemory ofn, Len(ofn)
   
   ofn.lStructSize = Len(ofn)
   ofn.flags = OFN_EXPLORER Or OFN_FILEMUSTEXIST
   ofn.hInstance = App.hInstance
   ofn.hwndOwner = retBuf.hwnd
   ofn.lpstrFile = Chr$(0) & Space$(1024) & Chr$(0) & Chr$(0)
   ofn.lpstrFileTitle = Chr$(0) & Space$(260) & Chr$(0) & Chr$(0)
   ofn.lpstrTitle = retBuf.dlgTitle & Chr$(0) & Chr$(0)
   ofn.lpstrFilter = retBuf.sFilter & Chr$(0) & Chr$(0)
   ofn.nFilterIndex = retBuf.nFilter
   ofn.nMaxFile = 1024
   ofn.nMaxFileTitle = 260
   ofn.nFileExtension = 5
   ofn.lpfnHook = 0
   ofn.lpstrInitialDir = App.Path & Chr$(0) & Chr$(0)
   retBuf.bResult = GetOpenFileName(ofn)
   If retBuf.bResult <> False Then
       retBuf.retStr = Split(ofn.lpstrFile, Chr$(0))
       OpenFiles = UBound(retBuf.retStr) - 1
   End If
End Function

Public Function BrowseForFolder(owner As Form, tit As String) As
String
   Dim bf As BROWSEINFO
   Dim idList As ITEMIDLIST
   Dim ret As Long
   Dim sRet As String * 260
   
   With bf
       .hwndOwner = owner.hwnd
       .lParam = 10
       .lpszTitle = tit
       .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_VALIDATE
       .pszDisplayName = Space$(260)
   End With
   
   ret = SHBrowseForFolder(bf)
   If ret <> 0 Then
        ret = SHGetPathFromIDList(ret, sRet)
        Call CoTaskMemFree(ret)
        BrowseForFolder = sRet
   End If
End Function