Option Explicit
' $Archive: $
' $Author: $
' $Date: $
' $Revision: $

Const module_name = "SourceSafe" 'this name must be unique.
Const module_desc = "Source code control commands" 'script description
Const module_ver  = "0.2" 'version: added multi-file commands and language settings.
' For more information on Visual SourceSafe programming, see the following website:
' http://msdn.microsoft.com/library/en-us/dnvss/html/vssauto.asp

Const VSSITEM_PROJECT = 0
Const VSSITEM_FILE = 1
Const VSSFILE_NOTCHECKEDOUT = 0
Const VSSFILE_CHECKEDOUT = 1
Const VSSFILE_CHECKEDOUT_ME = 2
Dim LINE_END 'Not a real constant, because functions are called
LINE_END = Chr(13) & Chr(10)

'-----------------------------
' SETTINGS. ADAPT TO YOUR NEED.
Const cSCC_DATABASE = "(full path to srcsafe.ini)"
Const cSCC_USER_NAME = "Dikkie Dik"
Const cSCC_PASSWORD = ""
Const cUSE_DEFAULT_LOGIN_DETAILS = True ' If true, do not use the above settings, but the default (last used database, windows user name, no password)
'If True, the "Edit this script" option is added to the menu. Handy when debugging.
Const cADD_EDIT_ME_TO_MENU = True
'-----------------------------
' LANGUAGE SETTINGS.
'-----------------------------
Const cMENU_ADD_FILE = "Add file to sourcesafe"
Const cMENU_CHECK_IN_FILE = "Check &in"
Const cMENU_CHECK_OUT_FILE = "Check &out"
Const cMENU_EDIT_ME = "Edit this script"
Const cMENU_FILE_LATEST_VERSION = "Get latest version"
Const cMENU_FILE_UNDO_CHECKOUT = "Undo checkout"
Const cMENU_FILE_HISTORY = "Show &history"
Const cMENU_FILE_STATUS = "Show &status"
Const cMENU_FILE_LINKS = "Show &links"
Const cMENU_CHECK_IN_ALL = "Check in all files in project"
Const cMENU_ALL_LATEST_VERSION = ""
'    (END OF SETTINGS.)
'-----------------------------

Dim mobjDatabase
Dim mstrCurrentProject
Dim mstrUserName
mstrCurrentProject=""

Sub AddToSourceSafe()
 Dim strComment, strFile, objSource, objProject, strProjectSpec
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 If objSource Is Nothing Then
   strProjectSpec = InputBox("Please specify a project", , mstrCurrentProject)
   Set objProject = mobjDatabase.VSSItem(strProjectSpec)
   If Not IsNull(objProject) Then
     If objProject.Type=VSSITEM_PROJECT Then
       strComment = InputBox("Comment:", , "First creation.")
       objProject.Add strFile, strComment
       ReloadCurrentFile()
     Else
       echo strProjectSpec & " is not a project."
     End If
   Else
     echo "Project " & strProjectSpec & " not found."
   End If
 Else
   echo "This file is already known in SourceSafe."
 End If
End Sub

Sub CheckIn()
 Dim strComment, strFile, objSource
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   Select Case objSource.IsCheckedOut
         Case VSSFILE_NOTCHECKEDOUT:
             echo strFile & " was not checked out."
         Case VSSFILE_CHECKEDOUT_ME:
             strComment = InputBox("Check-in comment:", "Please describe the change", objSource.CheckOuts.Item(1).Comment)
             objSource.CheckIn strComment, strFile
             ReloadCurrentFile()
         Case VSSFILE_CHECKEDOUT: 'Check out by ANOTHER user
             strMessage = strFile & " is checked out by " & objSource.CheckOuts.Item(1).UserName
             If objSource.CheckOuts.Item(1).Comment<>"" Then
               strMessage = strMessage & " with comment: " & objSource.CheckOuts.Item(1).Comment
             End If
             MsgBox strMessage, , "Conflict"
   End Select 
 End If
End Sub

