Dokončení importu: References + StartUp (Po spuštění)
Jan Matuška 5.12.2009
Zdravičko, kolegové,
taky vás rozčiluje ručně si doklikávat reference a dopisovat StartUp-nastavení, když importujete mdb/adp do nového souboru?
Dejte si kód do nového modulu a spusťte:
wrk_import_here_refs_and_startups_form_path "cesta_k_starému"
Tu je kód:
Sub wrk_import_here_refs_and_startups_form_path(ByVal ProjectFullPath As String)
Dim app As Access.Application
Set app = CreateObject(ProjectFullPath)
wrk_copy_app_refs_and_startups_form_path app, Application
End Sub
Sub wrk_copy_app_refs_and_startups_form_path(app1 As Access.Application, app2 As Access.Application)
'JMA 2009
wrk_import_references app1, app2
wrk_import_project_props app1.CurrentProject, app2.CurrentProject
End Sub
Function wrk_import_project_props(cp1 As Object, cp2 As Object)
'JMA 2009
Dim p1
Dim p2
' On Error Resume Next
On Error GoTo 0
For Each p1 In cp1.Properties
If HasProperty(cp2, p1.Name) Then
Set p2 = cp2.Properties(p1.Name)
If p2.Value <> p1.Value Then
Debug.Print "update property " & p1.Name & ":" & p2.Value & " ->" & p1.Value
On Error Resume Next
p2.Value = p1.Value
If Err <> 0 Then Debug.Print " >>> " & Err.Description
On Error GoTo 0
End If
Else
Call cp2.Properties.Add(p1.Name, p1.Value)
Set p2 = cp2.Properties(p1.Name)
Debug.Print "added property " & p1.Name & ":" & p2.Value
End If
Next
End Function
Function wrk_import_references(a1 As Access.Application, a2 As Access.Application)
'JMA 2009
Dim r1 As Reference
Dim r2 As Reference
For Each r1 In a1.References
' if r1.FullPath
If Not HasReference(a2, r1) Then
Set r2 = a2.References.AddFromGuid(r1.guid, r1.Major, r1.Minor)
Debug.Print "added reference to: " & r2.FullPath
End If
Next
End Function
Private Function HasReference(a As Access.Application, r1 As Access.Reference) As Boolean
'JMA 2009
Dim r As Access.Reference
For Each r In a.References
If Not r.FullPath = r1.FullPath Then
' ElseIf Not r.guid = r1.guid Then
' ElseIf Not r.Minor = r1.Minor Then
' ElseIf Not r.Major = r1.Major Then
Else
HasReference = True
End If
Next
End Function
Private Function HasProperty(o As Object, ByVal PropName As String) As Boolean
'JMA 090320
'O: A/N zda existuje vlastnost
'tohle je rychlejší než procházet kolekci Property
'funguje jen u prvků, které mají kolekci Propeties, která není u všech možných objektů
'možná funkcí Eval("o."& propname)
On Error Resume Next
Dim v
HasProperty = False
v = o.Properties(PropName)
HasProperty = (Err = 0)
If Err <> 0 Then On Error Resume Next 'vyčištění objektu Err
End Function
|