Private Sub NamesSpaces2Return(ByRef sString As String)
' Функция заменяет пробелы в ФИО людей на CR
Const sSpace = " "
Dim nPos1, nPos2 As Integer
Dim sTemp As String
Dim sCR As String
sCR = Chr(13)
nPos1 = InStr(sString, sSpace)
nPos2 = InStr(nPos1 + 1, sString, sSpace)
sTemp = Mid(sString, 1, nPos1 - 1) & sCR & Mid(sString, nPos1 + 1, nPos2 - nPos1) & sCR & Mid(sString, nPos2 + 1, Len(sString) - nPos2)
sString = sTemp
End Sub
Private Sub AnalizeDDDString(ByVal sInpString As String, ByRef sTabNum As String, ByRef sName As String, ByRef sDolznost As String, ByRef sOtdel As String, ByRef sFotoName As String)
' разбор строки для пропусков ддда
' знак разделитель полей в строке
Const sDivider = ";"
Dim nCurrPos As Integer
' найдем первое поле - табельный номер
' он стоит до первого разделителя
nCurrPos = InStr(sInpString, sDivider)
' выдернем строку с табельным номером
sTabNum = Left(sInpString, nCurrPos - 1)
' из исходной строки удалим табельный номер и разделитель
nCharCount = Len(sInpString) - nCurrPos
sInpString = Right(sInpString, nCharCount)
' найдем второе поле - ФИО
' он стоит до первого разделителя
nCurrPos = InStr(sInpString, sDivider)
' выдернем строку с ФИО
sName = Left(sInpString, nCurrPos - 1)
NamesSpaces2Return sName
' из исходной строки удалим ФИО и разделитель
nCharCount = Len(sInpString) - nCurrPos
sInpString = Right(sInpString, nCharCount)
' третье поле - должность
' он стоит до первого разделителя
nCurrPos = InStr(sInpString, sDivider)
' выдернем строку с должностью
sDolznost = Left(sInpString, nCurrPos - 1)
' из исходной строки удалим должность и разделитель
nCharCount = Len(sInpString) - nCurrPos
sInpString = Right(sInpString, nCharCount)
' четвертое поле - отдел
' он стоит до первого разделителя
nCurrPos = InStr(sInpString, sDivider)
' выдернем строку с отделом
sOtdel = Left(sInpString, nCurrPos - 1)
' из исходной строки удалим отдел и разделитель
nCharCount = Len(sInpString) - nCurrPos
sInpString = Right(sInpString, nCharCount)
' все что осталось - это имя файла с фотографией
sFotoName = sInpString
End Sub
Private Sub AddFoto(sFotoName As String, FotoShape As Shape)
' импортирует фотку с именем файла sFotoName и размещает ее
Dim OldFoto As Shape
Dim NewFoto As Shape
Dim dX As Double, dY As Double, dWidth As Double, dHeight As Double
' получим размеры и положение старой фотки
FotoShape.GetBoundingBox dX, dY, dWidth, dHeight
' импортиреум фотку
ActiveLayer.Import (sFotoName)
Set NewFoto = ActiveSelectionRange(1)
' поставим ее на место
NewFoto.SetBoundingBox dX, dY, dWidth, dHeight, True
' поменяем разрешение картинки - проверка!!!!
NewFoto.Bitmap.Resample 0, 0, True, 300, 300
' удалим старую со страницы
FotoShape.Delete
End Sub
'расстановка фотографий и данных для пропусков ООО СК ддд
Public Sub zpxDDDIDCards()
'
' Recorded 8.06.2009
'
' Description:
'
' открытие и чтение файла данных
Const BasePath = "e:\Мои документы\ддд\пропуск 06.09\"
Const textFileName = BasePath & "Имена ддд.txt"
Const PhotoDir = "E:\Мои документы\ддд\пропуск 06.09\22mod\"
Const TextTabNum = "tabnum"
Const TextName = "name"
Const TextDolznost = "dolznost"
Const TextOtdel = "otdel"
Const TextFoto = "foto"
Dim fs, f, s
' Dim textFile As Textstream
Dim OrigSelection As ShapeRange
Dim BaseShape As Shape
Dim currPage As Page
Dim NewPageRange As ShapeRange
Dim sTabNum As String, sName As String, sDolznost As String, sOtdel As String, sFoto As String
Dim sCurrText As String
Set fs = CreateObject("Scripting.FileSystemObject")
Set textFile = fs.OpenTextFile(textFileName) ' , ForReading, False)
'ActivePage.Shapes.All.CreateSelection
'ActivePage.ActiveLayer.Shapes.All.Cut
Set OrigSelection = ActiveSelectionRange
If OrigSelection.count > 0 Then
ActiveDocument.BeginCommandGroup ("Пропуска на ддд")
' цикл чтения текстового файла
Do While textFile.AtEndOfStream <> True
sCurrText = textFile.ReadLine
ActiveDocument.AddPages (1)
OrigSelection.CopyToLayer ActivePage.ActiveLayer
AnalizeDDDString sCurrText, sTabNum, sName, sDolznost, sOtdel, sFoto
For Each BaseShape In ActiveLayer.SelectableShapes
' прочтем строку
' выбираем страницу
Select Case BaseShape.Name
Case TextTabNum
BaseShape.Text.Story = sTabNum
Case TextName
BaseShape.Text.Story = sName
Case TextDolznost
BaseShape.Text.Story = sDolznost
Case TextOtdel
BaseShape.Text.Story = sOtdel
Case TextFoto
AddFoto PhotoDir & sFoto, BaseShape
End Select
Next
Loop
ActiveDocument.EndCommandGroup
textFile.Close
End If
End Sub