Алексей Андрюнин

VisualBasic source

Attribute VB_Name = "InsHLinks"
'***********************************************************************
'* *
'* Макросы для вставки файлов, на которые указывают гиперссылки *
'* в документе *
'* *
'***********************************************************************
'* Версия 1.0 *
'***********************************************************************
'* (c) Андрюнин А. В., 2000 *
'***********************************************************************

'************************** Настройки модуля ***************************
Option Explicit
Option Base 1

'*********************** Константы и типы данных ***********************
' Эти три константы задают способы вставки файла в документ
Const IPS_NOTINSERT = 0 ' Не вставлять файл
Const IPS_TOEND = 1 ' Вставлять в конец
Const IPS_UNDERSELECTION = 2 ' Вставлять под выделенное
Const IPS_REPLACESELECTION = 3 ' Вставлять с заменой выделенного

' Эти три константы определяют надо ли выводить сообщение о повторной вставке файла
Const ROR_NEWER = 0
Const ROR_ALWAYS = 1
Const ROR_ALWAYSASK = 2
Const ROR_IFINSERTED = 3
Const ROR_IFINSERTEDASK = 4

Const GRAPHFORMATSCOUNT = 31 ' Число графических форматов
Const PROTOCOLSCOUNT = 17 ' Число протоколов

Const ANYFILEFILTER = "All Files(*.*)" + vbNullChar + "*.*" + vbNullChar + vbNullChar ' Фильтр для окна выбора имени файла
Const ERRORS_BOOKMARK = "Errors" ' Имя закладки на список ошибок в отчете
Const LINKS2NET_BOOKMARK = "LinksToNet" ' Имя закладки на список ссылок в сеть в отчете

' Заголовки окон
Const SHOWHLTITLE = "Свойства гиперссылки" ' Заголовок окна
Const INSHLTITLE = "Вставка адресата гиперссылки" ' Заголовок окна
Const TESTMODETITLE = " (в режиме проверки)" ' Подзаголовок окна
Const SEARCHHLINKTITLE = "Поиск гиперссылки по адресу" ' Заголовок окна
Const SHOWNUMTITLE = "Показ номера гиперссылки" ' Заголовок окна

' Названия панели инструментов, кнопок и экранных подсказок к ним
Const BAR_NAME = "Работа с гиперссылками"
Const BAR_INSCUR = "+ 1..."
Const BAR_INSCURTT = "Вставить файл, на который указывает текущая гиперссылка"
Const BAR_INSALL = "+ Все..."
Const BAR_INSALLTT = "Вставить все файлы, на которые указывают гиперссылки в документе"
Const BAR_SHOWCUR = "Свойства..."
Const BAR_SHOWCURTT = "Показать свойства текущей гиперссылки"
Const BAR_SHOWALL = "Свойства всех..."
Const BAR_SHOWALLTT = "Показать свойства всех гиперссылок в документе"
Const BAR_SRC = "Поиск..."
Const BAR_SRCTT = "Поиск гиперссылки по адресу"
Const BAR_NUM = "Номер"
Const BAR_NUMTT = "Показать номер текущей гиперссылки"
Const BAR_TEST = "Проверка..."
Const BAR_TESTT = "Проверка гиперссылок в документе путем перехода по ним"

' Различные сообщения
Const MSG_FSCIPPED = "Файл пропущен"
Const MSG_FNOTFOUND = "Файл не найден"
Const MSG_WHILEINSERT = "Ошибка во время вставки файла"
Const MSG_LINK2NET = "Ссылка в гл. сеть"
Const MSG_FILEINHLINK = "Файл, указанный в гиперссылке"
Const MSG_ERRTYPE = "Тип ошибки"
Const MSG_ADDRINHLINK = "Адрес, указанный в гиперссылке"
Const MSG_NAMEOFINSERTED = "Имя вставленного файла"
Const MSG_INSERTIONSNUM = "Количество вставок"
Const MSG_ERRORSNUM = "Число ошибок: "
Const MSG_LINKS2NETNUM = "Число ссылок в глобальную сеть: "
Const MSG_REPINSFILESNUM = "Число файлов вставленных более одного раза: "
Const MSG_TOTALINSFILESNUM = "Общее число вставленных файлов: "
Const MSG_REPORT = "Отчет о вставке файлов в документ:"
Const MSG_ERRWHILETRYINS = "Возникла ошибка при попытке вставки файла:"
Const MSG_FINISHINS = "Вставка завершена."
Const MSG_CLINKPROPRT = "Свойства текущей гиперссылки"
Const MSG_ADDR = "Файл: "
Const MSG_SUBADDR = "Закладка: "
Const MSG_INSLINKORNOT = "Вставить файл в документ?"
Const MSG_ALREADYINSERTED = " (уже вставлено)"
Const MSG_FWASNOTINS = " (файл не вставлялся)"
Const MSG_INSERTEDREP = " (вставлено повторно)"
Const MSG_INSERTEDFILES = "Вставленные файлы"
Const MSG_ONLYREPSLISTED = " (перечислены только вставленные более одного раза)"
Const MSG_LINKSINGLOBAL = "Ссылки, указывающие в глобальную сеть"
Const MSG_aErrorsList = "Список ошибок"
Const MSG_SEARCHFINISHED = "Поиск завершен."
Const MSG_INPUTSEARCHADDR = "Введите адрес для поиска:"
Const MSG_CONTINUESEARCH = "Продолжить поиск?"
Const MSG_DATANOTFOUND = "Данные не найдены."
Const MSG_HLINK2FILE = "Ссылка на файл : "
Const MSG_FNOTREPINS = " встретилась более одного раза и будет пропущена (файл не будет вставлен повторно)."
Const MSG_FREPINS = " встретилась более одного раза. Файл будет вставлен в документ повторно."
Const MSG_CONTINUEPROCESS = "Продолжить выполнение?"
Const MSG_INSERTORNOT = "Вставить файл?"
Const MSG_INPUTPATH = "Введите путь, где находятся вставляемые файлы"
Const MSG_FILE = "Файл: "
Const MSG_FINDMANUALLY = "Хотите найти его вручную? (Выберите Да, чтобы найти файл, или Нет, чтобы пропустить его.)"
Const MSG_NOTEXIST = " не существует!"
Const MSG_NOHLINKSINDOC = "В документе нет гиперссылок!"
Const MSG_CURHLNUM = "Номер текущей гиперссылки в документе: "

' Коды ошибок
Const ERR_FSCIPPED = 1 ' Файл пропущен
Const ERR_FNOTFOUND = 2 ' Файл не найден
Const ERR_WHILEINSERT = 3 ' Произошла ошибка во время вставки файла
Const ERR_LFOLLOW2NET = 4 ' Ссылка указывает на файл в глобальной сети

' Результат функции ScipFileInsertion
Const SFI_NOTINSERTEDYET = 1 ' Файл еще не был вставлен
Const SFI_CANTREPINS = 2 ' Файл уже был вставлен, и повторная вставка не нужна
Const SFI_NEEDREPINS = 3 ' Файл уже был вставлен, но нужна повторная вставка

' Структура для хранения информации о вставленных файлах
Type INSDATA
lpstrFName As String ' Имя вставляемого файла
lpstrBMName As String ' Имя закладки на первый экземпляр
iNumInserted As Integer ' Число вставленных экземпляров
End Type

' Структура для хранения информации об ошибках в процессе вставки
Type ERRDATA
lpstrFName As String ' Имя вставляемого файла
iErrCode As Integer ' Код ошибки (см. группу констант ERR_xxx)
End Type

'*********** Константы и тип данных для функции OpenFile ************
Public Const OF_EXIST = &H4000 ' Флаг передаваемый ф-ии для проверки на существование файла
Public Const OFS_MAXPATHNAME = 128 ' Максимальная длина пути и имени файла в байтах
Public Const HFILE_ERROR = -1 ' Значение возвращаемое функцией в случае ошибки

' Структура для передачи в функцию
Type OFSTRUCT
cBytes As Byte
fFixedDisk As Byte
nErrCode As Integer
Reserved1 As Integer
Reserved2 As Integer
szPathName(OFS_MAXPATHNAME) As Byte
End Type

' 32-битная функция Windows API OpenFile для функции ExistFile
Declare Function OpenFile Lib "kernel32" (ByVal lpFileName As String, lpReOpenBuff As OFSTRUCT, ByVal wStyle As Long) As Long

