Küldök két word makrót. Remélem ilyesmire gondoltál. (Office 2007 alatt
teszteltem, remélem nem lesz gond az újabb wordben sem.)
Az elsőt egy üres dokumentumból kell indítani. Bekéri a könyvtárat,
amiből dolgozzon. Az abban levő .docx-eket megnyitva megkeresi a
hyperlinkeket, majd azokat az üres dokumentumba másolja szövegként. A
kapott eredmény formája:
http://valami1.cim
http://valahol.cim
http://valami.cim
.docx neve
http://masvalami.cim
másik .docx neve
stb.
Az alkönyvtárakat nem nézi meg, a sima szövegként levő címekkel nem
foglalkozik, csak a hiperhivatkozásokkal.
A másodikat egy megnyitott doc-ból kell indítani. Az ebben a doc-ban
levő hiperhivatkozásokat keresi meg, és rakja egy üres dokumentumba.
Sub web_hivatkozas_konyvtarbol()
Dim oLink As Hyperlink
Dim docCurrent As Document
Dim doc_keres As Document
Dim rngStory As StoryRanges
Set docCurrent = ActiveDocument
Dim SrcFldr As String
MsgBox "Válaszd ki a forrás mappát!"
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
SrcFldr = .SelectedItems(1)
End With
Application.ScreenUpdating = False
n$ = Dir(SrcFldr & "\" & "*.docx")
If n$ <> "" Then
On Error GoTo hiba
While n$ <> ""
Selection.InsertBefore Text:=(n$ + Chr(13))
Documents.Open SrcFldr & "\" & n$
Windows(n$).Activate
Set doc_keres = ActiveDocument
For Each oLink In doc_keres.Hyperlinks
Set rng = docCurrent.Range
rng.Collapse
rng.InsertAfter (oLink.Address) + Chr(13)
Next
doc_keres.Close (wdDoNotSaveChanges)
docCurrent.Activate
n$ = Dir()
Wend
Else
Application.ScreenUpdating = True
MsgBox ("A könyvtár nem tartalmaz .docx fájlt")
Set doc_keres = Nothing
Set docCurrent = Nothing
Exit Sub
End If
Application.ScreenUpdating = True
Set doc_keres = Nothing
Set docCurrent = Nothing
Exit Sub
hiba:
Application.ScreenUpdating = True
MsgBox ("Valami hiba történt!")
a = Err.Number
Stop
End Sub
Sub web_hivatkozas_docbol()
Dim docCurrent As Document
Dim docNew As Document
Dim oLink As Hyperlink
Dim rng As Range
Application.ScreenUpdating = False
Set docCurrent = ActiveDocument
Set docNew = Documents.Add
For Each oLink In docCurrent.Hyperlinks
Set rng = docNew.Range
rng.Collapse
' rng.InsertAfter (oLink.TextToDisplay) + Chr(9) +
(oLink.Address) + Chr(13)
rng.InsertAfter (oLink.Address) + Chr(13)
Next
docNew.Activate
Application.ScreenUpdating = True
Application.ScreenRefresh
End Sub
|