Biasanya di PC Kantor harus pake login Admin agar bisa nembus ini, Kalo user
biasa terbatas pada access tertentu bahkan ketika explore ke Xl-Startup saja
ndak bisa tapi masih bisa di akalin dengan Add-Ins
Option Explicit
Option Compare Text
Sub BuatPersonaldanImportMod()
Application.ScreenUpdating = False
Dim Filt As String, Title As String, FIndex As Integer, i As Integer, FName
Dim XPersonal 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
XPersonal = True
Exit For
End If
Next
If XPersonal = True Then
If MsgBox((File.Name) & "Sudah ada." & vbCrLf & vbCrLf & _
"Apakah ingin menambah modules? ", vbYesNo, _
"info") = vbNo Then GoTo ExitSajalah
End If
If XPersonal = 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 & "Apakah ingin
melanjutkan import modules?", _
vbYesNo, "Personal.xls Created") = vbNo Then GoTo ExitSajalah
End If
Filt = "All Files (*.*),*.*," & _
"Basic Files (*.bas),*.bas," & _
"Class Files (*.cls),*.cls," & _
"Form Files (*.frm),*.frm,"
FIndex = 5
FName = Application.GetOpenFName _
(FileFilter:=Filt, _
FIndex:=FIndex, _
Title:="Pilih File untuk Import", _
MultiSelect:=True)
If TypeName(FName) = "Boolean" Then GoTo ExitSajalah
For i = LBound(FName) To UBound(FName)
PersonalXLS.VBProject.VBComponents.Import (FName(i))
Next
ExitSajalah:
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
---------------------------------
Sikap Peduli Lingkungan?
Temukan jawabannya di Yahoo! Answers!