'******* Константы и тип данных для функции GetOpenFileName ********
Public Const MAXCUSTFILTER = 40 ' Минимально возможный размер nMaxCustFilter
Public Const MAXFNAME = 260 ' Размер буфера lpstrFile
Public Const OFN_FILEMUSTEXIST = &H1000 ' Указанный пользователем файл должен существовать
Public Const OFN_EXPLORER = &H80000 ' Вид окна как у проводника Windows
Public Const OFN_HIDEREADONLY = &H4 ' Скрыть флажок Read Only

Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

' 32-битные функции Windows API GetActiveWindow и GetOpenFileName для функции ChooseCorrectName
Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Declare Function GetActiveWindow Lib "user32" () As Long

'****************************** Переменные *****************************
Dim bOnlyTestMode As Boolean ' Не вставлять гиперссылки, - только проверить
Dim bNeedConfirmation As Boolean ' Запрос подтверждения для каждой гиперссылки
Dim bSrchOnSpecPath As Boolean ' Искать файл в указанной директории, если его нет в поддиректории
Dim bReportOnFinished As Boolean ' Выдать сообщение о завершении
Dim bNeedFullReport As Boolean ' Нужно ли выводить полный отчет
Dim bReportErrors As Boolean ' Сообщать об ошибках в процессе вставки гиперссылок
Dim bInsRepPics As Boolean ' Вставлять ли повторяющиеся изображения повторно
Dim bInsRepNonPics As Boolean ' Вставлять ли повторяющиеся файлы повторно
Dim bOnlyRepsInReport As Boolean ' Выводить в отчет только сообщения о файлах вставленных более одного раза
Dim bColorizeReps As Boolean ' Выделять цветом сообщения о файлах вставленных более одного раза в отчете
Dim bCommentErrors As Boolean ' Добавить к тексту гиперссылки файла, при вставке которого возникла ошибка ее описание
Dim bCommentLinks2Net As Boolean ' Добавить к тексту гиперссылки в глобальную сеть сообщение об этом
Dim bCommentReps As Boolean ' Добавить к тексту гиперссылки на уже вставленный файл сообщение об этом
Dim bCommentNotIns As Boolean ' Добавить к тексту гиперссылки сообщение на о том, что ее вставка была
пропущена (Если для текущего типа файла установлен режим IPS_NOTINSERT)
Dim iSkipFirstLinks As Integer ' Пропустить указанное число ссылок сначала документа
Dim iReportOnRepPics As Integer ' Выводить сообщение о повторной вставке изображений
Dim iReportOnRepNonPics As Integer ' Выводить сообщение о повторной вставке файлов
Dim iPicsInsMode As Integer ' Вставлять картинки
Dim iNonPicsInsMode As Integer ' Вставлять неграфические файлы
Dim lpstrFPath As String ' Путь к файлам
Dim aGraphExtensions As Variant ' Расширения графических файлов
Dim aProtocols As Variant ' Аббревиатуры протоколов
Dim aInsertedFiles() As INSDATA ' Имена файлов, которые были вставлены и добавленных закладок + количества вставок
Dim iNumFilesInserted As Integer ' Количество файлов, которые были вставлены
Dim aErrorsList() As ERRDATA ' Список ошибок
Dim iNumErrors As Integer ' Количество ошибок
Dim iCurCycleStep As Integer ' Текущий шаг цикла (при вставке всех ссылок)
Dim iCurConfirmationState As Integer ' Текущий ответ пользователя на запрос подтверждения
Dim bInCycleMode As Boolean ' Код исполняется в режиме вставки всех гиперссылок
Dim aDocumentBookmarks() As String ' Имена закладок в документе
Dim iNumDocumentBookmarks As Integer ' Количество закладок в документе
Dim lpstrBookmarkPrefix As String ' Префикс имен закладок
Dim lCurrentBookmarkID As Long ' Текущий суффикс имени закладки
Dim lpstrInsertTitle As String ' Заголовок окна
Dim iInsertedFilePos As Integer ' Куда был вставлен последний файл
Dim bOptionsInitialized As Boolean ' Были ли установлены значения по умолчанию переменных, задающих режимы работы
Dim bProcessWasInitialised As Boolean ' Были ли установлены начальные значения переменных
Dim aErrNames As Variant ' Массив, содержащий описания ошибок
Dim bNetLinksAsLocal As Boolean ' Рассматривать ссылки в сеть как локальные

Public bDialogConfirmed As Boolean ' Диалоговое окно было закрыто нажатием кнопки Ok
Public iNumHLinksInDoc As Integer ' Текущее число гиперссылок в документе
Public iBuf2UForm As Integer ' Буфер для промежуточного использования при редактировании поля SkipFirstLinksTextBox формы

'***********************************************************************
'* Функция получает полный путь к файлу и возвращает только имя файла *
'***********************************************************************
Function JustFileName(lpstrFullName As String) As String
Dim lLastDelimPos As Long
Dim lSLen As Long

lSLen = Len(lpstrFullName)

