1: '// Sample params
2: '// sourceSafeIni: "\\IPAddress\SourceSafe\srcsafe.ini"
3: '// sourceCodeProject: "$/RBL/Excel Addin/Source"
4: '// sourceCodeFolder: "F:\BTR\RBL\Excel Addin\Source"
5: Sub CheckInCodeFiles(sourceSafeIni As String, sourceCodeProject As String, sourceCodeFolder As String)
6:
7: On Error GoTo Err_Handler
8:
9: Dim sourceSafe As Object: Set sourceSafe = CreateObject("SourceSafe")
10: Call sourceSafe.Open(sourceSafeIni)
11:
12: Dim vssFolder As Object: Set vssFolder = Nothing
13: Set vssFolder = sourceSafe.vssItem(sourceCodeProject) '// Project must exist or an error will occur
14: vssFolder.CheckOut '// Check out all files
15:
16: Call ExportCodeFiles(sourceCodeFolder, True)
17:
18: Dim fso As Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
19: Dim sourceFile As file
20:
21: For Each sourceFile In fso.GetFolder(sourceCodeFolder).Files
22: If LCase(fso.GetExtensionName(sourceFile.Name)) <> "scc" Then
23: Call CheckInSourceSafeItem(vssFolder, sourceFile)
24: End If
25: Next '// sourceFile
26:
27: Dim vssItem As Object
28: For Each vssItem In vssFolder.Items
29: If vssItem.IsCheckedOut Then
30: '// Still checked out means the file was no longer in VBAProject, so undo checkout and 'delete'
31: vssItem.UndoCheckout
32: vssItem.Deleted = True
33: End If
34: Next '// vssItem
35:
36: Set vssFolder = Nothing
37: Set sourceSafe = Nothing
38:
39: Exit Sub
40:
41: Err_Handler:
42:
43: '// Clean-up and re-throw...
44:
45: Dim errNumber As Long: errNumber = Err.number
46: Dim errSource As String: errSource = Err.source
47: Dim errDescription As String: errDescription = Err.description
48:
49: If Not vssFolder Is Nothing Then Set vssFolder = Nothing
50: If Not sourceSafe Is Nothing Then Set sourceSafe = Nothing
51:
52: Call Err.Raise(errNumber, errSource, errDescription)
53:
54: Resume
55: End Sub
56:
57: Sub CheckInSourceSafeItem(sourceProject As Object, sourceFile As file)
58:
59: Dim vssFile As Object: Set vssFile = Nothing
60: On Error Resume Next
61: Set vssFile = sourceProject.Items(0)(sourceFile.Name)
62: On Error GoTo 0
63: If Not vssFile Is Nothing Then
64: vssFile.CheckIn , sourceFile.path
65: Else
66: sourceProject.Add sourceFile.path
67: End If
68:
69: End Sub
70:
71: Sub ExportCodeFiles(basePath As String, Optional cleanDirectory As Boolean = False)
72:
73: On Error GoTo Err_Handler:
74:
75: Dim fso As Scripting.FileSystemObject: Set fso = New Scripting.FileSystemObject
76:
77: If Not fso.FolderExists(basePath) Then
78: Call fso.CreateFolder(basePath)
79: ElseIf cleanDirectory Then
80: Call fso.DeleteFolder(basePath, True)
81: Call fso.CreateFolder(basePath)
82: End If
83:
84: Dim component As VBComponent
85: For Each component In ThisWorkbook.VBProject.VBComponents
86: Dim ext As String
87: Select Case True
88: Case component.Type = vbext_ct_ClassModule
89: ext = ".cls"
90: Case component.Type = vbext_ct_MSForm
91: ext = ".frm"
92: Case component.Type = vbext_ct_StdModule
93: ext = ".bas"
94: Case component.Type = vbext_ct_Document
95: ext = ".cls" '// ThisWorkbook: Can't be imported back in, but *.cls lets it be viewed in VB
96: Case Else
97: Call Err.Raise(vbObjectError, , "Not supported.")
98: End Select
99: Call component.Export(fso.BuildPath(basePath, component.Name) & ext)
100: Next '//component
101:
102: Set fso = Nothing
103:
104: Exit Sub
105:
106: Err_Handler:
107:
108: '// Clean-up and re-throw...
109:
110: Dim errNumber As Long: errNumber = Err.number
111: Dim errSource As String: errSource = Err.source
112: Dim errDescription As String: errDescription = Err.description
113:
114: Set fso = Nothing
115:
116: Call Err.Raise(errNumber, errSource, errDescription)
117: End Sub