1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
| Function createFileHypertexte(ByVal fileName As String)
Dim Chem_app As String
Set Objse = GetObject(, "SolidEdge.application")
Dim objAttributeSets As AttributeSets
Dim objAttributeSet As AttributeSet
Dim j As Integer
Dim objTmpS As Object 'DrawingViews
Dim objTmp As Object
Chem_app = LireFormatDsFichierTexte("CHEMIN POUR LIRE PDF")
If Right(Chem_app, 1) <> "\" Then Chem_app = Chem_app & "\"
Chem_app = Chem_app & Left(fileName, Len(fileName) - 3) & "txt"
Dim objSheet As Sheet
Set objSheet = Objse.ActiveDocument.ActiveSheet
Dim cpt As Integer
Dim i As Integer
Set objTmpS = objSheet.Groups
For i = 1 To objTmpS.Count
objTmpS(i).Ungroup
Next i
On Error Resume Next
Set objTmpS = objSheet.DrawingObjects
For i = 1 To objTmpS.Count
cpt = cpt + 1
Set objAttributeSets = objTmpS(i).AttributeSets
Call TtHyperLinkFichierTexte(Chem_app, objAttributeSets)
Next i
End Function
Private Function TtHyperLinkFichierTexte(ByVal NameFile As String, ByVal objTtAttributeSets As AttributeSets)
Dim NumFic
NumFic = FreeFile
For Each objAttributeSet In objTtAttributeSets
For j = 1 To objAttributeSet.Count
If objAttributeSet.Item(j).Name = "UG_USER_HYPERLINK" Then
Open NameFile For Append As NumFic
Print #NumFic, objAttributeSet.Item(j).Value
Close NumFic
End If
Next
Next
End Function |
