Visual Basic Source Code/Visual Basic Source Code.iso/vbsource/runner1a/shortcre.bas

BASIC Source File | 1999-09-14 | 11.7 KB | 335 lines

Attribute VB_Name = "ShrtCut"
Private Const kQuote = """"
Private Const kEmptyString = ""
Private Const kMaxPathLength = 260 ' Maximum allowed path & filename length.
Private Const kMaxGroupNameLength = 30 ' NT Maximum length that we allow for an group name.
Private Const kInvalid95GroupNameChars = "\/:*?""<>|" ' Invalid Windows 95 Group Name Characters.
Private Const kInvalidNTGroupNameChars = """][,)(" ' Invalid Windows NT Group Name Characters.
Private Const kDesktopGroup = "..\..\DESKTOP" ' Desktop Group.
Private Const kStartMenuGroup = ".." ' Start Menu Group.
'     'PROGRAM MANAGER ACTIONS'
Const kDDE_AddItem = 1 'AddProgManItem flag
Const kDDE_AddGroup = 2 'AddProgManGroup flag
'     'Other functions'
Declare Function GetWinPlatform Lib "VB5STKIT.DLL" () As Long

Declare Function fNTWithShell Lib "VB5STKIT.DLL" () As Boolean

Private Declare Function OSGetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long

Declare Function OSfCreateShellGroup Lib "VB5STKIT.DLL" Alias "fCreateShellFolder" (ByVal lpstrDirName As String) As Long

Declare Function OSfCreateShellLink Lib "VB5STKIT.DLL" Alias "fCreateShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String, ByVal lpstrLinkPath As String, ByVal lpstrLinkArguments As String) As Long

Declare Function OSfRemoveShellLink Lib "VB5STKIT.DLL" Alias "fRemoveShellLink" (ByVal lpstrFolderName As String, ByVal lpstrLinkName As String) As Long
Public Sub CreateShortcut(ByRef frm As Form, ByVal strGroupName As String, ByVal strLinkName As String, ByVal strLinkPath As String, ByVal strLinkArguments As String)
              If fCreateProgGroup(frm, strGroupName) Then

                            If TreatAsWin95() Then

                                   CreateShellLink strLinkPath, strGroupName, strLinkArguments, strLinkName
                            Else

                                   strLinkPath = GetShortPathName(strUnQuoteString(strLinkPath))
                                   CreateProgManItem frm, strGroupName, strLinkPath & " " & strLinkArguments, strLinkName
                            End If

              End If

End Sub


Private Sub CreateShellLink(ByVal strLinkPath As String, ByVal strGroupName As String, ByVal strLinkArguments As String, ByVal strLinkName As String)
       strLinkName = strUnQuoteString(strLinkName)
       strLinkPath = strUnQuoteString(strLinkPath)
       Dim fSuccess As Boolean
       fSuccess = OSfCreateShellLink(strGroupName & "", strLinkName, strLinkPath, strLinkArguments & "")

              If Not fSuccess Then
                     MsgBox "Create Shortcut Failed!", vbExclamation, "Ouch!"
              End If

End Sub


Private Sub CreateProgManItem(frm As Form, ByVal strGroupName As String, ByVal strCmdLine As String, ByVal strIconTitle As String)

       PerformDDE frm, strGroupName, strCmdLine, strIconTitle, kDDE_AddItem
End Sub


Private Sub PerformDDE(frm As Form, ByVal strGroup As String, ByVal strCmd As String, ByVal strTitle As String, ByVal intDDE As Integer)

       Const strCOMMA$ = ","
       Const strRESTORE$ = ", 1)]"
       Const strACTIVATE$ = ", 5)]"
       Const strENDCMD$ = ")]"
       Const strSHOWGRP$ = "[ShowGroup("
       Const strADDGRP$ = "[CreateGroup("
       Const strREPLITEM$ = "[ReplaceItem("
       Const strADDITEM$ = "[AddItem("
       Dim intIdx As Integer
       Screen.MousePointer = vbHourglass
       Dim intRetry As Integer

              For intRetry = 1 To 20
                     On Error Resume Next
                     frm.lblDDE.LinkTopic = "PROGMAN|PROGMAN"

                            If Err = 0 Then
                                   Exit For
                            End If


                            DoEvents
                            Next intRetry

                     frm.lblDDE.LinkMode = 2

                            For intIdx = 1 To 10
                                    DoEvents
                            Next

                     frm.lblDDE.LinkTimeout = 100
                     On Error Resume Next

                            If Err = 0 Then
                                   Select Case intDDE
                                   Case kDDE_AddItem

                                          #If 0 Then
                                                 frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strACTIVATE
                                          #Else
                                                 frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
                                          #End If

                                   frm.lblDDE.LinkExecute strREPLITEM & strTitle & strENDCMD
                                   Err = 0
                                   frm.lblDDE.LinkExecute strADDITEM & strCmd & strCOMMA & strTitle & String$(3, strCOMMA) & strENDCMD
                                   Case kDDE_AddGroup
                                   frm.lblDDE.LinkExecute strADDGRP & strGroup & strENDCMD
                                   frm.lblDDE.LinkExecute strSHOWGRP & strGroup & strRESTORE

                            End Select

              End If

       frm.lblDDE.LinkMode = 0
       frm.lblDDE.LinkTopic = ""
       Screen.MousePointer = vbDefault
       Err = 0
End Sub
Private Function fCreateProgGroup(frm As Form, sNewGroupName As String) As Boolean

              If UCase(Trim(sNewGroupName)) = kDesktopGroup Or sNewGroupName = kStartMenuGroup Then
                     fCreateProgGroup = True
                     Exit Function
              Else

                            If TreatAsWin95() Then


                                          If Not fValid95Filename(sNewGroupName) Then
                                                 MsgBox "Error: Could not validate the Program Group name!", vbQuestion, "Error"
                                                 GoTo CGError
                                          End If

                            Else


                                          If Not fValidNTGroupName(sNewGroupName) Then
                                                 MsgBox "Error: Could not validate the Program Group name!", vbQuestion, "Error"
                                                 GoTo CGError
                                          End If

                            End If

                            If Not fCreateOSProgramGroup(frm, sNewGroupName) Then
                                   GoTo CGError
                            End If

                     fCreateProgGroup = True
              End If

       Exit Function
CGError:
       fCreateProgGroup = False
End Function


Private Function fCreateShellGroup(ByVal strFolderName As String) As Boolean

       ReplaceDoubleQuotes strFolderName

              If strFolderName = "" Then
                     Exit Function
              End If

       Dim fSuccess As Boolean
       fSuccess = OSfCreateShellGroup(strFolderName)

              If fSuccess Then
              Else
                     MsgBox "Create Start Menu Group Failed!", vbExclamation, "Ouch!"
              End If

       fCreateShellGroup = fSuccess
End Function


Private Function fValid95Filename(strFilename As String) As Boolean

       Dim iInvalidChar As Integer
       Dim iFilename As Integer

              If Not ValidateFilenameLength(strFilename) Then
                     fValid95Filename = False
                     Exit Function
              End If

              For iInvalidChar = 1 To Len(kInvalid95GroupNameChars)

                            If InStr(strFilename, Mid$(kInvalid95GroupNameChars, iInvalidChar, 1)) <> 0 Then
                                   fValid95Filename = False
                                   Exit Function
                            End If

              Next iInvalidChar

       fValid95Filename = True
End Function


Public Function fValidNTGroupName(strGroupName) As Boolean
              If Len(strGroupName) > kMaxGroupNameLength Then
                     fValidNTGroupName = False
                     Exit Function
              End If
       Dim iInvalidChar As Integer
       Dim iFilename As Integer

              For iInvalidChar = 1 To Len(kInvalidNTGroupNameChars)

                            If InStr(strGroupName, Mid$(kInvalidNTGroupNameChars, iInvalidChar, 1)) <> 0 Then
                                   fValidNTGroupName = False
                                   Exit Function
                            End If

              Next iInvalidChar

       fValidNTGroupName = True
End Function


Private Function fCreateOSProgramGroup(frm As Form, ByVal strFolderName As String) As Boolean


              If TreatAsWin95() Then
                     fCreateOSProgramGroup = fCreateShellGroup(strFolderName)
              Else
                     CreateProgManGroup frm, strFolderName
                     fCreateOSProgramGroup = True
              End If

End Function


Private Sub CreateProgManGroup(frm As Form, ByVal strGroupName As String)

       PerformDDE frm, strGroupName, kEmptyString, kEmptyString, kDDE_AddGroup
End Sub
Private Function TreatAsWin95() As Boolean


              If IsWindows95() Then
                     TreatAsWin95 = True
              ElseIf fNTWithShell() Then
                     TreatAsWin95 = True
              Else
                     TreatAsWin95 = False
              End If

End Function


Private Function IsWindows95() As Boolean

       Const dwMask95 = &H2&

              If GetWinPlatform() And dwMask95 Then
                     IsWindows95 = True
              Else
                     IsWindows95 = False
              End If

End Function


Private Function strUnQuoteString(ByVal strQuotedString As String)
       strQuotedString = Trim(strQuotedString)

              If Mid$(strQuotedString, 1, 1) = kQuote And Right$(strQuotedString, 1) = kQuote Then
                     '     ' It's quoted. Get rid of the quotes.
                     strQuotedString = Mid$(strQuotedString, 2, Len(strQuotedString) - 2)
              End If

       strUnQuoteString = strQuotedString
End Function


Private Function StripTerminator(ByVal strString As String) As String

       Dim intZeroPos As Integer
       intZeroPos = InStr(strString, Chr$(0))

              If intZeroPos > 0 Then
                     StripTerminator = Left$(strString, intZeroPos - 1)
              Else
                     StripTerminator = strString
              End If

End Function


Private Sub ReplaceDoubleQuotes(str As String)

       Dim i As Integer

              For i = 1 To Len(str)

                            If Mid$(str, i, 1) = """" Then
                                   Mid$(str, i, 1) = "'"
                            End If

              Next i

End Sub



Private Function GetShortPathName(ByVal strLongPath As String) As String

       Const cchBuffer = 300
       Dim strShortPath As String
       Dim lResult As Long
       On Error GoTo 0
       strShortPath = String(cchBuffer, Chr$(0))
       lResult = OSGetShortPathName(strLongPath, strShortPath, cchBuffer)

              If lResult = 0 Then
                     Error 53
              Else
                     GetShortPathName = StripTerminator(strShortPath)
              End If

End Function


Private Function ValidateFilenameLength(strFilename As String) As Boolean

       ValidateFilenameLength = (Len(strFilename) < kMaxPathLength)
End Function