如何将VB6项目部署到服务器上,如何将整个VB6项目保存到新文件夹？模块和所有...

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