Option Explicit
Public VBInstance As VBIDE.VBE
Public Connect As Connect
Private Sub CancelButton_Click()
Connect.Hide
End Sub
Private Sub OKButton_Click()
On Error Resume Next
Dim strProject As String
Dim strPath As String
Dim strPath2 As String
Dim strFile As String
Dim strPrjFile As String
Dim rst As VbMsgBoxResult
Dim m, n As Long
Dim col2 As Collection, col As Collection
Dim vbCom As VBComponent
Dim fso As FileSystemObject
Dim ts As TextStream
Dim f1 As String, f2 As String
strProject = Me.VBInstance.ActiveVBProject.FileName
strPath = ParseFileName(strProject, strPrjFile)
strPath2 = setFolder
If strPath = "" Or strPath = strPath2 Then
MsgBox "target folder is invalid or same as the project folder. Can't copy."
Exit Sub
End If
Set col2 = New Collection
Set col = New Collection
Set fso = New FileSystemObject
Set ts = fso.CreateTextFile(strPath2 & "wemeet.log", False)
For m = Me.VBInstance.ActiveVBProject.VBComponents.Count To 1 Step -1
Set vbCom = Me.VBInstance.ActiveVBProject.VBComponents(m)
For n = 1 To vbCom.FileCount
f1 = vbCom.FileNames(n)
ParseFileName f1, strFile
f2 = strPath2 & "" & strFile
fso.CopyFile f1, f2
col.Add f1
col2.Add f2
ts.WriteLine "" & Now() & " [Move]: " & f1
ts.WriteLine "" & Now() & " [To ]: " & f2
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.VBComponents.Remove vbCom
Next
For m = 1 To col2.Count
Me.VBInstance.ActiveVBProject.VBComponents.AddFile col2.Item(m)
ts.WriteLine "" & Now() & " [Add]: " & col2.Item(m)
ts.WriteBlankLines 1
Next
Me.VBInstance.ActiveVBProject.SaveAs strPath2 & "" & strPrjFile
ts.WriteLine "" & Now() & " [SaveAs]: " & strPath2 & "" & strPrjFile
ts.WriteBlankLines 1
ts.Close
fso.OpenTextFile strPath2 & "wemeet.log"
Set fso = Nothing
Set col = Nothing
Set col2 = Nothing
Set vbCom = Nothing
Connect.Hide
End Sub
Private Function ParseFileName(ByVal sPath As String, ByRef sFile As String) As String
Dim fso As New FileSystemObject
If fso.FileExists(sPath) Then
ParseFileName = fso.GetParentFolderName(sPath)
sFile = fso.GetFileName(sPath)
Else
ParseFileName = ""
sFile = ""
End If
Set fso = Nothing
End Function
Private Function setFolder() As String
Dim objDlg As Object
Dim objStartFolder As Object
Set objDlg = CreateObject("Shell.Application")
Set objStartFolder = objDlg.BrowseForFolder(&H0, "Select a folder", &H10 + &H1)
If InStr(1, TypeName(objStartFolder), "Folder") > 0 Then
setFolder = objStartFolder.ParentFolder.ParseName(objStartFolder.Title).Path
End If
Set objDlg = Nothing
End Function
