quote:

---

Public Sub ProcessOne_01(Doc As Visio.Document)
'Обработка очередного документа
'Работает при установке в Visio опции Tools / Macros / Security / Trust access to Visual Basic Project
'После использования опцию желательно снять
'===================================================
' В проекте заменяются три модуля: cProvod, Forvard, DBTolls
Dim Proj As VBProject
Set Proj = Visio.Application.Vbe.VBProjects(2)
For i = 1 To Proj.VBComponents.Count
'Debug.Print Proj.VBComponents(i).Name
If StrComp(Proj.VBComponents(i).Name, "cProvod") = 0 Then
Proj.VBComponents.Remove Proj.VBComponents(i)
Proj.VBComponents.Import ("cProvod.cls")
Debug.Print "Заменен модуль cProvod"
End If
If StrComp(Proj.VBComponents(i).Name, "Forvard") = 0 Then
Proj.VBComponents.Remove Proj.VBComponents(i)
Proj.VBComponents.Import ("Forvard.bas")
Debug.Print "Заменен модуль Forvard"
End If
If StrComp(Proj.VBComponents(i).Name, "DBTolls") = 0 Then
Proj.VBComponents.Remove Proj.VBComponents(i)
Proj.VBComponents.Import ("DBTolls.bas")
Debug.Print "Заменен модуль DBTolls"
End If
Next
'===================================================
' В трафарете исправляется один мастер: Provod
Dim mas As Visio.Master
Dim masCopy As Visio.Master
Dim Sh As Visio.Shape
Set mas = ActiveDocument.Masters("Provod")
Set masCopy = mas.Open
Debug.Print mas.Shapes(1).Name
Set Sh = masCopy.Shapes(1)
Rc = Sh.RowCount(visSectionProp)
Sh.AddNamedRow visSectionProp, "Model", visTagDefault
With Sh
.CellsSRC(visSectionProp, Rc, visCustPropsLabel).FormulaU = """Model"""
.CellsSRC(visSectionProp, Rc, visCustPropsType).FormulaU = "0"
.CellsSRC(visSectionProp, Rc, visCustPropsLangID).FormulaU = "1049"
End With
masCopy.Close
Set masCopy = Nothing
End Sub

---

Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, nSize As Long) As Long

Sub fff()

Dim hh As Variant

Debug.Print ThisDocument.VBProject.References.Count

Dim i As Long

For i = 1 To ThisDocument.VBProject.References.Count
    Debug.Print ThisDocument.VBProject.References(i).Name & "   " & ThisDocument.VBProject.References(i).Guid
    
    hh = ThisDocument.VBProject.References(i).Guid
'    Debug.Print VBA.VarType(hh)
Next i

'ThisDocument.VBProject.References.AddFromGuid(
End Sub

Sub DocsRefer()
Dim i As Long

Dim k As Long

Dim FO As New Scripting.FileSystemObject
Dim DirT As Scripting.Folder
Dim TmpF As Scripting.File

Dim TmpStr As String

Dim TmpDoc As Word.Document
Dim SDoc As Word.Document

Dim Gu As String
Dim Ma As Long
Dim Mi As Long

Dim CF As New Scripting.Dictionary

Gu = ThisDocument.VBProject.References(5).Guid


Set DirT = FO.GetFolder(ThisDocument.Path)
'Set SDoc = Word.Documents.Open(ThisDocument.Path & "/" & "Srv.doc")

For Each TmpF In DirT.Files
    TmpStr = TmpF.Name
    If VBA.Left$(TmpStr, 1) Like ("[1-9]") Then
        
        Call CF.Add(i, DirT.Path & "/" & TmpF.Name)
        
        i = i + 1
    End If
Next



For i = 0 To CF.Count - 1
    Set TmpDoc = Word.Documents.Open(CF(CF.Keys(i)))
    
        Gu = ThisDocument.VBProject.References(5).Guid
        Ma = ThisDocument.VBProject.References(5).Major
        Mi = ThisDocument.VBProject.References(5).Minor

        Call TmpDoc.VBProject.References.AddFromGuid(Gu, Ma, Mi)

        Gu = ThisDocument.VBProject.References(6).Guid
        Ma = ThisDocument.VBProject.References(6).Major
        Mi = ThisDocument.VBProject.References(6).Minor

        Call TmpDoc.VBProject.References.AddFromGuid(Gu, Ma, Mi)


        Call TmpDoc.VBProject.References.AddFromFile(ThisDocument.Path & "/" & "Srv.doc")
        
        TmpDoc.VBProject.VBComponents.Import (DirT.Path & "/" & "AUTO.bas")
        
        TmpDoc.Close True

Next i




End Sub