Пробежка по коллекции документов с возможностью использования Type total для формирования массива содержащего в себе значения lable, value, value_percent. Удобно для использования в сортировке коллекции документов по выбранному ключу (полю)
[Declarations]
Type total
lable As String
value As Double
value_percent As Double
End Type
[Sub/Function]
dim suf
suf = "_1"
Dim doc As NotesDocument
Dim progolos As NotesItem
Dim proc As NotesItem
Dim a As Integer
Dim progolos As String, proc As String, progolos_val As Variant, proc_val As Variant
progolos = "progolos_" & suf
proc= "proc_" & suf
Set doc = coll.GetFirstDocument
Do While Not(doc Is Nothing)
Set progolos = doc.GetFirstItem(progolos_izbiratel)
Set proc = doc.GetFirstItem(proc_izbiratel)
If ( progolos Is Nothing ) Then
progolos_val = ""
Else
progolos_val = progolos.values(0)
End If
If ( proc Is Nothing ) Then
proc_val = ""
Else
proc_val = proc.values(0)
End If
ReDim Preserve array(a%) As total_progolos
array(a%).lable = doc.n_kom(0)
array(a%).value = progolos_val
array(a%).value_percent = proc_val
Set doc = coll.GetNextDocument(doc)
a% = a% + 1
Loop
Показаны сообщения с ярлыком lotus script. Показать все сообщения
Показаны сообщения с ярлыком lotus script. Показать все сообщения
26 октября 2010 г.
16 марта 2010 г.
Снова о документе подключения
Снова возникла задача массово подрихтовать документы подключения у пользователей, убрать лишнее, посидев вечерочком....подумав ...попечатав ... вот что получилось
Sub create_connect
On Error Goto errmes
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim strErrMessage,connect,dserver
Dim s As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim coll As NotesDocumentCollection
Dim doc As NotesDocument
Dim coldoc As NotesDocument
Set db = s.GetDatabase("","names.nsf")
Set view = db.GetView("Connections")
'*****************************
connect = "server/domain"
'*****************************
Set coll = view.Getalldocumentsbykey(connect)
Stop
If coll.Count > 1 Then
'если в коллекции найдены несколько документов, то проверить у них интернет-хост
'если он не удовлетворяет условию, удалить документы не удовлетворяющие условию
Set doc = coll.Getfirstdocument
While Not(doc Is nothing)
If doc.Destination(0) = "CN=server/O=domain" Then
If Not (doc.OptionalNetworkAddress(0) = "server_inet_host") Then
Call doc.Removepermanently(True)
Call ws.Viewrefresh()
End If
End If
Set doc = coll.Getnextdocument(doc)
Wend
'если в коллекции найден один документ, то проверить у него интернет-хост
'и если он не удовлетворяет условию, то переписать значение на нужное
ElseIf coll.Count = 1 Then
Set doc = coll.Getfirstdocument
If Not doc.OptionalNetworkAddress(0) = "server_inet_host" Then
Call doc.ReplaceItemValue("OptionalNetworkAddress", "server_inet_host")
Call doc.ReplaceItemValue("PhoneNumber", "server_inet_host")
Call doc.Save(True,False)
End If
'если нет документа, то создать заново
ElseIf coll.Count = 0 Then
Set uidoc = ws.ComposeDocument( "", db.filename, "local" )
Call uidoc.FieldsetText("Destination","CN=server/O=domain")
Call uidoc.FieldsetText("OptionalNetworkAddress","server_inet_host")
Call uidoc.FieldsetText("PhoneNumber","server_inet_host")
Call uidoc.FieldsetText("PortName","TCPIP")
Call uidoc.FieldsetText("LanPortName","TCPIP")
Call uidoc.Save
Call uidoc.Close
Print "Документ подключения " & connect &" cоздан"
End if
'сообщение об ошибке
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End sub
Sub create_connect
On Error Goto errmes
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Dim strErrMessage,connect,dserver
Dim s As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim coll As NotesDocumentCollection
Dim doc As NotesDocument
Dim coldoc As NotesDocument
Set db = s.GetDatabase("","names.nsf")
Set view = db.GetView("Connections")
'*****************************
connect = "server/domain"
'*****************************
Set coll = view.Getalldocumentsbykey(connect)
Stop
If coll.Count > 1 Then
'если в коллекции найдены несколько документов, то проверить у них интернет-хост
'если он не удовлетворяет условию, удалить документы не удовлетворяющие условию
Set doc = coll.Getfirstdocument
While Not(doc Is nothing)
If doc.Destination(0) = "CN=server/O=domain" Then
If Not (doc.OptionalNetworkAddress(0) = "server_inet_host") Then
Call doc.Removepermanently(True)
Call ws.Viewrefresh()
End If
End If
Set doc = coll.Getnextdocument(doc)
Wend
'если в коллекции найден один документ, то проверить у него интернет-хост
'и если он не удовлетворяет условию, то переписать значение на нужное
ElseIf coll.Count = 1 Then
Set doc = coll.Getfirstdocument
If Not doc.OptionalNetworkAddress(0) = "server_inet_host" Then
Call doc.ReplaceItemValue("OptionalNetworkAddress", "server_inet_host")
Call doc.ReplaceItemValue("PhoneNumber", "server_inet_host")
Call doc.Save(True,False)
End If
'если нет документа, то создать заново
ElseIf coll.Count = 0 Then
Set uidoc = ws.ComposeDocument( "", db.filename, "local" )
Call uidoc.FieldsetText("Destination","CN=server/O=domain")
Call uidoc.FieldsetText("OptionalNetworkAddress","server_inet_host")
Call uidoc.FieldsetText("PhoneNumber","server_inet_host")
Call uidoc.FieldsetText("PortName","TCPIP")
Call uidoc.FieldsetText("LanPortName","TCPIP")
Call uidoc.Save
Call uidoc.Close
Print "Документ подключения " & connect &" cоздан"
End if
'сообщение об ошибке
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End sub
9 марта 2010 г.
Работа со "stubs" (окурками, удаленных документов)
На днях... решая очередную задачу по db.search, столкнулся ,по началу,с непонятной вещью, а именно, в отчет лезут удаленные документы. Непорядок... нужно избавляться, и занялся я борьбой с последствиями курения - окурками.
Option Public
Option Declare
Dim strErrMessage
Const wAPIModule = "NNOTES"
Declare Private Sub IDDestroyTable Lib wAPIModule Alias "IDDestroyTable" _
( ByVal hT As Long)
Declare Private Function IDScan Lib wAPIModule Alias "IDScan" _
( ByVal hT As Long, ByVal F As Integer, ID As Long) As Integer
Declare Private Function NSFDbOpen Lib wAPIModule Alias "NSFDbOpen" _
( ByVal P As String, hDB As Long) As Integer
Declare Private Function NSFDbClose Lib wAPIModule Alias "NSFDbClose" _
( ByVal hDB As Long) As Integer
Declare Private Function NSFDbGetModifiedNoteTable Lib wAPIModule Alias "NSFDbGetModifiedNoteTable" _
( ByVal hDB As Long, ByVal C As Integer, ByVal S As Currency, U As Currency, hT As Long) As Integer
Declare Private Function NSFNoteDelete Lib wAPIModule Alias "NSFNoteDelete" _
( ByVal hDB As Long, ByVal N As Long, ByVal F As Integer) As Integer
Declare Private Function OSPathNetConstruct Lib wAPIModule Alias "OSPathNetConstruct" _
( ByVal NullPort As Long, ByVal Server As String, ByVal FIle As String, ByVal PathNet As String) As Integer
Declare Private Sub TimeConstant Lib wAPIModule Alias "TimeConstant" _
( ByVal C As Integer, T As Currency)
Dim Db As NotesDatabase
Sub countAndDeleteStubs(db As NotesDatabase, choice As Integer)
On Error GoTo errmes
Dim ever As Currency, last As Currency
Dim hT As Long, RRV As Long, hDB As Long
Dim n&,done,np$
With db
np$ = Space(1024)
OSPathNetConstruct 0, db.Server, db.FilePath, np$
End With
NSFDbOpen np$, hDB
TimeConstant 2, ever
NSFDbGetModifiedNoteTable hDB, &H7FFF, ever, last, hT
n& = 0
done = (IDScan(hT, True, RRV) = 0)
While Not done
If RRV < 0 Then
If (choice = 1) Then
NSFNoteDelete hDB, RRV And &H7FFFFFFF, &H0201
End If
n& = n& + 1
End If
done = (IDScan(hT, False, RRV) = 0)
Wend
IDDestroyTable hT
NSFDbClose hDB
If (choice = 1) Then
print "Удалено " & CStr(n&) & " окурков в базе данных " & db.FilePath & " на сервере " & db.Server
Else
print "В базе данных " & db.FilePath & " на сервере " & db.Server & " найдено " & CStr(n&) & " окурков"
End If
Exit sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & GetThreadInfo(10) &" текущая процедура " & GetThreadInfo(1) & ", в строке " & CStr(Erl)
Print strErrMessage
End Sub
Sub findstubs
'поиск окурков
On Error GoTo errmes
Dim Session As New NotesSession
Dim ws As New NotesUIWorkspace
Dim dbInfo As Variant
Dim sDbServer As String
Dim sDbPath As String
Dim retVal As Integer
Set db = session.Currentdatabase
retVal = ws.Prompt (PROMPT_YESNOCANCEL,"Удалить ""Окурки""?","Удалить все [да] или показать их число [Нет]")
Select Case retVal
Case 1 : Call countAndDeleteStubs(db, 1)
Case 0 : Call countAndDeleteStubs(db, 0)
Case -1 : print "Отменено"
End Select
Print "Процедура сжатия базы данных..."
Call db.Compact
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End Sub
Option Public
Option Declare
Dim strErrMessage
Const wAPIModule = "NNOTES"
Declare Private Sub IDDestroyTable Lib wAPIModule Alias "IDDestroyTable" _
( ByVal hT As Long)
Declare Private Function IDScan Lib wAPIModule Alias "IDScan" _
( ByVal hT As Long, ByVal F As Integer, ID As Long) As Integer
Declare Private Function NSFDbOpen Lib wAPIModule Alias "NSFDbOpen" _
( ByVal P As String, hDB As Long) As Integer
Declare Private Function NSFDbClose Lib wAPIModule Alias "NSFDbClose" _
( ByVal hDB As Long) As Integer
Declare Private Function NSFDbGetModifiedNoteTable Lib wAPIModule Alias "NSFDbGetModifiedNoteTable" _
( ByVal hDB As Long, ByVal C As Integer, ByVal S As Currency, U As Currency, hT As Long) As Integer
Declare Private Function NSFNoteDelete Lib wAPIModule Alias "NSFNoteDelete" _
( ByVal hDB As Long, ByVal N As Long, ByVal F As Integer) As Integer
Declare Private Function OSPathNetConstruct Lib wAPIModule Alias "OSPathNetConstruct" _
( ByVal NullPort As Long, ByVal Server As String, ByVal FIle As String, ByVal PathNet As String) As Integer
Declare Private Sub TimeConstant Lib wAPIModule Alias "TimeConstant" _
( ByVal C As Integer, T As Currency)
Dim Db As NotesDatabase
Sub countAndDeleteStubs(db As NotesDatabase, choice As Integer)
On Error GoTo errmes
Dim ever As Currency, last As Currency
Dim hT As Long, RRV As Long, hDB As Long
Dim n&,done,np$
With db
np$ = Space(1024)
OSPathNetConstruct 0, db.Server, db.FilePath, np$
End With
NSFDbOpen np$, hDB
TimeConstant 2, ever
NSFDbGetModifiedNoteTable hDB, &H7FFF, ever, last, hT
n& = 0
done = (IDScan(hT, True, RRV) = 0)
While Not done
If RRV < 0 Then
If (choice = 1) Then
NSFNoteDelete hDB, RRV And &H7FFFFFFF, &H0201
End If
n& = n& + 1
End If
done = (IDScan(hT, False, RRV) = 0)
Wend
IDDestroyTable hT
NSFDbClose hDB
If (choice = 1) Then
print "Удалено " & CStr(n&) & " окурков в базе данных " & db.FilePath & " на сервере " & db.Server
Else
print "В базе данных " & db.FilePath & " на сервере " & db.Server & " найдено " & CStr(n&) & " окурков"
End If
Exit sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & GetThreadInfo(10) &" текущая процедура " & GetThreadInfo(1) & ", в строке " & CStr(Erl)
Print strErrMessage
End Sub
Sub findstubs
'поиск окурков
On Error GoTo errmes
Dim Session As New NotesSession
Dim ws As New NotesUIWorkspace
Dim dbInfo As Variant
Dim sDbServer As String
Dim sDbPath As String
Dim retVal As Integer
Set db = session.Currentdatabase
retVal = ws.Prompt (PROMPT_YESNOCANCEL,"Удалить ""Окурки""?","Удалить все [да] или показать их число [Нет]")
Select Case retVal
Case 1 : Call countAndDeleteStubs(db, 1)
Case 0 : Call countAndDeleteStubs(db, 0)
Case -1 : print "Отменено"
End Select
Print "Процедура сжатия базы данных..."
Call db.Compact
Exit Sub
errmes:
strErrMessage = "Ошибка " & Error$ & " выполняемая процедура " & Getthreadinfo(10) &" текущая процедура " & Getthreadinfo(1) & ", в строке " & Cstr(Erl)
Print strErrMessage
End Sub
3 марта 2010 г.
ProgressBar
На днях, решил приукрасить подготовку отчетов "прогрессом"
Особенность от стандартного использования - это, конвертация ascii в читабельный вид
Вот что получилось
'функции преобразования строк
Const OS_TRANSLATE_NATIVE_TO_LMBCS = 0 'Translate platform-specific to LMBCS */
Const OS_TRANSLATE_LMBCS_TO_NATIVE = 1 'Translate LMBCS to platform-specific */
Const OS_TRANSLATE_LOWER_TO_UPPER = 3 'current int'l case table */
Const OS_TRANSLATE_UPPER_TO_LOWER = 4 'current int'l case table */
Const OS_TRANSLATE_UNACCENT = 5 'int'l unaccenting table */
Const OS_TRANSLATE_LMBCS_TO_ASCII_DOS = 11
Const OS_TRANSLATE_LMBCS_TO_ASCII = 13
Declare Sub OSTranslate Lib "nnotes.dll" Alias "OSTranslate"( ByVal mode As Integer, ByVal strIn As String, ByVal lenIn As Integer, ByVal strOut As String, ByVal lenOut As Integer )
Declare Function NEMProgressBegin Lib "nnotesws.dll" ( ByVal wFlags As Integer ) As Long
Declare Sub NEMProgressEnd Lib "nnotesws.dll" ( ByVal hwnd As Long )
Declare Sub NEMProgressSetBarPos Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal dwPos As Long)
Declare Sub NEMProgressSetBarRange Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal dwMax As Long )
Declare Sub NEMProgressSetText Lib "nnotesws.dll" ( ByVal hwnd As Long, ByVal pcszLine1 As String, _
ByVal pcszLine2 As String )
Const NPB_TWOLINE% = 1
Class ProgressBar
Private hwnd As Long
Sub New (BarRange As Long)
On Error GoTo ErrorHandler
Me.hwnd = NEMProgressBegin (NPB_TWOLINE)
Call NEMProgressSetBarRange (Me.hwnd, BarRange)
Exit Sub
ErrorHandler:
strErrMessage_rep = "Ошибка " & Error$ & " выполняемая процедура " & GetThreadInfo(10) &" текущая процедура " & GetThreadInfo(1) & ", в строке " & CStr(Erl)
Print strErrMessage_rep
End Sub
Код как использовать
Dim s As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim server
Dim view_adr As NotesView
Set db = s.Currentdatabase
If Not ( db.IsFTIndexed ) Then
Call db.UpdateFTIndex( True )
End If
If ( db.LastModified > db.LastFTIndexed ) Then
Call db.UpdateFTIndex( True )
End If
Set view_adr = db.GetView("view_object")
Dim i As Long
Set doc = view_adr.Getfirstdocument()
a = view_adr.Allentries.Count
Dim RefreshProgress As New ProgressBar (view_adr.Allentries.Count) 'отображение рогрес-бара
Dim BarMsg As String
Dim UpdMsg As String
Let BMsg = "Обработка окументов..."
Let tmp0=Len(BMsg)
Let tmp1=Len(BMsg)*2
Let BarMsg = Space(Len(BMsg)*2)
Call OSTranslate( OS_TRANSLATE_NATIVE_TO_LMBCS, BMsg, tmp0, BarMsg, tmp1 )
For i = 1 To a
Call plan_nachislenie(doc)
Call RefreshProgress.UpdatePosition (i)
Let ascii = doc.address(0)
Let tmp0=Len(ascii)
Let tmp1=Len(ascii)*2
Let UpdMsg = Space(Len(ascii)*2)
Call OSTranslate( OS_TRANSLATE_NATIVE_TO_LMBCS, ascii, tmp0, UpdMsg, tmp1 )
Call RefreshProgress.UpdateProgressText(BarMsg, UpdMsg)
Set doc = view_adr.GetNextdocument(doc)
Next
Print "Готово"
3 февраля 2010 г.
Просмотр элементов дизайна
В представлении создаем кнопу которая заменяет значение в поле $FormulaClass
Dim w As NotesUIWorkspace
Dim uiview As NotesUIView
Dim view As NotesView
Dim unid As String
Dim s As NotesSession
Dim db As NotesDatabase
Dim note As NotesDocument
Set w = New NotesUIWorkspace
Set uiview = w.CurrentView
Set view = uiview.View
Let unid = view.UniversalID
Set s = New NotesSession
Set db = s.CurrentDatabase
Set note = db.GetDocumentByUNID (unid)
Call note.ReplaceItemValue ("$FormulaClass", "2")
Call note.Save (True, True)
Этим самым мы можем видеть элементы дизайна!
Список значений которые может принимать это поле (поддерживает множественные значения ( 4+128+256 = 388 ))
Value Design Elements Shown
1 - Documents
2 - Unknown
4 - Forms and Subforms
8 - Views, Folders and Navigators
16 - Database Title
32 - Design Collection (overall information)
64 - ACL Note (in compiled format)
128 - Unknown
256 - Unknown
512 - Agents (Shared)
1024 - Shared Fields
1548 - Forms, Sub-forms, Views, Folders, Navigators, Agents (Shared), Shared Fields
Dim w As NotesUIWorkspace
Dim uiview As NotesUIView
Dim view As NotesView
Dim unid As String
Dim s As NotesSession
Dim db As NotesDatabase
Dim note As NotesDocument
Set w = New NotesUIWorkspace
Set uiview = w.CurrentView
Set view = uiview.View
Let unid = view.UniversalID
Set s = New NotesSession
Set db = s.CurrentDatabase
Set note = db.GetDocumentByUNID (unid)
Call note.ReplaceItemValue ("$FormulaClass", "2")
Call note.Save (True, True)
Этим самым мы можем видеть элементы дизайна!
Список значений которые может принимать это поле (поддерживает множественные значения ( 4+128+256 = 388 ))
Value Design Elements Shown
1 - Documents
2 - Unknown
4 - Forms and Subforms
8 - Views, Folders and Navigators
16 - Database Title
32 - Design Collection (overall information)
64 - ACL Note (in compiled format)
128 - Unknown
256 - Unknown
512 - Agents (Shared)
1024 - Shared Fields
1548 - Forms, Sub-forms, Views, Folders, Navigators, Agents (Shared), Shared Fields
Создание документа Location
Иногда требуется создать документ подключения к серверу не находясь за компьютером пользователя. Данный скрипт позволит автоматизировать данный процесс. Эту процедуру в последствии можно использовать как функцию
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim allnabs As Variant
allnabs=session.addressbooks
Forall books In allnabs
If books.isprivateaddressbook Then
If Not(Books.isopen) Then
Call Books.open("",books.filename)
Set db = books
End If
End If
End Forall
Set view = db.GetView("Connections")
connect = "имя сервера подключения"
Set doc = view.GetDocumentByKey(connect)
If Not doc Is Nothing Then
Print "Документ подключения " & connect &" уже есть"
Else
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = ws.ComposeDocument( "", db.filename, "local" )
Call uidoc.FieldsetText("Destination","notes-имя сервера подключения")
Call uidoc.FieldsetText("OptionalNetworkAddress","dns-имя сервера подключения")
Call uidoc.FieldsetText("PortName","TCPIP")
Call uidoc.FieldsetText("LanPortName","TCPIP")
Call uidoc.Save
Call uidoc.Close
Print "Документ подключения " & connect &" cоздан"
End If
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Dim allnabs As Variant
allnabs=session.addressbooks
Forall books In allnabs
If books.isprivateaddressbook Then
If Not(Books.isopen) Then
Call Books.open("",books.filename)
Set db = books
End If
End If
End Forall
Set view = db.GetView("Connections")
connect = "имя сервера подключения"
Set doc = view.GetDocumentByKey(connect)
If Not doc Is Nothing Then
Print "Документ подключения " & connect &" уже есть"
Else
Dim ws As New NotesUIWorkspace
Dim uidoc As NotesUIDocument
Set uidoc = ws.ComposeDocument( "", db.filename, "local" )
Call uidoc.FieldsetText("Destination","notes-имя сервера подключения")
Call uidoc.FieldsetText("OptionalNetworkAddress","dns-имя сервера подключения")
Call uidoc.FieldsetText("PortName","TCPIP")
Call uidoc.FieldsetText("LanPortName","TCPIP")
Call uidoc.Save
Call uidoc.Close
Print "Документ подключения " & connect &" cоздан"
End If
Импорт значений документов в таблицу Rt поля
Действие вешается в представлении для импорта файла Excel в Lotus
Значения из документов представления "body_f2" из примера импортируются в сгенерированную скриптом табличку, где колличество вкладок вычисляется динамически, в зависимости от количества документов в представлении,а использование стиля позволяем изменять размеры колонок
Sub Click(Source As Button)
Dim val_List( 1 To 200 ) As Variant ' колличество шагов исполнеия цыкла
Dim current_val As Variant
counter% = 1
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
REM Create document with Body rich text item
Dim doc As New NotesDocument(db)
Dim view_doc As NotesDocument
Call doc.ReplaceItemValue("Form", "body_rt_f2") ' название формы отчета по этой форме (в ней же содержится RT поле в котором создается таблица со вкладками)
Dim body As New NotesRichTextItem(doc, "body_rt")
Set view = db.GetView("body_f2")
REM Create table in Body item
rowCount% = 16 'колличество строк в таблице каждой из вкладок
columnCount% = 7 'колличество столбцов в таблице каждой из вкладок
a = view.EntryCount ' число документов в представлении (строки)
'c = a+12
'b = Fix(c/rowCount%) ' число вкладок
b = Fix(a/rowCount%) ' число вкладок
b1 = Fix(a/rowCount%) ' число вкладок
b2 = a/rowCount%
If b1< b2 Then b=b1 +1
Dim tabs() As String
If Messagebox("Продолжить создание таблицы?", _
MB_YESNO + MB_ICONQUESTION, "Tabbed?") = IDNO Then
Call body.AppendTable(b, 1)
Else
Redim tabs(1 To b)
For i = 1 To b
tabs(i) = "Стр № " & i
Next
Call body.AppendTable(b, 1, tabs) 'создание таблицы с вкладками
End If
REM Populate table
Dim rtnav As NotesRichTextNavigator
Set rtnav = body.CreateNavigator
Call rtnav.FindFirstElement(RTELEM_TYPE_TABLE)'
Set view_doc = view.GetFirstDocument
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL) 'поиск ячейки в 1 вкладке
' вставка таблицы 7х15
'****************************************** стиль оформления
Dim columnStyles1(0 To 6) As NotesRichTextParagraphStyle
For i = 0 To 6
Set columnStyles1(i) = session.CreateRichTextParagraphStyle
columnStyles1(i).LeftMargin = 0 ' position relative to cell border.
columnStyles1(i).FirstLineLeftMargin = 0
Next
columnStyles1(0).RightMargin = 4.5 * RULER_ONE_CENTIMETER
columnStyles1(0).Alignment = ALIGN_CENTER
columnStyles1(1).RightMargin = 17. * RULER_ONE_CENTIMETER
columnStyles1(1).Alignment = ALIGN_LEFT
columnStyles1(2).RightMargin = 2. * RULER_ONE_CENTIMETER
columnStyles1(2).Alignment = ALIGN_CENTER
columnStyles1(3).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(3).Alignment = ALIGN_CENTER
columnStyles1(4).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(4).Alignment = ALIGN_CENTER
columnStyles1(5).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(5).Alignment = ALIGN_CENTER
columnStyles1(6).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(6).Alignment = ALIGN_CENTER
'*********************************************
For ib = 1 To b Step 1
Call body.BeginInsert(rtnav)
Call body.AppendTable(rowCount%, columnCount%,,,columnStyles1)
'Call body.AppendTable(16, 7,,,columnStyles1)
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL) 'поиск ячейки во вложенной таблице 1 вкладки
For iRow% = 1 To rowCount% Step 1
If view_doc.Size = 0 Goto savedoc
On Error Goto savedoc
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 0 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 1 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 2 ))
'On Error=19 Goto savedoc
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 3 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 4 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 5 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Dim v6 As String
v6$ = Left$(view_doc.ColumnValues( 6 ), 6)
Call body.AppendText(v6$)
val_List( counter% ) = current_val
Set view_doc = view.GetNextDocument( view_doc )
counter% = counter% + 1
Call body.EndInsert
If current_val > a Goto savedoc
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Next
Next
'Exit Sub
savedoc:
REM Save document and refresh view
Call doc.Save(True, False)
Dim ws As New NotesUIWorkspace
Call ws.ViewRefresh
Exit Sub
End Sub
Значения из документов представления "body_f2" из примера импортируются в сгенерированную скриптом табличку, где колличество вкладок вычисляется динамически, в зависимости от количества документов в представлении,а использование стиля позволяем изменять размеры колонок
Sub Click(Source As Button)
Dim val_List( 1 To 200 ) As Variant ' колличество шагов исполнеия цыкла
Dim current_val As Variant
counter% = 1
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
REM Create document with Body rich text item
Dim doc As New NotesDocument(db)
Dim view_doc As NotesDocument
Call doc.ReplaceItemValue("Form", "body_rt_f2") ' название формы отчета по этой форме (в ней же содержится RT поле в котором создается таблица со вкладками)
Dim body As New NotesRichTextItem(doc, "body_rt")
Set view = db.GetView("body_f2")
REM Create table in Body item
rowCount% = 16 'колличество строк в таблице каждой из вкладок
columnCount% = 7 'колличество столбцов в таблице каждой из вкладок
a = view.EntryCount ' число документов в представлении (строки)
'c = a+12
'b = Fix(c/rowCount%) ' число вкладок
b = Fix(a/rowCount%) ' число вкладок
b1 = Fix(a/rowCount%) ' число вкладок
b2 = a/rowCount%
If b1< b2 Then b=b1 +1
Dim tabs() As String
If Messagebox("Продолжить создание таблицы?", _
MB_YESNO + MB_ICONQUESTION, "Tabbed?") = IDNO Then
Call body.AppendTable(b, 1)
Else
Redim tabs(1 To b)
For i = 1 To b
tabs(i) = "Стр № " & i
Next
Call body.AppendTable(b, 1, tabs) 'создание таблицы с вкладками
End If
REM Populate table
Dim rtnav As NotesRichTextNavigator
Set rtnav = body.CreateNavigator
Call rtnav.FindFirstElement(RTELEM_TYPE_TABLE)'
Set view_doc = view.GetFirstDocument
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL) 'поиск ячейки в 1 вкладке
' вставка таблицы 7х15
'****************************************** стиль оформления
Dim columnStyles1(0 To 6) As NotesRichTextParagraphStyle
For i = 0 To 6
Set columnStyles1(i) = session.CreateRichTextParagraphStyle
columnStyles1(i).LeftMargin = 0 ' position relative to cell border.
columnStyles1(i).FirstLineLeftMargin = 0
Next
columnStyles1(0).RightMargin = 4.5 * RULER_ONE_CENTIMETER
columnStyles1(0).Alignment = ALIGN_CENTER
columnStyles1(1).RightMargin = 17. * RULER_ONE_CENTIMETER
columnStyles1(1).Alignment = ALIGN_LEFT
columnStyles1(2).RightMargin = 2. * RULER_ONE_CENTIMETER
columnStyles1(2).Alignment = ALIGN_CENTER
columnStyles1(3).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(3).Alignment = ALIGN_CENTER
columnStyles1(4).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(4).Alignment = ALIGN_CENTER
columnStyles1(5).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(5).Alignment = ALIGN_CENTER
columnStyles1(6).RightMargin = 1.5 * RULER_ONE_CENTIMETER
columnStyles1(6).Alignment = ALIGN_CENTER
'*********************************************
For ib = 1 To b Step 1
Call body.BeginInsert(rtnav)
Call body.AppendTable(rowCount%, columnCount%,,,columnStyles1)
'Call body.AppendTable(16, 7,,,columnStyles1)
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL) 'поиск ячейки во вложенной таблице 1 вкладки
For iRow% = 1 To rowCount% Step 1
If view_doc.Size = 0 Goto savedoc
On Error Goto savedoc
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 0 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 1 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 2 ))
'On Error=19 Goto savedoc
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 3 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 4 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Call body.AppendText(view_doc.ColumnValues( 5 ))
Call body.EndInsert
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Call body.BeginInsert(rtnav)
Dim v6 As String
v6$ = Left$(view_doc.ColumnValues( 6 ), 6)
Call body.AppendText(v6$)
val_List( counter% ) = current_val
Set view_doc = view.GetNextDocument( view_doc )
counter% = counter% + 1
Call body.EndInsert
If current_val > a Goto savedoc
Call rtnav.FindNextElement(RTELEM_TYPE_TABLECELL)
Next
Next
'Exit Sub
savedoc:
REM Save document and refresh view
Call doc.Save(True, False)
Dim ws As New NotesUIWorkspace
Call ws.ViewRefresh
Exit Sub
End Sub
Перевод атачмента из одного поля в другое
Вот небольшой примерчик кнопки на форме
которая переводит атачмент в одном поле (Info) в embeded object в другое поле (embed)
Sub Click(Source As Button)
Dim workspace As New NotesUIWorkspace
Dim doc As NotesUIDocument
Dim rtitemA As NotesRichTextItem
Dim info As NotesRichTextItem
Set doc = workspace.CurrentDocument 'текущий документ
If Not doc.Document.HasEmbedded Then Exit Sub
Set rtitemA = doc.Document.GetFirstItem("info") ' поле где лежит атачмент
REM Сохраняем аттачи на диск
Forall att In rtitemA.EmbeddedObjects
If att.Type = EMBED_ATTACHMENT Then
filepath$ = "C:\temp\" & att.Source
Call att.ExtractFile(filepath$) ' сохранение файлов в "C:\temp\"
Call doc.GotoField("embed")
Call doc.Import("Microsoft Word",filepath$) ' создание (импорт) объекта Word
Kill filepath$ ' удаление фалов из дирректории "C:\temp\"
End If
End Forall
Call doc.FieldClear("Info") ' очищение поля "Info"
Call rtitemA.Update ' обновление поля
End Sub
которая переводит атачмент в одном поле (Info) в embeded object в другое поле (embed)
Sub Click(Source As Button)
Dim workspace As New NotesUIWorkspace
Dim doc As NotesUIDocument
Dim rtitemA As NotesRichTextItem
Dim info As NotesRichTextItem
Set doc = workspace.CurrentDocument 'текущий документ
If Not doc.Document.HasEmbedded Then Exit Sub
Set rtitemA = doc.Document.GetFirstItem("info") ' поле где лежит атачмент
REM Сохраняем аттачи на диск
Forall att In rtitemA.EmbeddedObjects
If att.Type = EMBED_ATTACHMENT Then
filepath$ = "C:\temp\" & att.Source
Call att.ExtractFile(filepath$) ' сохранение файлов в "C:\temp\"
Call doc.GotoField("embed")
Call doc.Import("Microsoft Word",filepath$) ' создание (импорт) объекта Word
Kill filepath$ ' удаление фалов из дирректории "C:\temp\"
End If
End Forall
Call doc.FieldClear("Info") ' очищение поля "Info"
Call rtitemA.Update ' обновление поля
End Sub
Импорт из Microsoft Excel в документ Lotus
Действие в представлении для импорта файла Excel в Lotus
Кнопка вышается на представление "body_f2", после нажатия возможен выбор файла, но берется по умолчанию, потом вводится колличество строк и далее начинается сам импорт.
На каждую новую строчку в Excel создаётся новый документ, после окончания импорта в представлении отображаются документы,в которых ячейки Excel соответствуют полям формы документа.
Далее из этого представления по действию ("Импорт значений документов в таблицу RT поля") значения из документов импортируются в сгенерированную скриптом табличу, где количество вкладок вычисляется динамически, в зависимости от колличества документов в представлении
Таблица имеет вид
_________________________________________________________________________
|________________________ШАПКА__________________________________________|
|_название__|______код________|_цыфры__|_цыфры_|_цыфры_|_цыфры_|_%_____|
|___"a" _____|____"a_1"_________|__"a_2"__|_"a_3"___|_"a_4"__|__"a_5"__|_"a_6"__|
Sub Initialize
Dim xlFilename As String
xlFilename = Inputbox$("Файл импорта по умолчанию.", "Файл для импорта Диск:\f2.XLS", "c:\f2.xls")
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Set db = session.CurrentDatabase
Dim row As Integer
Dim written As Integer
Dim number As Integer
number = Inputbox$("Введите колличество строк", "количество строк, содержащихся в импортируемом файле")
Dim Excel As Variant
Dim xlWorkbook As Variant
Dim xlSheet As Variant
Dim xlCells As Variant
Set Excel = CreateObject("excel.application")
Excel.Visible = False
Print "Открыт файл " & xlFilename & "..."
Excel.Workbooks.Open xlFilename '// открытие файла Excel
Set xlWorkbook = Excel.ActiveWorkbook
Set xlSheet = xlWorkbook.ActiveSheet
Set xlCells = xlSheet.Cells
row = 1
written = 0
Print "Starting import from Excel file..."
Dim strName As String
Add:
row = row + 1
written=written+1
Print ("Импорт строки: "& Cstr(row) & " из: " &Cstr(number))
Set view = db.GetView("body_f2")'представление где после импорта отображаются созданные документы
strName = xlCells( row, 1). Value
Set doc = view.GetDocumentByKey(strName ,True)
If doc Is Nothing Then
Set doc = db.CreateDocument
With doc
.Form = "body_f2"
.a = xlCells(row, 1).Value
.a_1 = xlCells( row, 2 ).Value
.a_2 = xlCells(row, 3).Value
.a_3 = xlCells( row, 4).Value
.a_4 = xlCells( row, 5).Value
.a_5 = xlCells( row, 6).Value
.a_6 = xlCells( row, 7).Value
End With
Else
End If
Call doc.Save( True, True )
Set doc = Nothing
If written < number Then Goto Add
excel.quit
Dim ws As New NotesUIWorkspace
Call ws.ViewRefresh
End Sub
Кнопка вышается на представление "body_f2", после нажатия возможен выбор файла, но берется по умолчанию, потом вводится колличество строк и далее начинается сам импорт.
На каждую новую строчку в Excel создаётся новый документ, после окончания импорта в представлении отображаются документы,в которых ячейки Excel соответствуют полям формы документа.
Далее из этого представления по действию ("Импорт значений документов в таблицу RT поля") значения из документов импортируются в сгенерированную скриптом табличу, где количество вкладок вычисляется динамически, в зависимости от колличества документов в представлении
Таблица имеет вид
_________________________________________________________________________
|________________________ШАПКА__________________________________________|
|_название__|______код________|_цыфры__|_цыфры_|_цыфры_|_цыфры_|_%_____|
|___"a" _____|____"a_1"_________|__"a_2"__|_"a_3"___|_"a_4"__|__"a_5"__|_"a_6"__|
Sub Initialize
Dim xlFilename As String
xlFilename = Inputbox$("Файл импорта по умолчанию.", "Файл для импорта Диск:\f2.XLS", "c:\f2.xls")
Dim session As New NotesSession
Dim db As NotesDatabase
Dim view As NotesView
Dim doc As NotesDocument
Set db = session.CurrentDatabase
Dim row As Integer
Dim written As Integer
Dim number As Integer
number = Inputbox$("Введите колличество строк", "количество строк, содержащихся в импортируемом файле")
Dim Excel As Variant
Dim xlWorkbook As Variant
Dim xlSheet As Variant
Dim xlCells As Variant
Set Excel = CreateObject("excel.application")
Excel.Visible = False
Print "Открыт файл " & xlFilename & "..."
Excel.Workbooks.Open xlFilename '// открытие файла Excel
Set xlWorkbook = Excel.ActiveWorkbook
Set xlSheet = xlWorkbook.ActiveSheet
Set xlCells = xlSheet.Cells
row = 1
written = 0
Print "Starting import from Excel file..."
Dim strName As String
Add:
row = row + 1
written=written+1
Print ("Импорт строки: "& Cstr(row) & " из: " &Cstr(number))
Set view = db.GetView("body_f2")'представление где после импорта отображаются созданные документы
strName = xlCells( row, 1). Value
Set doc = view.GetDocumentByKey(strName ,True)
If doc Is Nothing Then
Set doc = db.CreateDocument
With doc
.Form = "body_f2"
.a = xlCells(row, 1).Value
.a_1 = xlCells( row, 2 ).Value
.a_2 = xlCells(row, 3).Value
.a_3 = xlCells( row, 4).Value
.a_4 = xlCells( row, 5).Value
.a_5 = xlCells( row, 6).Value
.a_6 = xlCells( row, 7).Value
End With
Else
End If
Call doc.Save( True, True )
Set doc = Nothing
If written < number Then Goto Add
excel.quit
Dim ws As New NotesUIWorkspace
Call ws.ViewRefresh
End Sub
Установка границ таблицы OpenOffice - sCalc
Set xlglob = CreateObject ( "com.sun.star.ServiceManager" )
Set Desktop = xlglob.createInstance("com.sun.star.frame.Desktop")
Set document = Desktop.LoadComponentFromURL("private:factory/scalc","_ blank",0,mass)
Set Border = Desktop.Bridge_GetStruct("com.sun.star.table.BorderLine")
Set sheets=Document.getSheets()
Set xlWbk = sheets.getByIndex(0)
...........................................
Set oRange = xlWbk.getCellRangeByName("A1:G5")
oRange.merge(True)
Call oRange.setPropertyValue("CellBackColor", 16764057)
Border.color = 155
Border.lineDistance = 0
Border.innerLineWidth = 0
Border.outerLineWidth = 1
Call oRange.SetPropertyValue ( "TopBorder" , Border )
Call oRange.SetPropertyValue( "BottomBorder" , Border )
Call oRange.SetPropertyValue( "LeftBorder" , Border )
Call oRange.SetPropertyValue( "RightBorder" , Border )
Set Desktop = xlglob.createInstance("com.sun.star.frame.Desktop")
Set document = Desktop.LoadComponentFromURL("private:factory/scalc","_ blank",0,mass)
Set Border = Desktop.Bridge_GetStruct("com.sun.star.table.BorderLine")
Set sheets=Document.getSheets()
Set xlWbk = sheets.getByIndex(0)
...........................................
Set oRange = xlWbk.getCellRangeByName("A1:G5")
oRange.merge(True)
Call oRange.setPropertyValue("CellBackColor", 16764057)
Border.color = 155
Border.lineDistance = 0
Border.innerLineWidth = 0
Border.outerLineWidth = 1
Call oRange.SetPropertyValue ( "TopBorder" , Border )
Call oRange.SetPropertyValue( "BottomBorder" , Border )
Call oRange.SetPropertyValue( "LeftBorder" , Border )
Call oRange.SetPropertyValue( "RightBorder" , Border )
Импорт значения из ячейки в таблице документа OpenOffice - sWriter в документ Lotus`а,
Код импорта из ячеек таблицы ODT файла
Используя функцию writegetcelltable (objDocument, "Таблица1", "A2"), нужно лишь указать имя таблицы и имя ячейки
Sub Click(Source As Button)
Dim args()
Set objServiceManager= CreateObject("com.sun.star.ServiceManager")
Set objCoreReflection= objServiceManager.createInstance("com.sun.star.reflection.CoreReflection")
Set objDesktop= objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set objDocument= objDesktop.loadComponentFromURL("file:///C:/1.odt", "_blank", 0, args())
Call writegetcelltable (objDocument, "Таблица1", "A2")
End Sub
Sub writegetcelltable (oDoc As Variant, tablename As Variant, cellname As Variant)
Set TextTables = oDoc.getTextTables()
Set TextTable = TextTables.getByName(tablename) ' таблица
Set TCell = TextTable.getCellByName(cellname) ' ячейка
Set oText = TCell.getText()
a = oText.getValue() ' значение из ячейки
End Sub
Используя функцию writegetcelltable (objDocument, "Таблица1", "A2"), нужно лишь указать имя таблицы и имя ячейки
Sub Click(Source As Button)
Dim args()
Set objServiceManager= CreateObject("com.sun.star.ServiceManager")
Set objCoreReflection= objServiceManager.createInstance("com.sun.star.reflection.CoreReflection")
Set objDesktop= objServiceManager.createInstance("com.sun.star.frame.Desktop")
Set objDocument= objDesktop.loadComponentFromURL("file:///C:/1.odt", "_blank", 0, args())
Call writegetcelltable (objDocument, "Таблица1", "A2")
End Sub
Sub writegetcelltable (oDoc As Variant, tablename As Variant, cellname As Variant)
Set TextTables = oDoc.getTextTables()
Set TextTable = TextTables.getByName(tablename) ' таблица
Set TCell = TextTable.getCellByName(cellname) ' ячейка
Set oText = TCell.getText()
a = oText.getValue() ' значение из ячейки
End Sub
Импорт значения из ячейки документа OpenOffice в документ Lotus`а
Код импорта из ячеек таблицы ODS файла
Используя вызов xlWbk.getCellRangeByName("E7").getValue() , мы импортируем в нужное нам notes-поле значение из ячейки
Dim mass()
Dim xlWbk As Variant
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim doc As New NotesDocument(db)
Call doc.ReplaceItemValue("Form","1")
FileName = "1.ods"
Set xlglob = CreateObject ( "com.sun.star.ServiceManager" )
Set Desktop = xlglob.createInstance("com.sun.star.frame.Desktop")
Set document= Desktop.loadComponentFromURL("file:///C:/"+FileName, "_blank", 0, mass)
Set sheets=Document.getSheets()
Set xlWbk = sheets.getByIndex(0)
doc.b_1 = xlWbk.getCellRangeByName("E7").getValue()
Эксперемент показал, что лучше
в конструкции doc.b_1 = xlWbk.getCellRangeByName("E7").getValue()
использовать doc.b_1 = xlWbk.getCellRangeByName("E7").getString()
Используя вызов xlWbk.getCellRangeByName("E7").getValue() , мы импортируем в нужное нам notes-поле значение из ячейки
Dim mass()
Dim xlWbk As Variant
Dim session As New NotesSession
Dim db As NotesDatabase
Set db = session.CurrentDatabase
Dim doc As New NotesDocument(db)
Call doc.ReplaceItemValue("Form","1")
FileName = "1.ods"
Set xlglob = CreateObject ( "com.sun.star.ServiceManager" )
Set Desktop = xlglob.createInstance("com.sun.star.frame.Desktop")
Set document= Desktop.loadComponentFromURL("file:///C:/"+FileName, "_blank", 0, mass)
Set sheets=Document.getSheets()
Set xlWbk = sheets.getByIndex(0)
doc.b_1 = xlWbk.getCellRangeByName("E7").getValue()
Эксперемент показал, что лучше
в конструкции doc.b_1 = xlWbk.getCellRangeByName("E7").getValue()
использовать doc.b_1 = xlWbk.getCellRangeByName("E7").getString()
Выгрузка в Word, через поля-Word
Данный код демострирует как выгрузить данные в Word, используя для этого поля Word'a.
Этот код я использовал для формирования договора. Что оказалось удобным способом для автоматического формирования текста договора (где как правило меняеются данные в одном и том же месте текста договора)
Dim s As New notessession
Dim todaydate As New notesdatetime("Today")
Dim word As Variant
Dim wordoc As Variant
Dim todaysdate As String
Dim orderid As String
Dim producedby As String
Dim storeid As String
Dim customername As String
Dim address As String
Dim citytown As String
Dim postcode As String
Dim daytimeno As String
Dim eveningno As String
'Присваивание значений пересенным (Lotus)
todaysdate = todaydate.localtime
orderid = "2183763248"
producedby = s.username
storeid = "12345"
customername = "John Doe"
address = "Apartment 5c, 5 Test Avenue"
citytown = "Testtown"
postcode = "XX5 5XX"
daytimeno = "1234567890"
eveningno = "0987654321"
'Создание Word-документа
Set word = CreateObject("Word.Application") 'Создание объекта Word'a
Call word.documents.add("Return and Uplift.dot") 'Создание нового документа по шаблону Return and Uplift.dot
Set worddoc = word.activedocument 'Активация объекта
'Присваивание полям-Word'a значений из полей notes-документа
worddoc.FormFields(1).result = todaysdate
worddoc.FormFields(2).result = orderid
worddoc.FormFields(3).result = producedby
worddoc.FormFields(4).result = storeid
worddoc.FormFields(5).result = customername
worddoc.FormFields(6).result = address
worddoc.FormFields(7).result = citytown
worddoc.FormFields(8).result = postcode
worddoc.FormFields(9).result = daytimeno
worddoc.FormFields(10).result = eveningno
worddoc.saveas(customername) 'сохранение документа-Word'a с именем файла "John Doe.doc"
word.visible = True 'Сделать видимым окно Word'a
'word.quit 'закрытие Word'a
Этот код я использовал для формирования договора. Что оказалось удобным способом для автоматического формирования текста договора (где как правило меняеются данные в одном и том же месте текста договора)
Dim s As New notessession
Dim todaydate As New notesdatetime("Today")
Dim word As Variant
Dim wordoc As Variant
Dim todaysdate As String
Dim orderid As String
Dim producedby As String
Dim storeid As String
Dim customername As String
Dim address As String
Dim citytown As String
Dim postcode As String
Dim daytimeno As String
Dim eveningno As String
'Присваивание значений пересенным (Lotus)
todaysdate = todaydate.localtime
orderid = "2183763248"
producedby = s.username
storeid = "12345"
customername = "John Doe"
address = "Apartment 5c, 5 Test Avenue"
citytown = "Testtown"
postcode = "XX5 5XX"
daytimeno = "1234567890"
eveningno = "0987654321"
'Создание Word-документа
Set word = CreateObject("Word.Application") 'Создание объекта Word'a
Call word.documents.add("Return and Uplift.dot") 'Создание нового документа по шаблону Return and Uplift.dot
Set worddoc = word.activedocument 'Активация объекта
'Присваивание полям-Word'a значений из полей notes-документа
worddoc.FormFields(1).result = todaysdate
worddoc.FormFields(2).result = orderid
worddoc.FormFields(3).result = producedby
worddoc.FormFields(4).result = storeid
worddoc.FormFields(5).result = customername
worddoc.FormFields(6).result = address
worddoc.FormFields(7).result = citytown
worddoc.FormFields(8).result = postcode
worddoc.FormFields(9).result = daytimeno
worddoc.FormFields(10).result = eveningno
worddoc.saveas(customername) 'сохранение документа-Word'a с именем файла "John Doe.doc"
word.visible = True 'Сделать видимым окно Word'a
'word.quit 'закрытие Word'a
31 января 2010 г.
Отправка файлов группе
Dim ws As New NotesUIWorkspace
Dim s As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim body As NotesRichTextItem
Set db = s.CurrentDatabase
files = ws.OpenFileDialog(True,"Выберите файлы для отправки",,"c:\")
If Isempty( files) Then
Exit Sub
End If
Stop
Set doc = New NotesDocument( db )
doc.Form = "Memo"
doc.SendTo = "Имя группы получатей" 'имя группы должно присутствовать в АК пользователя
doc.Subject = "Тема письма"
Set body = New NotesRichTextItem(doc, "Body")
Call body.AppendText("_:::. Смотрите прикрепленные файлы .:::_")
Call body.AddNewLine(2)
For i = 0 To Ubound (files)
Call body.EmbedObject(EMBED_ATTACHMENT, "", files(i))
Next
Call doc.Send( False )
Dim s As New NotesSession
Dim db As NotesDatabase
Dim doc As NotesDocument
Dim body As NotesRichTextItem
Set db = s.CurrentDatabase
files = ws.OpenFileDialog(True,"Выберите файлы для отправки",,"c:\")
If Isempty( files) Then
Exit Sub
End If
Stop
Set doc = New NotesDocument( db )
doc.Form = "Memo"
doc.SendTo = "Имя группы получатей" 'имя группы должно присутствовать в АК пользователя
doc.Subject = "Тема письма"
Set body = New NotesRichTextItem(doc, "Body")
Call body.AppendText("_:::. Смотрите прикрепленные файлы .:::_")
Call body.AddNewLine(2)
For i = 0 To Ubound (files)
Call body.EmbedObject(EMBED_ATTACHMENT, "", files(i))
Next
Call doc.Send( False )
25 января 2010 г.
Работа с массивом
Возникла необходимость создать массив с нужными мне указателями ...
Set view_characters = db.Getview("characters_teplo")
Dim nav As NotesViewNavigator
Dim entry As NotesViewEntry
Dim vecoll As NotesViewEntryCollection
Dim docArray(),q
'uin = uidoc.Document.Universalid
Set vecoll = view_characters.Getallentriesbykey(uin)
Set entry = vecoll.Getfirstentry()
Stop
q = 0
ReDim docArray(vecoll.Count-1,1)
While Not (entry Is Nothing)
If (entry.IsDocument) Then
docArray(q,0) = entry.Columnvalues(1)
Set docArray(q,1) = entry.Document
End If
q=q+1
Set entry = vecoll.GetNextEntry(entry)
Wend
В конечном итоге получается массив
("указатель1")("документ1")
("указатель2")("документ2")
Set view_characters = db.Getview("characters_teplo")
Dim nav As NotesViewNavigator
Dim entry As NotesViewEntry
Dim vecoll As NotesViewEntryCollection
Dim docArray(),q
'uin = uidoc.Document.Universalid
Set vecoll = view_characters.Getallentriesbykey(uin)
Set entry = vecoll.Getfirstentry()
Stop
q = 0
ReDim docArray(vecoll.Count-1,1)
While Not (entry Is Nothing)
If (entry.IsDocument) Then
docArray(q,0) = entry.Columnvalues(1)
Set docArray(q,1) = entry.Document
End If
q=q+1
Set entry = vecoll.GetNextEntry(entry)
Wend
В конечном итоге получается массив
("указатель1")("документ1")
("указатель2")("документ2")
Подписаться на:
Сообщения (Atom)