Sub CheckInAll()
 dim numCount, objRoot, objLog, strFile, strComment
 Set objRoot = SourceSafeDatabase().VSSItem("$\")
 Set objLog = New clsLogWriter
 strComment = InputBox("Check-in comment:")
 For numCount = 0 To projectFilesCount-1
    strFile = projectFiles(numCount)
    FileCheckIn ItemIn(objRoot, Ucase(strFile)), strFile, strComment, objLog
 Next
End Sub

Sub CheckOut()
 Dim objSource, strFile, strComment, strMessage
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   Select Case objSource.IsCheckedOut
         Case VSSFILE_NOTCHECKEDOUT:
             strComment = InputBox("Check-out comment:", "Please describe the planned change")
             objSource.CheckOut strComment, strFile
             ReloadCurrentFile()
         Case VSSFILE_CHECKEDOUT_ME:
             MsgBox "You have already checked out " & strFile
         Case VSSFILE_CHECKEDOUT: 'Check out by ANOTHER user
             strMessage = strFile & " is checked out by " & objSource.CheckOuts.Item(1).UserName
             If objSource.CheckOuts.Item(1).Comment<>"" Then
               strMessage = strMessage & " with comment: " & objSource.CheckOuts.Item(1).Comment
             End If
             MsgBox strMessage, , "Conflict"
   End Select 
 End If
End Sub

Function CurrentFileName()
 With newEditor()
      .assignActiveEditor()
      CurrentFileName = .fileName()
 End With
End Function

Sub EditMe()
 With newEditor()
      .openFile(moduleFileName(module_name))
 End With
End Sub

Sub FileCheckIn(ByVal objSource, ByVal strFile, ByVal strComment, ByVal objLogWriter)
 Dim strMessage
 With objLogWriter
     If objSource Is Nothing Then
       .WriteLine strFile & " is not known in sourcesafe."
     Else
       Select Case objSource.IsCheckedOut
             Case VSSFILE_NOTCHECKEDOUT:
                 .WriteLine strFile & " was not checked out."
             Case VSSFILE_CHECKEDOUT_ME:
                 objSource.CheckIn strComment, strFile
                 ReloadIfActive strFile
                 .WriteLine strFile & " is checked in."
             Case VSSFILE_CHECKEDOUT:
                 strMessage = strFile & " is checked out by " & objSource.CheckOuts.Item(1).UserName
                 If objSource.CheckOuts.Item(1).Comment<>"" Then
                   strMessage = strMessage & " with comment: " & objSource.CheckOuts.Item(1).Comment
                 End If
                 .WriteLine strMessage
       End Select
     End If
 End With
End Sub

Sub GetLatestVersion()
 Set objSource = SourceSafeRef()
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   objSource.Get
   ReloadCurrentFile()
 End If
End Sub

Sub Init
 Dim strModuleName
 strModuleName = "&" & module_name
 With New clsAccesskeyGenerator
     addMenuItem .WithAccessKey(cMENU_ADD_FILE), strModuleName, "AddToSourceSafe"
     addMenuItem .WithAccessKey(cMENU_CHECK_IN_FILE), strModuleName, "CheckIn"
     addMenuItem .WithAccessKey(cMENU_CHECK_OUT_FILE), strModuleName, "CheckOut"
     addMenuItem .WithAccessKey(cMENU_FILE_LATEST_VERSION), strModuleName, "GetLatestVersion"
     addMenuItem .WithAccessKey(cMENU_FILE_UNDO_CHECKOUT), strModuleName, "UndoCheckOut"
     addMenuItem "-", strModuleName, ""
     addMenuItem .WithAccessKey(cMENU_FILE_HISTORY), strModuleName, "ShowHistory"
     addMenuItem .WithAccessKey(cMENU_FILE_STATUS), strModuleName, "ShowStatus"
     addMenuItem .WithAccessKey(cMENU_FILE_LINKS), strModuleName, "ShowLinks"
     addMenuItem "-", strModuleName, ""
     addMenuItem .WithAccessKey(cMENU_CHECK_IN_ALL), strModuleName, "CheckInAll"
     If cADD_EDIT_ME_TO_MENU Then
       addMenuItem "-", strModuleName, ""
       addMenuItem .WithAccessKey(cMENU_EDIT_ME), strModuleName, "EditMe"
     End If
 End With
End Sub

Function ItemIn(ByVal objProject, ByVal strName)
 Dim objItem, objResult, numCount
 numCount = objProject.Items.Count
 Set objResult = Nothing
 While numCount>0
      Set objItem = objProject.Items.Item(numCount)
      If objItem.Type = VSSITEM_FILE Then
        If Ucase(objItem.LocalSpec) = strName Then
          Set objResult = objItem
          mstrCurrentProject = objItem.Parent.Spec
          numCount = -1
        End If
      Else
        Set objItem = ItemIn(objItem, strName)
        If Not(objItem Is Nothing) Then
          Set objResult = objItem
          numCount = -1
        End If
      End If
      numCount = numCount -1
 Wend
 Set ItemIn = objResult
End Function

Function NewLog()
 Dim edtLog
 Set edtLog = newEditor()
 edtLog.assignLog()
 edtLog.text "" 'Clear contents
 Set NewLog = edtLog
End Function

Sub ReloadCurrentFile() 'built-in function does not work
 dim numLine
 With newEditor
     .assignActiveEditor
     numLine = .caretY
     .openFile CurrentFileName
     .caretY numLine
 End With
End Sub

Sub ReloadIfActive(ByVal strFile)
 Dim numCount, edt, numLine
 numCount = editorsCount - 1
 With newEditor
     While numCount>=0
          .assignEditorByIndex(numCount)
          If .fileName=strFile Then
            numLine = .caretY
            .openFile CurrentFileName
            .caretY numLine
            numCount = -1' Exit the loop neatly
          End If
          numCount = numCount - 1
     Wend
 End With
End Sub

Sub ShowHistory()
 Dim strFile, objSource, intCount, objHistory, strLabel, strUser, strComment, edtLog
 Set edtLog = NewLog()
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 intCount = 0
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   For Each objHistory In objSource.Versions
      edtLog.appendText("Version " & objHistory.VersionNumber & ":" & LINE_END)
      edtLog.appendText("   Action        : " & objHistory.Action & " at " & FormatDateTime(objHistory.Date) & LINE_END)
      strComment = objHistory.Comment
      If strComment<>"" Then
        edtLog.appendText("   Comment       : " & strComment & LINE_END)
      End If
      strUser = objHistory.UserName
      If strUser<>mstrUserName Then
        edtLog.appendText("   User          : " & strUser & LINE_END)
      End If
      strLabel = objHistory.Label
      If strLabel<>"" Then
        edtLog.appendText("   Label         : " & strLabel & LINE_END)
        edtLog.appendText("   Label comment : " & objHistory.LabelComment & LINE_END)
      End If
      intCount = intCount + 1
   Next
   If intCount = 0 Then
     edtLog.appendText("No history entries found." & LINE_END)
   End If
 End If
End Sub

Sub ShowLinks()
 Dim strFile, objSource, objLink, intCount
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 intCount = 0
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   Set edtLog = NewLog()
   For Each objLink In objSource.Links
      If objSource.Spec<>objLink.Spec Then
        edtLog.appendText("Also used in project: " & objLink.Parent.Name & LINE_END)
        intCount = intCount + 1
      End If
   Next
   If intCount = 0 Then
     edtLog.appendText("No links to other projects found." & LINE_END)
   End If
 End If
End Sub

Sub ShowStatus()
 Dim strFile, objSource, strMessage
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 If objSource Is Nothing Then
   echo strFile & " is not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   Select Case objSource.IsCheckedOut
         Case VSSFILE_NOTCHECKEDOUT:
             echo strFile & " is not checked out."
         Case VSSFILE_CHECKEDOUT_ME:
             echo strFile & " is checked out by you."
         Case VSSFILE_CHECKEDOUT: 'Check out by ANOTHER user
             strMessage = strFile & " is checked out by " & objSource.CheckOuts.Item(1).UserName
             If objSource.CheckOuts.Item(1).Comment<>"" Then
               strMessage = strMessage & " with comment: " & objSource.CheckOuts.Item(1).Comment
             End If
             echo strMessage
   End Select 
 End If
End Sub

Function SourceSafeDatabase()
 Set mobjDatabase = CreateObject("SourceSafe")
 If cUSE_DEFAULT_LOGIN_DETAILS Then
   mobjDatabase.Open
 Else
   mobjDatabase.Open cSCC_DATABASE, cSCC_USER_NAME, cSCC_PASSWORD
 End If
 mstrUserName = mobjDatabase.UserName
 Set SourceSafeDatabase = mobjDatabase
End Function

Function SourceSafeRef()
 Dim objRoot, strFile
 strFile = CurrentFileName()
 Set objRoot = SourceSafeDatabase().VSSItem("$\")
 Set SourceSafeRef = ItemIn(objRoot, Ucase(strFile))
End Function

Sub UndoCheckOut()
 Dim strFile, objSource
 Set objSource = SourceSafeRef()
 strFile = CurrentFileName()
 If objSource Is Nothing Then
   echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 Else
   Select Case objSource.IsCheckedOut
         Case VSSFILE_NOTCHECKEDOUT:
             echo strFile & " was not checked out."
         Case VSSFILE_CHECKEDOUT_ME:
             objSource.UndoCheckOut strFile
             ReloadCurrentFile()
         Case VSSFILE_CHECKEDOUT: 'Check out by ANOTHER user
             strMessage = strFile & " is checked out by " & objSource.CheckOuts.Item(1).UserName
             If objSource.CheckOuts.Item(1).Comment<>"" Then
               strMessage = strMessage & " with comment: " & objSource.CheckOuts.Item(1).Comment
             End If
             MsgBox strMessage, , "Conflict"
   End Select 
 End If
End Sub

Class clsAccesskeyGenerator
 Dim mstrKeys

 Private Sub AddKey(ByVal strKey)
    mstrKeys = mstrKeys & UCase(strKey)
 End Sub

 Private Sub Class_Initialize()
    mstrKeys = ""
 End Sub

 Private Sub HandleGivenAccessKey(ByRef strCommand, ByRef numPos)
    If Not IsKeyKnown(Mid(strCommand, numPos + 1, 1)) Then
      AddKey Mid(strCommand, numPos + 1, 1)
    Else
      strCommand = Left(strCommand, numPos - 1) & Mid(strCommand, numPos + 1)
      numPos = 0 ' remove accesskey, as it was already registered
    End If
 End Sub

 Private Sub DetermineNewAccessKey(ByRef strCommand)
    Dim numPos
    numPos = 1
    While IsKeyKnown(Mid(strCommand, numPos, 1)) And (numPos<=Len(strCommand))
         numPos = numPos + 1
    Wend
    If numPos<=Len(strCommand) Then
      AddKey Mid(strCommand, numPos, 1)
      strCommand = Left(strCommand, numPos - 1) & "&" & Mid(strCommand, numPos)
    End If
 End Sub

 Private Function IsKeyKnown(ByVal strKey)
    IsKeyKnown = InStr(1, mstrKeys, UCase(strKey))>0
 End Function

 Public Function WithAccessKey(ByVal strCommand)
    Dim numPos, strKey
    numPos = InStr(1, strCommand, "&")
    If numPos>0 Then
      HandleGivenAccessKey strCommand, numPos
    End If
    If numPos<1 Then
      DetermineNewAccessKey strCommand
    End If
    WithAccessKey = strCommand
 End Function
End Class

Class clsLogWriter
 Private medtLog

 Private Sub Class_Initialize()
    Set medtLog = newEditor()
    medtLog.assignLog()
    medtLog.text ""
 End Sub

 Public Sub WriteLine(ByVal strLine)
    With medtLog
        .appendText strLine & LINE_END
        .setCaretPos 0, .linesCount
        .command "ecScrollDown"
    End With
 End Sub
End Class

Class clsSourceSafeAction ' Template class
 Sub ActionIfUnknown(ByVal objSource, ByVal strFile)
    echo "This file was not found in SourceSafe. This could be caused by the absence of a working folder setting."
 End Sub

 Sub ActionIfCheckedIn(ByVal objSource, ByVal strFile)
    
 End Sub

 Sub ActionIfCheckOut(ByVal objSource, ByVal strFile)
    
 End Sub

 Sub ActionIfHeldByOther(ByVal objSource, ByVal strFile)
    
 End Sub
End Class