Private Sub Validating(pbOk As Boolean)
' constants
Const ksExt = ".txt"
' declarations
Dim I As Integer, A As String
' start
pbOk = True
' process
' source path
If pbOk Then
' exists?
On Error Resume Next
ChDir gsPath(1)
If Err.Number <> 0 Then
Err.Clear
MsgBox "Invalid source path", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
End If
On Error GoTo 0
End If
' filename
If pbOk Then
' exists?
gsFileName = ufAdmin.txtFilename.Text
A = Dir(gsPath(1) & gsFileName)
If A = "" Then
MsgBox "No files matching in source path", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
End If
End If
' backup path
If pbOk Then
' blank?
If gsPath(2) = "" Then gsPath(2) = gsPath(1)
' exists?
On Error Resume Next
ChDir gsPath(2)
If Err.Number <> 0 Then
Err.Clear
MsgBox "Invalid backup path", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
End If
' writable?
If pbOk Then
On Error Resume Next
A = gsPath(2) & Format(Now(), "yyyymmdd_hhmmss") & ksExt
I = FreeFile()
Open A For Output As #I
If Err.Number <> 0 Then
Err.Clear
MsgBox "Non writable backup path", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
End If
Close #I
DoEvents
Kill A
End If
On Error GoTo 0
End If
' user form
If pbOk Then
' any selected?
With ufAdmin
If .optFormKeep = False And .optFormDelete = False Then
MsgBox "No user form option selected", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
Else
gbFormDelete = .optFormDelete
End If
End With
End If
' module
If pbOk Then
' any selected?
With ufAdmin
If .optModuleKeep = False And .optModuleDelete = False Then
MsgBox "No module option selected", vbApplicationModal + vbCritical + vbOKOnly, "Error"
pbOk = False
Else
gbModuleDelete = .optModuleDelete
End If
End With
End If
' end
End SubSub JustDoIt()
'
' constants
Const ksExtFrm = ".frm"
Const ksExtFrx = ".frx"
Const ksExtBas = ".bas"
Const ksAsterix = "*"
'
' declarations
Dim sForm() As String, sModule() As String, bComponents() As Boolean
Dim iForm As Integer, iModule As Integer
Dim iRead As Integer, iWrite As Integer, sFolder As String
Dim I As Integer, J As Integer, A As String, bOk As Boolean
'
' start
' validation
Validating bOk
If Not bOk Then Exit Sub
' create backup subfolder
sFolder = Format(Now(), "yyyymmdd_hhmmss")
MkDir gsPath(2) & sFolder
' template
With ThisWorkbook.VBProject
iForm = 0
iModule = 0
ReDim bComponents(.VBComponents.Count)
For I = 1 To .VBComponents.Count
With .VBComponents(I)
bComponents(I) = False
A = .Name
Select Case .Type
Case vbext_ct_MSForm
If .Name <> gksFormAdmin Then
iForm = iForm + 1
ReDim Preserve sForm(iForm)
sForm(iForm) = A
bComponents(I) = True
.Export gsPath(2) & sFolder & Application.PathSeparator & _
A & ksExtFrm
End If
Case vbext_ct_StdModule
If .Name <> gksModuleAdmin Then
iModule = iModule + 1
ReDim Preserve sModule(iModule)
sModule(iModule) = A
bComponents(I) = True
.Export gsPath(2) & sFolder & Application.PathSeparator & _
A & ksExtBas
End If
End Select
End With
Next I
End With
'
' process
iRead = 0
iWrite = 0
If bOk Then
A = Dir(gsPath(1) & gsFileName)
Do Until A = ""
If A <> ThisWorkbook.Name Then
' count
iRead = iRead + 1
' backup
FileCopy gsPath(1) & A, _
gsPath(2) & sFolder & Application.PathSeparator & A
' open
On Error Resume Next
Workbooks.Open gsPath(1) & A, False
If Err.Number <> 0 Then
Err.Clear
Else
' main
iWrite = iWrite + 1
' delete old components
With ActiveWorkbook.VBProject
For I = .VBComponents.Count To 1 Step -1
With .VBComponents(I)
A = .Name
Select Case .Type
Case vbext_ct_MSForm
For J = 1 To iForm
If A = sForm(J) Then Exit For
Next J
If J <= iForm Or J > iForm And gbFormDelete Then
' delete form
Debug.Print ActiveWorkbook.Name, "delete form", A
ActiveWorkbook.VBProject.VBComponents.Remove _
ActiveWorkbook.VBProject.VBComponents(I)
End If
Case vbext_ct_StdModule
For J = 1 To iModule
If A = sModule(J) Then Exit For
Next J
If J <= iModule Or J > iModule And gbModuleDelete Then
' delete module
Debug.Print ActiveWorkbook.Name, "delete module", A
ActiveWorkbook.VBProject.VBComponents.Remove _
ActiveWorkbook.VBProject.VBComponents(I)
End If
End Select
End With
Next I
End With
' add new components
With ThisWorkbook.VBProject
For I = 1 To .VBComponents.Count
With .VBComponents(I)
If bComponents(I) Then
A = .Name
Select Case .Type
Case vbext_ct_MSForm
' add form
Debug.Print ActiveWorkbook.Name, "add form", A
ActiveWorkbook.VBProject.VBComponents.Import _
gsPath(2) & sFolder & Application.PathSeparator & _
A & ksExtFrm
Case vbext_ct_StdModule
' add module
Debug.Print ActiveWorkbook.Name, "add module", A
ActiveWorkbook.VBProject.VBComponents.Import _
gsPath(2) & sFolder & Application.PathSeparator & _
A & ksExtBas
End Select
End If
End With
Next I
End With
' save
ActiveWorkbook.Close True
End If
On Error GoTo 0
End If
' cycle
A = Dir()
Loop
' cleanup
On Error Resume Next
Kill gsPath(2) & sFolder & Application.PathSeparator & ksAsterix & ksExtFrm
Kill gsPath(2) & sFolder & Application.PathSeparator & ksAsterix & ksExtFrx
Kill gsPath(2) & sFolder & Application.PathSeparator & ksAsterix & ksExtBas
On Error GoTo 0
' msg
MsgBox CStr(iWrite) & " files updated from " & CStr(iRead) & " files matching", _
vbApplicationModal + IIf(iWrite = iRead, vbInformation, vbExclamation) + vbOKOnly, _
"Summary"
End If
'
' end
Unload ufAdmin
Beep
'
End SubSub ThisGuyIsMoreLazyThanI_QuickAndDirtyView()
' constants
' declarations
Dim I As Integer, J As Integer
' start
' process
'
Debug.Print "By VBAProjects"
With Application.VBE
I = .VBProjects.Count
For J = 1 To I
With .VBProjects(J)
Debug.Print J; I, .Name, .Description,
On Error Resume Next
Debug.Print .Filename,
If Err.Number <> 0 Then
Debug.Print "<file not saved yet>",
Err.Clear
End If
On Error GoTo 0
If Not CBool(.Protection) Then
Debug.Print .VBComponents.Count;
Else
Debug.Print "<protected>";
End If
Debug.Print
End With
Next J
End With
Debug.Print
'
Debug.Print "By Workbooks"
With Application
I = .Workbooks.Count
For J = 1 To I
With .Workbooks(J)
Debug.Print J; I, .Name,
On Error Resume Next
Debug.Print .FullName,
If Err.Number <> 0 Then
Debug.Print "<file not saved yet>",
Err.Clear
End If
On Error GoTo 0
If .HasVBProject Then
If .VBProject.Protection = vbext_pp_none Then
Debug.Print .VBProject.VBComponents.Count;
Else
Debug.Print "<protected>";
End If
Else
Debug.Print 0;
End If
Debug.Print
End With
Next J
End With
Debug.Print
'
Debug.Print "ThisWorkbook"
With ThisWorkbook.VBProject
I = .VBComponents.Count
For J = 1 To I
With .VBComponents(J)
Debug.Print J; I; .Name; .Type
End With
Next J
End With
' end
End Sub