работаем с параметрами и таблицами Word, используем прямые запросы к БД
пример - выпуск заявки на пропуска для участников маркетингового мероприятия (формат Word)
1. Готовим шаблон Word (за неимением возможности приложить файл - все на словах)
определяем ключевые поля - придумываем им псевдонимы - и макросом превращаем их в DOCPROPERTY
выглядит так где sPeriod, sCompany, fDol и т.д. не что иное как пользовательские DOCPROPERTY, можно использовать служебные поля - Вставка/Поле, можно сделать своих сколько нужно - ограничение - значение поля принимает по моему не более 1024 символов - так что для коротких записей вполне.
Сам макрос для преобразования текста в свойство
почитать - yandex.ru = "Формирование и регистрация стандартных документов Word"
макрос
Код: Выделить всё
Sub SetProperties()
Dim strName As String
Dim strVal As String
Dim strFld As String
Dim objDp As DocumentProperties
Dim blnFound As Boolean
Dim objTest As Object
Dim intAns As Integer
strName = Trim(Selection.Text)
strVal = strName
strName = InputBox("Value = " & strVal & Chr(13) & Chr(13) _
& "Enter Name, Please.", "Set Property", strName)
If strName <> Empty Then
blnFound = False
For Each objTest In ActiveDocument.CustomDocumentProperties
If objTest.Name = strName Then blnFound = True
Next
If blnFound Then
intAns = MsgBox("Name Already Exist", vbCritical)
Exit Sub
End If
Set objDp = ActiveDocument.CustomDocumentProperties
objDp.Add Name:=strName, LinkToContent:=False, _
Type:=msoPropertyTypeString, Value:=strVal
strFld = "DOCPROPERTY " & """" & strName & """"
With ActiveDocument.Content.Find
.ClearFormatting
Do While .Execute(FindText:=strVal, Forward:=True, _
Format:=True) = True
With .Parent
.Select
intAns = MsgBox("Replace " & """" & Selection _
& """" & Chr(13) & " With " _
& strFld, vbYesNo + vbQuestion)
If intAns = vbYes Then
Selection.Fields.Add Range:=Selection.Range, _
Type:=wdFieldEmpty, Text:= _
strFld, PreserveFormatting:=False
End If
.StartOf Unit:=wdWord, Extend:=wdMove
.Move Unit:=wdWord, Count:=1
End With
Loop
End With
Else
Exit Sub
End If
End Sub
И второе - используем таблицы, как для табличных данных - список, так и для подписей
оч. удобно
после оформления документа - удаляем макрос.
в итоге шаблон имеет нужные поля, пустые таблицы, колонтитулы - в общем все оформление
2. Работаем с шаблоном из VBScript
Код: Выделить всё
Sub Print_Access()
'------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Dim Path,WordApp, DocWrd
Dim sql, Arr, i , j
Dim Check, id_aObject, sCompany, sManager, fManager,sDol, fCompany, fDol
Dim sCompany_id, sManager_id, Filial_str
Dim d_Begin_atr, d_End_atr
'прочтем данные из Лоции
id_aObject=LsVars.GetVarValue("id_aObject")
Check=LsVars.GetVarValue("Check")
Path= "...Заявка на посетителей.doc"
'прочтем данные из БД
If DataBase.ADODB_Connected Then ' если подключиться удалось работаем иначе нет
If DataBase.ADODB_RecordSet Then ' если удалось создать recordset тоже работаем
'прочтем данные по мероприятию
sql = "select * from LSDBO.Ric_Get_aAttrib(" & CStr(id_aObject) & ")order by IdTypeAttr"
rs.Open sql, cn
d_Begin_atr = database.getDataFromRs(8, cDateTime) ' d_Begin_atr
d_End_atr = database.getDataFromRs(9, cDateTime) ' d_End_atr
fManager = database.getDataFromRs(3000000000122, cString) ' fManager
Filial_str = database.getDataFromRs(100004086200000, cString) ' Filial_str
sCompany_id = database.getDataFromRs(100004087100000, cNumeric) ' sCompany_id
sManager_id= database.getDataFromRs(100004087200000, cNumeric) ' sManager_id
rs.Close
sCompany=DataBase.GetSingleData("Select LSDBO.Ric_Get_CompanyName(" & cStr(sCompany_id) & ")") ' наименование принимающей компании
sManager=DataBase.GetSingleData("Select LSDBO.Ric_Get_String_atr(" & cStr(sManager_id) & ",3000000000121)") ' наименование контактного лица принимающей стороны
sDol=DataBase.GetSingleData("Select LSDBO.Ric_Get_String_atr(" & cStr(sManager_id) & ",3000000000086)") ' должность контактного лица принимающей стороны
i=DataBase.GetSingleData("select cid from LSDBO.Ric_Get_Filials() where name='" & Filial_str & "'") ' id КОМПАНИИ филиала инициирующей стороны
fCompany=DataBase.GetSingleData("Select LSDBO.Ric_Get_CompanyName(" & cStr(i) & ")") ' наименование инициирующей компании
i=DataBase.GetSingleData("select sid from LSDBO.Ric_Get_Filials() where name='" & Filial_str & "'") ' id ПРЕДСТАВИЛЬСТВА филиала инициирующей стороны
i=DataBase.GetSingleData("select id from lsdbo.ric_get_chUsers(" & cStr(i) & ") where ffio='" & fManager & "'") ' id Менеджера ответственного за Мероприятие
fDol=DataBase.GetSingleData("Select LSDBO.Ric_Get_String_atr(" & cStr(i) & ",3000000000086)") ' должность контактного лица инициирующей стороны
'прочтем данные по участникам докладчикам
select case check
case 1 ' докладчики и участники
sql = "SELECT rw.description, vv1.value, vv2.value FROM lsdbo.object_reference rw left join lsdbo.object_type tw on rw.type_id=tw.id left join lsdbo.attrib_value av1 on rw.id=av1.object_id and av1.attrib_id=3000000000086 left join lsdbo.value_string vv1 on av1.value_id=vv1.id and av1.attrib_id=3000000000086 left join lsdbo.attrib_value av2 on rw.id=av2.object_id and av2.attrib_id=100004068400000 left join lsdbo.value_string vv2 on av2.value_id=vv2.id and av2.attrib_id=100004068400000 where rw.id in (select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Стки,Стк') union all select id from LSDBO.Ric_Get_objChild("+cStr(id_aObject)+",'Lsts,Lst')) order by rw.description"
case 2 ' докладчики
sql = "SELECT ..."
case 0 ' участники
sql = "SELECT ..."
end select
rs.Open sql, cn
Arr = rs.GetRows '(Rows, Start, Fields)
rs.Close
Set cn = Nothing 'убить объект соединения с базой
End if
End If
'сформируем Word
set WordApp=CreateObject("Word.Application")
set DocWrd= WordApp.Documents.Open(Path)
' WordApp.Visible=True 'сделать Word видимым
With DocWrd 'заполним таблицу 1 данными
If UBound(Arr, 2) > 0 Then 'расширим таблицу если нужно
.Tables(1).Rows(2).Select
WordApp.Selection.InsertRowsBelow (UBound(Arr, 2) )
End If
For i = LBound(Arr, 2) To UBound(Arr, 2)
.Tables(1).Cell(i + 2, 1).Range.InsertAfter i + 1
For j = 0 To 2
.Tables(1).Cell(i + 2, j + 2).Range.Text = Arr(j, i) 'InsertAfter Arr(j, i)
Next
Next
.CustomDocumentProperties("sType").Value = "" ' тип семинара
.CustomDocumentProperties("sName").Value = "" ' наименование семинара
.CustomDocumentProperties("sPeriod").Value = "с " & FormatDateTime(d_Begin_atr,4) & " (" & FormatDateTime(d_Begin_atr,2) & ")" & " по " & FormatDateTime(d_End_atr,4) & " (" & FormatDateTime(d_End_atr,2) & ")" & " г." ' период проведения семинара
.CustomDocumentProperties("sCompany").Value = sCompany ' компания где проводится семинар
.CustomDocumentProperties("sManager").Value = sManager ' представитель компании где проводится семинар
.CustomDocumentProperties("sDol").Value = "Руководителю службы безопасности" ' должность представителя компании где проводится семинар
.CustomDocumentProperties("fCompany").Value = fCompany ' компания проводящая семинар
.CustomDocumentProperties("fManager").Value = RegExp.GetShortFIO(fManager) ' представитель компании проводящей семинар
.CustomDocumentProperties("fDol").Value = fDol ' должность представителя компании проводящей семинар
.Fields.Update
End With
Erase Arr
WordApp.Visible=True 'сделать Word видимым
'отключимся от Word (очистим память) (убъем обекты)
if Not DocWrd Is Nothing Then Set DocWrd= Nothing
if Not WordApp Is Nothing Then Set WordApp = Nothing
End Sub
Интересных эффектов можно добиться в комбинации использования COM Excel+Word где на основе данных собранных из БД формируется файл Excel настроенный на вычисление некоторых результатов и формирующий некоторые итоговые таблицы (все макросы запускаются удаленно из VBScript) после чего данные из этих таблиц просто вставляются в Word а Excel убивается...
в общем все что угодно, на сколько хватает фантазии.
ps
имена таблиц шаблона - можно посмотреть при отладке скрипта например из VBA Excel