JMA
tuzka.cz
Ing. Jan Matuška tvorba databází a webu kontakt
služby+sw
software
exShop je pohoda!
KOALA
Kniha pošty
projekty
webdesign
o firmě
tipy kolegům
VBA
Dokončit import
FreeImage
ZIPování
TCP/IP
Outlook-přílohy
Access
HWIZ
Zdroje informací
Upload
Z autorské tvorby
Fotografie
Sbírka básní
Plakát
Přečtěte si
Jak a proč jsem se stal křesťanem
Víte, že AHOJ je zkratka?
Poznat Boha, ale jak?
... další přímo na stránkách BTM

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
 
 
Doporučuji
Exit 316
Letní tábor Doubravka 2009 s Beberkou
Exit 316
Nový TV pořad od září 2006!
Pro děti - zvědavé otázky se Zvědavou tužkou
KROKY - Časopis pro děti
křesťanská díla, CF - nejen databáze křesťanských písní
Komerce atd.
Podpořte snahu proti zavedení SW patentů!!!
profi webhosting Gigaweb
Nabídka SW a služeb
Kniha pošty
KOALA
Tvorba www
Umístění stránek
Chcete internetový obchod?