Option Explicit
Option Compare Text
Sub AddPersonal()
Application.ScreenUpdating = False
Dim Filt As String, Title As String, FilterIndex As Integer, i As Integer, FileName
Dim blnPersonal As Boolean
Dim FSO As Object, Folder As Object, File As Object
Dim PersonalXLS As Workbook
Set FSO = CreateObject("Scripting.FileSystemObject")
Set Folder = FSO.GetFolder(Application.StartupPath)
For Each File In Folder.Files
If UCase(File.Name) = "PERSONAL.XLS" Then
If WorkbookIsOpen(File.Name) Then
Set PersonalXLS = Application.Workbooks(File.Name)
Else
Set PersonalXLS = Application.Workbooks.Open(File.Path)
End If
blnPersonal = True
Exit For
End If
Next
If blnPersonal = True Then
If MsgBox("Personal.xls already exists." & vbCrLf & vbCrLf & _
"Would you like to add modules to it?", vbYesNo, _
"Personal.xls Exists") = vbNo Then GoTo ExitHere
End If
If blnPersonal = False Then
Set PersonalXLS = Application.Workbooks.Add
PersonalXLS.SaveAs (Application.StartupPath & "\PERSONAL.xls")
Windows("PERSONAL.xls").Visible = False
If MsgBox("Personal.xls created." & vbCrLf & vbCrLf & "Would you like to import modules?", _
vbYesNo, "Personal.xls Created") = vbNo Then GoTo ExitHere
End If
Filt = "All Files (*.*),*.*," & _
"Basic Files (*.bas),*.bas," & _
"Class Files (*.cls),*.cls," & _
"Form Files (*.frm),*.frm,"
FilterIndex = 5
Title = "Select a File to Import"
FileName = Application.GetOpenFilename _
(FileFilter:=Filt, _
FilterIndex:=FilterIndex, _
Title:=Title, _
MultiSelect:=True)
If TypeName(FileName) = "Boolean" Then GoTo ExitHere
For i = LBound(FileName) To UBound(FileName)
PersonalXLS.VBProject.VBComponents.Import (FileName(i))
Next
ExitHere:
PersonalXLS.Save
Set PersonalXLS = Nothing
Set FSO = Nothing
Set Folder = Nothing
Set File = Nothing
Application.ScreenUpdating = True
End Sub
Private Function WorkbookIsOpen(wbName) As Boolean
Dim wb As Workbook
On Error Resume Next
Set wb = Application.Workbooks(wbName)
If Err = 0 Then WorkbookIsOpen = True Else WorkbookIsOpen = False
End Function
|