lLastDelimPos = MaxFrom(LastPosInStr(lpstrFullName, ":"), LastPosInStr(lpstrFullName, "/"), _
LastPosInStr(lpstrFullName, "\"))

Select Case lLastDelimPos
Case 0
JustFileName = lpstrFullName
Case lSLen
JustFileName = ""
Case Else
JustFileName = Mid(lpstrFullName, lLastDelimPos + 1)
End Select

End Function
'***********************************************************************
'* Функция возвращает максимальное из переданных ей значений *
'***********************************************************************
Function MaxFrom(ParamArray aPars() As Variant) As Variant
Dim i As Integer
Dim vCValue As Variant

vCValue = LBound(aPars)

For i = LBound(aPars) + 1 To UBound(aPars)
If vCValue < aPars(i) Then vCValue = aPars(i)
Next i

MaxFrom = vCValue
End Function
'***********************************************************************
'* Функция возвращает позицию последнего вхождения подстроки lpstrSubSt*
'* в строку lpstrSt или 0, если подстроки нет в строке (неполный аналог*
'* ф-ии InStrRev присутствующей в Microsoft Office 200 Visual Basic) *
'***********************************************************************
Function LastPosInStr(lpstrSt As String, lpstrSubSt As String) As Long
Dim lLastPos As Long
Dim lCurPos As Long
Dim lSLen As Long

lLastPos = 0
lCurPos = 0
lSLen = Len(lpstrSt)

Do
lCurPos = InStr(lCurPos + 1, lpstrSt, lpstrSubSt)
If lCurPos <> 0 Then lLastPos = lCurPos
If lCurPos = lSLen Then lCurPos = 0
Loop Until lCurPos = 0

LastPosInStr = lLastPos

End Function
'***********************************************************************
'* Функция получает полный путь к файлу и возвращает только путь *
'***********************************************************************
Function JustPathName(lpstrFullName As String) As String
Dim lLastDelimPos As Long
Dim lSLen As Long

lSLen = Len(lpstrFullName)

lLastDelimPos = MaxFrom(LastPosInStr(lpstrFullName, ":"), LastPosInStr(lpstrFullName, "/"), _
LastPosInStr(lpstrFullName, "\"))
Select Case lLastDelimPos
Case 0
JustPathName = ""
Case lSLen
JustPathName = lpstrFullName
Case Else
JustPathName = Mid(lpstrFullName, 1, lLastDelimPos)
End Select

End Function
'***********************************************************************
'* Процедура задает расширения для графических файлов *
'***********************************************************************
Sub SetGraphExtensions()
aGraphExtensions = Array(".jpg", ".gif", ".tif", ".bmp", ".pcx", ".dib", ".rle", ".emf", ".wmf", ".jpeg", ".jfif", ".jpe", _
".gfa", ".emz", ".wmz", ".pcz", ".pcd", ".mix", ".png", ".tiff", ".pct", ".pict", ".bmz", ".cdr", _
".cgm", ".eps", ".fpx", ".wpg", ".dxf", ".drw", ".tga")
End Sub
'***********************************************************************
'* Процедура задает имена протоколов *
'***********************************************************************
Sub SetProtocols()
aProtocols = Array("http:", "https:", "ftp:", "mailto:", "gopher:", "news:", "telnet:", _
"nntp:", "cid:", "mid:", "mms:", "msn:", "pnm:", "prospero:", "rlogin:", "tn3270:", "wais:")
End Sub
'***********************************************************************
'* Процедура добавляет CommandBar с именем BAR_NAME *
'***********************************************************************
Sub AddCBar()
Dim ctrl As CommandBarButton

CommandBars.Add Name:=BAR_NAME
', Temporary:=True
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton
CommandBars(BAR_NAME).Controls.Add Type:=msoControlButton

Set ctrl = CommandBars(BAR_NAME).Controls(1)
With ctrl
.Caption = BAR_INSCUR
.FaceId = 233
.TooltipText = BAR_INSCURTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.InsertHyperlinkedFileInDocument"
End With

Set ctrl = CommandBars(BAR_NAME).Controls(2)
With ctrl
.Caption = BAR_INSALL
.FaceId = 159
.TooltipText = BAR_INSALLTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.InsertAllHyperlinks"
End With

Set ctrl = CommandBars(BAR_NAME).Controls(3)
With ctrl
.Caption = BAR_SHOWCUR
.FaceId = 222
.TooltipText = BAR_SHOWCURTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.ShowCurrentHLink"
.BeginGroup = True
End With

Set ctrl = CommandBars(BAR_NAME).Controls(4)
With ctrl
.Caption = BAR_SHOWALL
.FaceId = 303
.TooltipText = BAR_SHOWALLTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.ShowAllHLinks"
End With
Set ctrl = CommandBars(BAR_NAME).Controls(5)
With ctrl
.Caption = BAR_SRC
.FaceId = 172
.TooltipText = BAR_SRCTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.FindLinks2Addr"
.BeginGroup = True
End With

Set ctrl = CommandBars(BAR_NAME).Controls(6)
With ctrl
.Caption = BAR_NUM
.FaceId = 674
.TooltipText = BAR_NUMTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.DisplayCurHLinkNum"
.BeginGroup = True
End With

Set ctrl = CommandBars(BAR_NAME).Controls(7)
With ctrl
.Caption = BAR_TEST
.FaceId = 837 ' или 161, 329, 550
.TooltipText = BAR_TESTT
.Style = msoButtonIconAndCaption
.OnAction = "InsHLinks.TestLinksByFollowingThem"
.BeginGroup = True
End With

End Sub
'***********************************************************************
'* Процедура удаляет CommandBar с именем BAR_NAME *
'***********************************************************************
Sub DelCBar()
On Error Resume Next
CommandBars(BAR_NAME).Delete
End Sub
'***********************************************************************
'* Функция возвращает True, если адрес ссылки начинается с http:, ftp:,*
'* mailto:, - иначе возвращает False *
'***********************************************************************
Function LinkFollowsToTheNet(lpstrCurAddress As String) As Boolean
Dim i As Integer

For i = 1 To PROTOCOLSCOUNT
If InStr(LCase(lpstrCurAddress), aProtocols(i)) > 0 Then
LinkFollowsToTheNet = True
Exit Function
End If
Next i

LinkFollowsToTheNet = False
End Function
'***********************************************************************
'* Функция возвращает True, если файл заданный в параметре lpstrFName *
'* существует, - иначе возвращает False *
'***********************************************************************
Function ExistFile(lpstrFName As String) As Boolean
Dim OFStr As OFSTRUCT
ExistFile = OpenFile(lpstrFName, OFStr, OF_EXIST) <> HFILE_ERROR
End Function
'***********************************************************************
'* Функция проверяет существование файла (если его нет, но задан *
'* параметр bSrchOnSpecPath, то проверяется также его наличие в *
'* директории lpstrFPath), возвращает полный путь к файлу или пустую *
'* строку, если файл не существует *
'***********************************************************************
'* ПРИМЕЧАНИЕ: функция не обрабатывает корректно строки начинающиеся с *
'* "..\" т.к. если файл указанный в такой строке существует на момент *
'* открытия html-файла в Word, то Word автоматически преобразовывает *
'* имя с учетом каталога верхнего уровня *
'***********************************************************************
Function DetermineLinkedFileName(lpstrCurAddress As String) As String
Dim lpstrS As String
Dim lpstrJustName As String

DetermineLinkedFileName = ""

lpstrJustName = JustFileName(lpstrCurAddress)

' Если указано только имя - проверяем его
If lpstrJustName = lpstrCurAddress Then
lpstrS = lpstrFPath + lpstrJustName
If ExistFile(lpstrS) Then DetermineLinkedFileName = lpstrS
' Если в имени нет ":", - проверяем второй
' символ (для путей в ЛВС), - если не "\" - предполагаем
' относительный путь - директорию(и) и имя файла
ElseIf (InStr(lpstrCurAddress, ":") = 0) And (InStr(Mid(lpstrCurAddress, 2, Len(lpstrCurAddress)), "\") <> 1) Then
If InStr(lpstrCurAddress, "\") = 1 Then
lpstrS = lpstrFPath + Mid(lpstrCurAddress, 2, Len(lpstrCurAddress))
Else
lpstrS = lpstrFPath + lpstrCurAddress
End If
If ExistFile(lpstrS) Then
DetermineLinkedFileName = lpstrS
ElseIf bSrchOnSpecPath Then
lpstrS = lpstrFPath + lpstrJustName
If ExistFile(lpstrS) Then DetermineLinkedFileName = lpstrS
End If
' Если предыдущие условия не выполнялись, - предполагаем,
' что задан полный путь к файлу
Else
If ExistFile(lpstrCurAddress) Then DetermineLinkedFileName = lpstrCurAddress
End If

End Function
'***********************************************************************
'* Процедура заменяет все "/" на "\" (если есть) *
'***********************************************************************
Sub ChangeDelimiters(ByRef lpstrCurAddress As String)
Dim lSLen As Long
Dim lSPos As Long

lSLen = Len(lpstrCurAddress)
Do
lSPos = InStr(lpstrCurAddress, "/")
If lSPos <> 0 Then
lpstrCurAddress = Mid(lpstrCurAddress, 1, lSPos - 1) + "\" + Mid(lpstrCurAddress, lSPos + 1, lSLen)
End If
Loop Until lSPos = 0
End Sub
'***********************************************************************
'* Функция возвращает SFI_NOTINSERTEDYET, если файл заданный в *
'* параметре lpstrCurAddress еще не был вставлен в документ, если файл *
'* уже был вставлен в документ и bCaInsRepeatedly = True, функция *
'* возвращает SFI_NEEDREPINS, иначе SFI_CANTREPINS. Если параметр *
'* bNeedModifyHLink = True, то, если файл уже вставлялся в документ, и *
'* bCaInsRepeatedly = False, будет изменен адрес гиперссылки, чтобы *
'* указывать на первую копию вставленного файла *
'***********************************************************************
Function ScipFileInsertion(lpstrCurAddress As String, bCaInsRepeatedly As Boolean, _
bNeedModifyHLink As Boolean) As Integer
Dim i As Integer

If iNumFilesInserted = 0 Then GoTo ExitFunct

' Проверку проводим с конца (для скорости), т.к. в
' оглавлениях различных руководств как правило сначала
' идет ссылка на главу, а затем на ее части (на
' закладки в том же файле)
For i = iNumFilesInserted To 1 Step -1
If aInsertedFiles(i).lpstrFName = LCase(lpstrCurAddress) Then
If bCaInsRepeatedly Then
ScipFileInsertion = SFI_NEEDREPINS
Else
If bNeedModifyHLink Then
If Selection.Range.Hyperlinks(1).SubAddress <> "" Then
Selection.Range.Hyperlinks(1).Address = ""
Else
Selection.Range.Hyperlinks(1).SubAddress = aInsertedFiles(i).lpstrBMName
Selection.Range.Hyperlinks(1).Address = ""
End If
End If
ScipFileInsertion = SFI_CANTREPINS
End If
Exit Function
End If
Next i

ExitFunct:
ScipFileInsertion = SFI_NOTINSERTEDYET
End Function
'***********************************************************************
'* Функция возвращает True, если файл заданный в параметре *
'* lpstrCurAddress является графическим изображением, - иначе *
'* возвращает False *
'***********************************************************************
Function ThisFileIsAPicture(lpstrCurAddress As String) As Boolean
Dim lpstrS As String
Dim i As Integer

lpstrS = LCase(lpstrCurAddress)

For i = 1 To GRAPHFORMATSCOUNT
If InStr(lpstrS, aGraphExtensions(i)) Then
ThisFileIsAPicture = True
Exit Function
End If
Next i

ThisFileIsAPicture = False
End Function
'***********************************************************************
'* Процедура заносит имя файла в список имен уже вставленных файлов *
'***********************************************************************
Sub RegisterInsertedName(lpstrCurAddress As String)
iNumFilesInserted = iNumFilesInserted + 1

If iNumFilesInserted > 1 Then ReDim Preserve aInsertedFiles(iNumFilesInserted)

aInsertedFiles(iNumFilesInserted).lpstrFName = LCase(lpstrCurAddress)
aInsertedFiles(iNumFilesInserted).lpstrBMName = lpstrBookmarkPrefix + Format(lCurrentBookmarkID)
aInsertedFiles(iNumFilesInserted).iNumInserted = 1
End Sub
'***********************************************************************
'* Процедура увеличивает счетчик числа вставок для файла заданного в *
'* параметре lpstrCurAddress *
'***********************************************************************
Sub IncInsertionCounter(lpstrCurAddress As String)
Dim i As Integer

If iNumFilesInserted = 0 Then Exit Sub

' Проверку проводим с конца (для скорости), т.к. в
' оглавлениях различных руководств как правило сначала
' идет ссылка на главу, а затем на ее части (на
' закладки в том же файле)
For i = iNumFilesInserted To 1 Step -1
If aInsertedFiles(i).lpstrFName = LCase(lpstrCurAddress) Then _
aInsertedFiles(i).iNumInserted = aInsertedFiles(i).iNumInserted + 1
Next i

End Sub
'***********************************************************************
'* Процедура заносит имя файла и код ошибки в список ошибок *
'***********************************************************************
Sub Add2ErrorsList(lpstrCurAddress As String, iErrCode As Integer)
Dim i As Integer

' Проверяем не зарегистрирована ли уже эта ошибка
If iNumErrors > 0 Then
For i = 1 To iNumErrors
If (aErrorsList(i).lpstrFName = LCase(lpstrCurAddress)) And _
(aErrorsList(i).iErrCode = iErrCode) Then Exit Sub
Next i
End If

' Заносим в список
iNumErrors = iNumErrors + 1

If iNumErrors > 1 Then ReDim Preserve aErrorsList(iNumErrors)

aErrorsList(iNumErrors).lpstrFName = LCase(lpstrCurAddress)
aErrorsList(iNumErrors).iErrCode = iErrCode
End Sub
'***********************************************************************
'* Процедура заносит в переменную lpstrBookmarkPrefix cлучайную строку *
'***********************************************************************
Sub GenerateUniquePrefix()
Dim chPrefix As String * 1
Dim lSPos As Long

Randomize
chPrefix = Chr(97 + Int((25 * Rnd) + 1))

lpstrBookmarkPrefix = Format(Rnd)

lSPos = InStr(lpstrBookmarkPrefix, Application.International(wdDecimalSeparator))
If lSPos <> 0 Then
lpstrBookmarkPrefix = Mid(lpstrBookmarkPrefix, 1, lSPos - 1) + Mid(lpstrBookmarkPrefix, lSPos + 1)
End If

lSPos = InStr(lpstrBookmarkPrefix, "-")
If lSPos <> 0 Then
lpstrBookmarkPrefix = Mid(lpstrBookmarkPrefix, 1, lSPos - 1) + Mid(lpstrBookmarkPrefix, lSPos + 1)
End If
lpstrBookmarkPrefix = LCase(chPrefix + lpstrBookmarkPrefix + "_")

End Sub
'***********************************************************************
'* Процедура заносит все имена закладок определенных в документе в *
'* массив aDocumentBookmarks *
'***********************************************************************
Sub CountDocumentBookmarks()
Dim i As Integer

iNumDocumentBookmarks = ActiveDocument.Bookmarks.Count
If iNumDocumentBookmarks > 0 Then
ReDim aDocumentBookmarks(iNumDocumentBookmarks)
For i = 1 To iNumDocumentBookmarks
aDocumentBookmarks(i) = LCase(ActiveDocument.Bookmarks(i).Name)
Next i
End If

GenerateUniquePrefix

lCurrentBookmarkID = 0
End Sub
'***********************************************************************
'* Процедура вставляет закладку в текущую позицию и добавляет ее в *
'* массив имен закладок; изменяет значение переменной *
'* lCurrentBookmarkID *
'***********************************************************************
Sub AddBMark2ThisPos()
Dim lpstrCName As String
Dim i As Integer

GenerateNew:
lCurrentBookmarkID = lCurrentBookmarkID + 1
lpstrCName = lpstrBookmarkPrefix + Format(lCurrentBookmarkID)

For i = 1 To iNumDocumentBookmarks
If aDocumentBookmarks(i) = lpstrCName Then GoTo GenerateNew
Next i

iNumDocumentBookmarks = iNumDocumentBookmarks + 1
ReDim Preserve aDocumentBookmarks(iNumDocumentBookmarks)
aDocumentBookmarks(iNumDocumentBookmarks) = lpstrCName

ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:=lpstrCName

End Sub
'***********************************************************************
'* Процедура вставляет параграф под выделенную область *
'***********************************************************************
Sub InsertPUnderSelection()
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
End Sub
'***********************************************************************
'* Функция позволяет пользователю выбрать файл (возвращает полный путь *
'* или пустую строку в случае отмены) *
'***********************************************************************
Function ChooseCorrectName(lpstrCurAddress As String) As String
Dim ofn As OPENFILENAME
Dim lpstrCustFilterSpec As String * MAXCUSTFILTER
Dim lpstrFName As String
Dim lpstrInitStr As String
Dim lZPos As Long

lpstrInitStr = JustFileName(lpstrCurAddress)
If lpstrInitStr = "" Then
lpstrFName = VBA.String(MAXFNAME, &H0)
Else
lpstrFName = lpstrInitStr + VBA.String(MAXFNAME - Len(lpstrInitStr), &H0)
End If

With ofn
.lStructSize = Len(ofn)
.hwndOwner = GetActiveWindow
.lpstrFilter = ANYFILEFILTER
.lpstrCustomFilter = lpstrCustFilterSpec
.nMaxCustFilter = MAXCUSTFILTER
.nFilterIndex = 1
.lpstrFile = lpstrFName
.nMaxFile = MAXFNAME
.lpstrFileTitle = &H0
.lpstrInitialDir = lpstrFPath
.lpstrTitle = lpstrInsertTitle
.flags = OFN_FILEMUSTEXIST + OFN_EXPLORER + OFN_HIDEREADONLY
.lpstrDefExt = &H0
End With

If GetOpenFileName(ofn) > 0 Then
lZPos = InStr(ofn.lpstrFile, Chr(0))
If lZPos <> 0 Then ofn.lpstrFile = Left(ofn.lpstrFile, lZPos - 1)
ChooseCorrectName = ofn.lpstrFile
Else
ChooseCorrectName = ""
End If
End Function
'***********************************************************************
'* Функция выводит сообщение о том, что файл не найден и позволяет *
'* пользователю выбрать - найти файл вручную, пропустить его или *
'* отменить процедуру вставки (возвращает vbYes - файл найден, vbNo - *
'* пропустить файл, vbCancel - отменить) *
'***********************************************************************
Function GetNameFromUser(ByRef lpstrCurAddress As String) As Integer
Dim lpstrBuf As String
TryAgain:
Select Case MsgBox(MSG_FILE + lpstrCurAddress + MSG_NOTEXIST + Chr(13) + MSG_FINDMANUALLY, vbCritical +
vbYesNoCancel, lpstrInsertTitle)
Case vbYes
lpstrBuf = ChooseCorrectName(lpstrCurAddress)
If lpstrBuf = "" Then
GoTo TryAgain
Else
lpstrCurAddress = lpstrBuf
GetNameFromUser = vbYes
End If
Case vbCancel
GetNameFromUser = vbCancel
Case Else
GetNameFromUser = vbNo
End Select
End Function
'***********************************************************************
'* Процедура добавляет к тексту гиперссылки комментарий *
'***********************************************************************
Sub AddComment2HLink(lpstrComment As String)
If Selection.Range.Hyperlinks.Count > 0 Then
Selection.Range.Hyperlinks(1).TextToDisplay = Selection.Range.Hyperlinks(1).TextToDisplay + lpstrComment
End If
End Sub
'***********************************************************************
'* Процедура вставляет выделенную гиперссылку в документ *
'***********************************************************************
Sub InsertSelected()
Dim lpstrCurAddress As String
Dim lpstrBuf As String
Dim rngCurRange As Variant
Dim bIsPic As Boolean
Dim bCaInsRepeatedly As Boolean
Dim bNeedModifyHLink As Boolean
Dim bAlreadyConfirmed As Boolean
Dim iCurFileState As Integer
Dim iCurReportOnRepMode As Integer

' Файл не был вставлен
iInsertedFilePos = IPS_NOTINSERT

' Инициализируем переменные, если не было инициализации
If Not bProcessWasInitialised Then

lpstrInsertTitle = INSHLTITLE

If bOnlyTestMode Then lpstrInsertTitle = lpstrInsertTitle + TESTMODETITLE

CountDocumentBookmarks

bProcessWasInitialised = True
End If

' Получаем адрес
Set rngCurRange = ActiveWindow.Selection.Range
If rngCurRange.Hyperlinks.Count = 0 Then Exit Sub

lpstrCurAddress = Trim(Selection.Range.Hyperlinks(1).Address)
If lpstrCurAddress = "" Then Exit Sub

' Проверяем не указывает ли ссылка в глобальную сеть
If LinkFollowsToTheNet(lpstrCurAddress) Then
If Not bNetLinksAsLocal Then
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_LFOLLOW2NET
Else
lpstrCurAddress = JustFileName(lpstrCurAddress)
End If

If bCommentLinks2Net And (Not bOnlyTestMode) Then _
AddComment2HLink " (" + aErrNames(ERR_LFOLLOW2NET) + ")"

If Not bNetLinksAsLocal Then Exit Sub
End If

' Определяем, является ли вставляемый файл графическим изображением
bIsPic = ThisFileIsAPicture(lpstrCurAddress)

' Определяем нужно ли вставлять файлы этого типа
If (bIsPic And (iPicsInsMode = IPS_NOTINSERT)) Or (Not bIsPic And (iNonPicsInsMode = IPS_NOTINSERT)) Then
If bCommentNotIns And (Not bOnlyTestMode) Then _
AddComment2HLink MSG_FWASNOTINS
Exit Sub
End If

' Производим замену разделителей
ChangeDelimiters lpstrCurAddress

' Определяем полное имя файла
lpstrBuf = DetermineLinkedFileName(lpstrCurAddress)

' Если не удалось определить полное имя, - запрашиваем
' его у пользователя (если задано)
If lpstrBuf = "" Then
If bReportErrors Then
iCurConfirmationState = GetNameFromUser(lpstrCurAddress)
If iCurConfirmationState <> vbYes Then
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_FNOTFOUND
If bCommentErrors And (Not bOnlyTestMode) Then _
AddComment2HLink " (" + aErrNames(ERR_FNOTFOUND) + ")"
Exit Sub
End If
Else
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_FNOTFOUND
If bCommentErrors And (Not bOnlyTestMode) Then _
AddComment2HLink " (" + aErrNames(ERR_FNOTFOUND) + ")"
Exit Sub
End If
Else
lpstrCurAddress = lpstrBuf
End If

' Определяем требуется ли изменять гиперссылку
bNeedModifyHLink = (Not bOnlyTestMode) And _
((bIsPic And (iPicsInsMode <> IPS_REPLACESELECTION)) _
Or (Not bIsPic And (iNonPicsInsMode <> IPS_REPLACESELECTION)))

bAlreadyConfirmed = False
' Определяем был ли уже вставлен этот файл
If bInCycleMode Then
bCaInsRepeatedly = (bIsPic And bInsRepPics) Or ((Not bIsPic) And bInsRepNonPics)
If bIsPic Then
iCurReportOnRepMode = iReportOnRepPics
Else
iCurReportOnRepMode = iReportOnRepNonPics
End If
iCurFileState = ScipFileInsertion(lpstrCurAddress, bCaInsRepeatedly, bNeedModifyHLink)
Select Case iCurFileState
' Файл уже был вставлен и повторная вставка не нужна
Case SFI_CANTREPINS
If bCommentReps And (Not bOnlyTestMode) Then _
AddComment2HLink MSG_ALREADYINSERTED
Select Case iCurReportOnRepMode
Case ROR_ALWAYS
MsgBox MSG_HLINK2FILE + lpstrCurAddress + MSG_FNOTREPINS, vbInformation, lpstrInsertTitle
Case ROR_ALWAYSASK
iCurConfirmationState = MsgBox(MSG_HLINK2FILE + lpstrCurAddress + MSG_FNOTREPINS + Chr(13) + MSG_CONTINUEPROCESS,
vbOKCancel + vbQuestion, lpstrInsertTitle)
End Select
Exit Sub
' Файл уже был вставлен, но требуется повторная вставка
Case SFI_NEEDREPINS
Select Case iCurReportOnRepMode
Case ROR_ALWAYS, ROR_IFINSERTED
MsgBox MSG_HLINK2FILE + lpstrCurAddress + MSG_FREPINS, vbInformation, lpstrInsertTitle
Case ROR_ALWAYSASK, ROR_IFINSERTEDASK
iCurConfirmationState = MsgBox(MSG_HLINK2FILE + lpstrCurAddress + MSG_FREPINS + Chr(13) + MSG_INSERTORNOT,
vbYesNoCancel + vbQuestion, lpstrInsertTitle)
If iCurConfirmationState <> vbYes Then
If iCurConfirmationState = vbNo Then
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_FSCIPPED
If bCommentErrors And (Not bOnlyTestMode) Then _
AddComment2HLink " (" + aErrNames(ERR_FSCIPPED) + ")"
End If
Exit Sub
End If
bAlreadyConfirmed = True
End Select
If bCommentReps And bNeedModifyHLink Then _
AddComment2HLink MSG_INSERTEDREP
End Select
End If

' Если требуется, запрашиваем подтверждение на вставку
If bNeedConfirmation And (Not bAlreadyConfirmed) Then
iCurConfirmationState = MsgBox(MSG_CLINKPROPRT + Chr(13) + MSG_ADDR + lpstrCurAddress + Chr(13) + MSG_SUBADDR +
Selection.Range.Hyperlinks(1).SubAddress + Chr(13) + _
MSG_INSLINKORNOT, vbYesNoCancel + vbQuestion, lpstrInsertTitle)
If iCurConfirmationState <> vbYes Then
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_FSCIPPED
If bCommentErrors And (Not bOnlyTestMode) Then _
AddComment2HLink " (" + aErrNames(ERR_FSCIPPED) + ")"
Exit Sub
End If
End If

On Error GoTo ErrorHandler
' Если работаем не в режиме тестирования, - вставляем файл
If Not bOnlyTestMode Then
If (bIsPic And (iPicsInsMode = IPS_UNDERSELECTION)) Or (Not bIsPic And (iNonPicsInsMode = IPS_UNDERSELECTION)) Then
InsertPUnderSelection
iInsertedFilePos = IPS_UNDERSELECTION
ElseIf (bIsPic And (iPicsInsMode = IPS_REPLACESELECTION)) Or (Not bIsPic And (iNonPicsInsMode = IPS_REPLACESELECTION)) Then
Selection.Delete Unit:=wdCharacter, Count:=1
Set rngCurRange = ActiveWindow.Selection.Range
iInsertedFilePos = IPS_REPLACESELECTION
Else
Selection.EndKey Unit:=wdStory
iInsertedFilePos = IPS_TOEND
End If

' Устанавливаем закладку на текущую позицию
AddBMark2ThisPos

If bIsPic Then
Selection.InlineShapes.AddPicture FileName:=lpstrCurAddress, _
LinkToFile:=False, SaveWithDocument:=True
Else
Selection.InsertFile FileName:=lpstrCurAddress, Range:="", ConfirmConversions _
:=False, Link:=False, Attachment:=False
End If
End If
On Error GoTo 0

' Регистрируем вставленный файл
If bInCycleMode Then
If iCurFileState = SFI_NEEDREPINS Then
IncInsertionCounter lpstrCurAddress
Else
RegisterInsertedName lpstrCurAddress
End If
End If

rngCurRange.Select

' Если требуется, - изменяем гиперссылку
If (Not bOnlyTestMode) And (iInsertedFilePos <> IPS_REPLACESELECTION) Then
Selection.Range.Hyperlinks(1).SubAddress = lpstrBookmarkPrefix + Format(lCurrentBookmarkID)
Selection.Range.Hyperlinks(1).Address = ""
End If

If Not bInCycleMode Then
If bReportOnFinished Then MsgBox MSG_FINISHINS, vbInformation, lpstrInsertTitle
End If

Exit Sub

' Обработчик ошибок
ErrorHandler:
iInsertedFilePos = IPS_NOTINSERT
If bInCycleMode Then Add2ErrorsList lpstrCurAddress, ERR_WHILEINSERT
If bCommentErrors And bNeedModifyHLink Then _
AddComment2HLink " (" + aErrNames(ERR_WHILEINSERT) + ")"
If bReportErrors Then MsgBox MSG_ERRWHILETRYINS + lpstrCurAddress, vbCritical, lpstrInsertTitle
End Sub
'***********************************************************************
'* Если в документе нет гиперссылок, функция выдает сообщение и *
'* возвращает True, иначе возвращает False. После вызова функции в *
'* переменной iNumHLinksInDoc находится число гиперссылок в документе. *
'***********************************************************************
Function NoHLinksInDoc(lpstrTitle As String) As Boolean
iNumHLinksInDoc = ActiveDocument.Hyperlinks.Count
If iNumHLinksInDoc = 0 Then
MsgBox MSG_NOHLINKSINDOC, vbCritical, lpstrTitle
NoHLinksInDoc = True
Else
NoHLinksInDoc = False
End If
End Function
'***********************************************************************
'* Функция возвращает количество файлов вставленных более одного раза *
'***********************************************************************
Function CountNumReps() As Integer
Dim iCounter As Integer
Dim i As Integer

iCounter = 0

If iNumFilesInserted > 0 Then
For i = 1 To iNumFilesInserted
If aInsertedFiles(i).iNumInserted > 1 Then iCounter = iCounter + 1
Next i
End If

CountNumReps = iCounter
End Function
'***********************************************************************
'* Процедура выводит данные в ячейку таблицы отчета *
'***********************************************************************
Sub TypeDataInCell(ArrPos As Integer, TypeName As Boolean)

Selection.MoveRight Unit:=wdCell
If TypeName Then
Selection.TypeText Text:=aInsertedFiles(ArrPos).lpstrFName
Else
Selection.TypeText Text:=Format(aInsertedFiles(ArrPos).iNumInserted)
End If

If (aInsertedFiles(ArrPos).iNumInserted > 1) And bColorizeReps Then Selection.Shading.BackgroundPatternColor = wdColorTan

End Sub
'***********************************************************************
'* Функция возвращает число ссылок ведущих в сеть *
'***********************************************************************
Function CalcNumLinks2Net() As Integer
Dim i As Integer
Dim iNL As Integer

iNL = 0

If iNumErrors > 0 Then
For i = 1 To iNumErrors
If aErrorsList(i).iErrCode = ERR_LFOLLOW2NET Then iNL = iNL + 1
Next i
End If

CalcNumLinks2Net = iNL
End Function
'***********************************************************************
'* Процедура выводит отчет *
'***********************************************************************
Sub MakeReport()
Dim iNumReps As Integer
Dim i As Integer
Dim iNumLinks2Net As Integer
Dim iNumErr As Integer
Dim iNumRows As Integer
Dim lpstrTTitle As String

lpstrTTitle = ActiveDocument.Name

Documents.Add DocumentType:=wdNewBlankDocument

Selection.TypeText Text:=MSG_REPORT
Selection.HomeKey Unit:=wdLine
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.Font.Size = 14
Selection.EndKey Unit:=wdLine
Selection.TypeText Text:=" "
Selection.Font.Bold = wdToggle
Selection.TypeText Text:=lpstrTTitle
Selection.TypeParagraph
Selection.MoveUp Unit:=wdLine, Count:=1
Selection.EndKey Unit:=wdLine, Extend:=wdExtend
Selection.ParagraphFormat.Shading.BackgroundPatternColor = wdColorGray30
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
Selection.Font.Bold = wdToggle
Selection.Font.Size = 10
Selection.TypeText Text:=MSG_TOTALINSFILESNUM + Format(iNumFilesInserted)
Selection.TypeParagraph

iNumReps = CountNumReps
Selection.TypeText Text:=MSG_REPINSFILESNUM + Format(iNumReps)
Selection.TypeParagraph

iNumLinks2Net = CalcNumLinks2Net
If iNumLinks2Net > 0 Then
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:=LINKS2NET_BOOKMARK, TextToDisplay:=MSG_LINKS2NETNUM + Format(iNumLinks2Net)
Else
Selection.TypeText Text:=MSG_LINKS2NETNUM + Format(iNumLinks2Net)
End If
Selection.TypeParagraph

iNumErr = iNumErrors - iNumLinks2Net
If iNumErr > 0 Then
ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:="", _
SubAddress:=ERRORS_BOOKMARK, TextToDisplay:=MSG_ERRORSNUM + Format(iNumErr)
Else
Selection.TypeText Text:=MSG_ERRORSNUM + Format(iNumErr)
End If

Selection.TypeParagraph
Selection.TypeParagraph

If iNumFilesInserted > 0 Then
If bOnlyRepsInReport Then
iNumRows = iNumReps + 2
lpstrTTitle = MSG_INSERTEDFILES + MSG_ONLYREPSLISTED
Else
iNumRows = iNumFilesInserted + 2
lpstrTTitle = MSG_INSERTEDFILES
End If
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=iNumRows, NumColumns:=2
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.Cells.Merge
Selection.Font.Bold = wdToggle
Selection.Font.Color = wdColorWhite
Selection.Cells.Shading.BackgroundPatternColor = wdColorBlack
Selection.TypeText Text:=lpstrTTitle
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=MSG_NAMEOFINSERTED
Selection.Shading.BackgroundPatternColor = wdColorGray25
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=MSG_INSERTIONSNUM
Selection.Shading.BackgroundPatternColor = wdColorGray25

For i = 1 To iNumFilesInserted
If (Not bOnlyRepsInReport) Or (aInsertedFiles(i).iNumInserted > 1) Then
TypeDataInCell i, True
TypeDataInCell i, False
End If
Next i
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
End If

If iNumLinks2Net > 0 Then
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:=LINKS2NET_BOOKMARK
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=iNumLinks2Net + 2, NumColumns:=1
Selection.Font.Bold = wdToggle
Selection.Font.Color = wdColorWhite
Selection.Cells.Shading.BackgroundPatternColor = wdColorBlack
Selection.TypeText Text:=MSG_LINKSINGLOBAL
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=MSG_ADDRINHLINK
Selection.Shading.BackgroundPatternColor = wdColorGray25

For i = 1 To iNumErrors
If aErrorsList(i).iErrCode = ERR_LFOLLOW2NET Then
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=aErrorsList(i).lpstrFName
End If
Next i
Selection.MoveDown Unit:=wdLine, Count:=1
Selection.TypeParagraph
End If

If iNumErr > 0 Then
ActiveDocument.Bookmarks.Add Range:=Selection.Range, Name:=ERRORS_BOOKMARK
ActiveDocument.Tables.Add Range:=Selection.Range, NumRows:=iNumErr + 2, NumColumns:=2
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.Cells.Merge
Selection.Font.Bold = wdToggle
Selection.Font.Color = wdColorWhite
Selection.Cells.Shading.BackgroundPatternColor = wdColorBlack
Selection.TypeText Text:=MSG_aErrorsList
Selection.ParagraphFormat.Alignment = wdAlignParagraphCenter
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=MSG_FILEINHLINK
Selection.Shading.BackgroundPatternColor = wdColorGray25
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=MSG_ERRTYPE
Selection.Shading.BackgroundPatternColor = wdColorGray25

For i = 1 To iNumErrors
If aErrorsList(i).iErrCode <> ERR_LFOLLOW2NET Then
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=aErrorsList(i).lpstrFName
Selection.MoveRight Unit:=wdCell
Selection.TypeText Text:=aErrNames(aErrorsList(i).iErrCode)
End If
Next i
End If

Selection.HomeKey Unit:=wdStory
End Sub
'***********************************************************************
'* Процедура устанавливает параметры в значения по умолчанию *
'***********************************************************************
Sub SetDefaultValues()
bOnlyTestMode = True ' Не вставлять гиперссылки, - только проверить
bNeedConfirmation = False ' Запрос подтверждения для каждой гиперссылки
bSrchOnSpecPath = True ' Искать файл в указанной директории, если его нет в поддиректории
bReportOnFinished = True ' Выдать сообщение о завершении
bNeedFullReport = True ' Нужно ли выводить полный отчет
bReportErrors = False ' Сообщать об ошибках в процессе вставки гиперссылок
bInsRepPics = True ' Вставлять ли повторяющиеся изображения повторно
bInsRepNonPics = False ' Вставлять ли повторяющиеся файлы повторно
bOnlyRepsInReport = False ' Выводить в отчет только сообщения о файлах вставленных более одного раза
bColorizeReps = True ' Выделять цветом сообщения о файлах вставленных более одного раза в отчете
bCommentErrors = True ' Добавить к тексту гиперссылки файла, при вставке которого возникла ошибка ее описание
bCommentLinks2Net = True ' Добавить к тексту гиперссылки в глобальную сеть сообщение об этом
bCommentReps = True ' Добавить к тексту гиперссылки на уже вставленный файл сообщение об этом
bCommentNotIns = True ' Добавить к тексту гиперссылки сообщение на о том, что ее вставка была пропущена
' (Если для текущего типа файла установлен режим IPS_NOTINSERT)

iSkipFirstLinks = 0 ' Пропустить указанное число ссылок сначала документа
iReportOnRepPics = ROR_NEWER ' Выводить сообщение о повторной вставке изображений
iReportOnRepNonPics = ROR_IFINSERTEDASK ' Выводить сообщение о повторной вставке файлов
iPicsInsMode = IPS_UNDERSELECTION ' Вставлять картинки
iNonPicsInsMode = IPS_TOEND ' Вставлять неграфические файлы

SetGraphExtensions
SetProtocols
aErrNames = Array(MSG_FSCIPPED, MSG_FNOTFOUND, MSG_WHILEINSERT, MSG_LINK2NET)

bOptionsInitialized = True
End Sub
'***********************************************************************
'* Процедура устанавливает значения элементов формы в соответствии со *
'* значениями параметров. (Вызывается перед отображением формы) *
'***********************************************************************
Sub SetFormFields()
Dim lpstrS As String

iBuf2UForm = iNumHLinksInDoc - 1
lpstrS = ActiveDocument.Path
If lpstrS = "" Then lpstrS = Options.DefaultFilePath(wdDocumentsPath)

With InsHLinksForm
' 1-я страница
.PathTextBox.Text = lpstrS
.WebLNKAsLocal.Value = bNetLinksAsLocal
.SrchOnSpecPathCheckBox.Value = bSrchOnSpecPath
.NeedConfirmationCheckBox.Value = bNeedConfirmation
.OnlyTestModeCheckBox.Value = bOnlyTestMode
.NeedConfirmationCheckBox.Value = bNeedConfirmation
.ReportErrorsCheckBox.Value = bReportErrors
.ReportOnFinishedCheckBox.Value = bReportOnFinished
If (iSkipFirstLinks > iBuf2UForm) Or (iSkipFirstLinks < 0) Then
.SkipFirstLinksTextBox.Value = 0
Else
.SkipFirstLinksTextBox.Value = iSkipFirstLinks
End If

' 2-я страница
.PNOTINSERTOptionButton.Value = iPicsInsMode = IPS_NOTINSERT
.PTOENDOptionButton.Value = iPicsInsMode = IPS_TOEND
.PUNDERSELECTIONOptionButton.Value = iPicsInsMode = IPS_UNDERSELECTION
.PREPLACESELECTIONOptionButton.Value = iPicsInsMode = IPS_REPLACESELECTION
.InsRepPicsCheckBox.Value = bInsRepPics
.PNEWEROptionButton.Value = iReportOnRepPics = ROR_NEWER
.PALWAYSOptionButton.Value = iReportOnRepPics = ROR_ALWAYS
.PALWAYSASKOptionButton.Value = iReportOnRepPics = ROR_ALWAYSASK
.PIFINSERTEDOptionButton.Value = iReportOnRepPics = ROR_IFINSERTED
.PIFINSERTEDASKOptionButton.Value = iReportOnRepPics = ROR_IFINSERTEDASK

' 3-я страница
.NPNOTINSERTOptionButton.Value = iNonPicsInsMode = IPS_NOTINSERT
.NPTOENDOptionButton.Value = iNonPicsInsMode = IPS_TOEND
.NPUNDERSELECTIONOptionButton.Value = iNonPicsInsMode = IPS_UNDERSELECTION
.NPREPLACESELECTIONOptionButton.Value = iNonPicsInsMode = IPS_REPLACESELECTION
.InsRepNonPicsCheckBox.Value = bInsRepNonPics
.NPNEWEROptionButton.Value = iReportOnRepNonPics = ROR_NEWER
.NPALWAYSOptionButton.Value = iReportOnRepNonPics = ROR_ALWAYS
.NPALWAYSASKOptionButton.Value = iReportOnRepNonPics = ROR_ALWAYSASK
.NPIFINSERTEDOptionButton.Value = iReportOnRepNonPics = ROR_IFINSERTED
.NPIFINSERTEDASKOptionButton.Value = iReportOnRepNonPics = ROR_IFINSERTEDASK

' 4-я страница
.NeedFullReportCheckBox.Value = bNeedFullReport
.OnlyRepsInReportCheckBox.Value = bOnlyRepsInReport
.ColorizeRepsCheckBox.Value = bColorizeReps
.CommentErrorsCheckBox.Value = bCommentErrors
.CommentLinks2NetCheckBox.Value = bCommentLinks2Net
.CommentRepsCheckBox.Value = bCommentReps
.CommentNotInsCheckBox.Value = bCommentNotIns

' Делаем активной первую страницу
.OptionsPages.Value = 0
End With
End Sub
'***********************************************************************
'* Процедура получает данные из формы. (Вызывается если форма не была *
'* отменена) *
'***********************************************************************
Sub GetFormFields()
With InsHLinksForm
' 1-я страница
bNetLinksAsLocal = .WebLNKAsLocal.Value
lpstrFPath = Trim(.PathTextBox.Text)
If lpstrFPath = "" Then lpstrFPath = Options.DefaultFilePath(wdDocumentsPath)
If Right(lpstrFPath, 1) <> "\" Then lpstrFPath = lpstrFPath & "\"
bSrchOnSpecPath = .SrchOnSpecPathCheckBox.Value
bNeedConfirmation = .NeedConfirmationCheckBox.Value
bOnlyTestMode = .OnlyTestModeCheckBox.Value
bNeedConfirmation = .NeedConfirmationCheckBox.Value
bReportErrors = .ReportErrorsCheckBox.Value
bReportOnFinished = .ReportOnFinishedCheckBox.Value
iSkipFirstLinks = .SkipFirstLinksTextBox.Value

' 2-я страница
If .PNOTINSERTOptionButton.Value Then
iPicsInsMode = IPS_NOTINSERT
ElseIf .PTOENDOptionButton.Value Then
iPicsInsMode = IPS_TOEND
ElseIf .PUNDERSELECTIONOptionButton.Value Then
iPicsInsMode = IPS_UNDERSELECTION
Else
iPicsInsMode = IPS_REPLACESELECTION
End If
bInsRepPics = .InsRepPicsCheckBox.Value
If .PNEWEROptionButton.Value Then
iReportOnRepPics = ROR_NEWER
ElseIf .PALWAYSOptionButton.Value Then
iReportOnRepPics = ROR_ALWAYS
ElseIf .PALWAYSASKOptionButton.Value Then
iReportOnRepPics = ROR_ALWAYSASK
ElseIf .PIFINSERTEDOptionButton.Value Then
iReportOnRepPics = ROR_IFINSERTED
Else
iReportOnRepPics = ROR_IFINSERTEDASK
End If

' 3-я страница
If .NPNOTINSERTOptionButton.Value Then
iNonPicsInsMode = IPS_NOTINSERT
ElseIf .NPTOENDOptionButton.Value Then
iNonPicsInsMode = IPS_TOEND
ElseIf .NPUNDERSELECTIONOptionButton.Value Then
iNonPicsInsMode = IPS_UNDERSELECTION
Else
iNonPicsInsMode = IPS_REPLACESELECTION
End If
bInsRepNonPics = .InsRepNonPicsCheckBox.Value
If .NPNEWEROptionButton.Value Then
iReportOnRepNonPics = ROR_NEWER
ElseIf .NPALWAYSOptionButton.Value Then
iReportOnRepNonPics = ROR_ALWAYS
ElseIf .NPALWAYSASKOptionButton.Value Then
iReportOnRepNonPics = ROR_ALWAYSASK
ElseIf .NPIFINSERTEDOptionButton.Value Then
iReportOnRepNonPics = ROR_IFINSERTED
Else
iReportOnRepNonPics = ROR_IFINSERTEDASK
End If

' 4-я страница
bNeedFullReport = .NeedFullReportCheckBox.Value
bOnlyRepsInReport = .OnlyRepsInReportCheckBox.Value
bColorizeReps = .ColorizeRepsCheckBox.Value
bCommentErrors = .CommentErrorsCheckBox.Value
bCommentLinks2Net = .CommentLinks2NetCheckBox.Value
bCommentReps = .CommentRepsCheckBox.Value
bCommentNotIns = .CommentNotInsCheckBox.Value
End With
End Sub
'***********************************************************************
'* Функция выводит диалоговое окно с параметрами *
'***********************************************************************
Function SetOptions() As Boolean

If Not bOptionsInitialized Then SetDefaultValues

Load InsHLinksForm

SetFormFields

bDialogConfirmed = False

InsHLinksForm.Show

If bDialogConfirmed Then
GetFormFields
SetOptions = True
Else
SetOptions = False
End If

End Function
'***********************************************************************
'* Процедура вставляет текущую выделенную гиперссылку в документ *
'***********************************************************************
Sub InsertHyperlinkedFileInDocument()

If Documents.Count = 0 Then Exit Sub

If NoHLinksInDoc(INSHLTITLE) Then Exit Sub

If Not SetOptions Then Exit Sub

If (iPicsInsMode = IPS_NOTINSERT) And (iNonPicsInsMode = IPS_NOTINSERT) Then Exit Sub

bProcessWasInitialised = False

bInCycleMode = False

iNumFilesInserted = 0

InsertSelected
End Sub
'***********************************************************************
'* Процедура вставляет все гиперссылки в документ *
'***********************************************************************
Sub InsertAllHyperlinks()
Dim hLink As Hyperlink
Dim iInitHLinksCount As Integer
Dim iCurHLinksCount As Integer
Dim iPrevHLinksCount As Integer
Dim iNumLinksInserted2End As Integer
Dim iDifference As Integer

If Documents.Count = 0 Then Exit Sub

If NoHLinksInDoc(INSHLTITLE) Then Exit Sub

iInitHLinksCount = iNumHLinksInDoc

If Not SetOptions Then Exit Sub

If (iPicsInsMode = IPS_NOTINSERT) And (iNonPicsInsMode = IPS_NOTINSERT) Then Exit Sub

iCurHLinksCount = iInitHLinksCount

bProcessWasInitialised = False

bInCycleMode = True
iNumFilesInserted = 0
ReDim aInsertedFiles(1)
iNumErrors = 0
ReDim aErrorsList(1)
iNumLinksInserted2End = 0
iDifference = 0

For iCurCycleStep = iSkipFirstLinks + 1 To iInitHLinksCount
Set hLink = ActiveDocument.Hyperlinks(iCurCycleStep + iDifference)
If hLink.Type = msoHyperlinkShape Then
hLink.Shape.Select
Else
hLink.Range.Select
End If

iPrevHLinksCount = iCurHLinksCount
iCurConfirmationState = vbYes

InsertSelected

If iCurConfirmationState = vbCancel Then Exit Sub
If iInsertedFilePos <> IPS_NOTINSERT Then
iCurHLinksCount = ActiveDocument.Hyperlinks.Count
If iInsertedFilePos = IPS_TOEND Then
iNumLinksInserted2End = iCurHLinksCount - iPrevHLinksCount
Else
iDifference = iCurHLinksCount - iNumLinksInserted2End - iInitHLinksCount
End If
End If
Next iCurCycleStep

If bNeedFullReport Then MakeReport

If bReportOnFinished Then MsgBox MSG_FINISHINS, vbInformation, lpstrInsertTitle
End Sub
'***********************************************************************
'* Процедура выводит свойства Address и SubAdress выделенной ссылки *
'***********************************************************************
Sub ShowCurrentHLink()
Dim hLink As Hyperlink

If Documents.Count = 0 Then Exit Sub

On Error GoTo ExitProc

If ActiveWindow.Selection.Range.Hyperlinks.Count = 0 Then Exit Sub
Set hLink = ActiveWindow.Selection.Range.Hyperlinks(1)
MsgBox MSG_ADDR + hLink.Address + Chr(13) + MSG_SUBADDR + hLink.SubAddress, vbInformation, SHOWHLTITLE

ExitProc:
End Sub
'***********************************************************************
'* Процедура выводит свойства Address и SubAdress для всех гиперссылок *
'* документа по очереди *
'***********************************************************************
Sub ShowAllHLinks()
Dim hLink As Hyperlink
Dim i As Integer
Dim iCount As Integer

If Documents.Count = 0 Then Exit Sub

On Error Resume Next
iCount = ActiveDocument.Hyperlinks.Count
If (iCount = 0) Or (iCount <= iSkipFirstLinks) Then Exit Sub

For i = 1 + iSkipFirstLinks To iCount
Set hLink = ActiveDocument.Hyperlinks(i)
hLink.Range.Select

If MsgBox(MSG_ADDR + hLink.Address + Chr(13) + MSG_SUBADDR + hLink.SubAddress, vbOKCancel + vbInformation,
SHOWHLTITLE) <> vbOK Then Exit Sub
Next i
End Sub
'***********************************************************************
'* Процедура выделяет гиперссылки, в адресе которых есть указанное *
'* пользователем сочетание символов (при сравнении процедура заменяет *
'* все "/" на "\" (если есть) *
'***********************************************************************
Sub FindLinks2Addr()
Dim hLink As Hyperlink
Dim i As Integer
Dim iCount As Integer
Dim lpstrSearchStr As String
Dim lpstrSearchFor As String
Dim bFound As Boolean

If Documents.Count = 0 Then Exit Sub

bFound = False

On Error Resume Next
iCount = ActiveDocument.Hyperlinks.Count

If (iCount = 0) Or (iCount <= iSkipFirstLinks) Then Exit Sub

lpstrSearchFor = InputBox(MSG_INPUTSEARCHADDR, SEARCHHLINKTITLE)
If lpstrSearchFor = "" Then Exit Sub

If InStr(lpstrSearchFor, "#") Then
lpstrSearchFor = Mid(lpstrSearchFor, 2, Len(lpstrSearchFor))
If IsNumeric(lpstrSearchFor) Then
ActiveDocument.Hyperlinks(Val(lpstrSearchFor)).Range.Select
Exit Sub
End If
End If

lpstrSearchFor = LCase(lpstrSearchFor)
ChangeDelimiters lpstrSearchFor

For i = 1 + iSkipFirstLinks To iCount
Set hLink = ActiveDocument.Hyperlinks(i)
lpstrSearchStr = LCase(hLink.Address)
ChangeDelimiters lpstrSearchStr
If InStr(1, lpstrSearchStr, lpstrSearchFor) Then
hLink.Range.Select
bFound = True
If MsgBox(MSG_ADDR + hLink.Address + Chr(13) + MSG_SUBADDR + hLink.SubAddress + Chr(13) + Chr(13) +
MSG_CONTINUESEARCH, vbOKCancel + vbInformation, SEARCHHLINKTITLE) <> vbOK Then Exit Sub
End If
Next i
If bFound Then
MsgBox MSG_SEARCHFINISHED, , SEARCHHLINKTITLE
Else
MsgBox MSG_SEARCHFINISHED + Chr(13) + Chr(13) + MSG_DATANOTFOUND, , SEARCHHLINKTITLE
End If
End Sub
'***********************************************************************
'* Процедура выдает номер выделенной гиперссылки *
'***********************************************************************
Sub DisplayCurHLinkNum()
Dim hCurLink As Hyperlink
Dim hLink As Hyperlink
Dim i As Integer
Dim iCount As Integer

On Error Resume Next

If Documents.Count = 0 Then Exit Sub

iCount = ActiveDocument.Hyperlinks.Count

If iCount = 0 Then Exit Sub

With ActiveWindow.Selection.Range
If .Hyperlinks.Count = 0 Then Exit Sub
Set hLink = .Hyperlinks(1)
End With

For i = 1 To iCount
Set hCurLink = ActiveDocument.Hyperlinks(i)
If hCurLink.Range = hLink.Range Then
MsgBox MSG_CURHLNUM + Format(i), vbInformation, SHOWNUMTITLE
Exit Sub
End If
Next i
End Sub