Решено Выгрузка всех файлов из базы..

Shandrik · 18.06.2015

Мыш сказал(а):
@Shandrik, насколько мне помнится, были какие-то засады с doc.EmbeddedObjects - то ли не все файлы извлекались, то ли ошибка выпадала. ИМХО, через RichTextItem правильней...

А если получить список файлов по @AttachmentNames, а потом пройтисьб по нему doc.GetAttachment( fileName$ )?

Shandrik · 18.06.2015

В задаче ведь про имя поля не сказано. Файлы могут лежать в другом РТ-поле.

lmike · 18.06.2015

уже выкладывал здесь

Код:

'Return last detached file name, write list of detached files
Function DetachFiles(objdoc As NotesDocument, fld As String, filter As String, filesList List As String) As String
	Dim file As String, path As String
	Dim rtItem As NotesRichTextItem
	Dim docItem As NotesItem
	
	On Error Goto ErrorHandler
	Erase filesList
	Set docItem=objdoc.GetFirstItem(fld)
	If Not docItem Is Nothing Then
		DbgMsg("RichText:" & Cstr(docItem.Type = RICHTEXT))
		If docItem.Type=RICHTEXT Then
			Set rtItem=docItem
		End If
	End If
	
	path=GetNotesTempDirectory()
	file=""
	If objdoc.Hasembedded Then
		If ( Not rtItem Is Nothing ) Then
			If (Not Isempty(rtitem.EmbeddedObjects))Then
				Forall o In rtitem.EmbeddedObjects 
					Dim detach As Boolean
					detach=True
					If (filter<>"") Then
						If Not (Lcase(o.Name) Like filter) Then
							detach=False
						End If
					End If
					If detach Then
						file=o.Name
						filesList(file)=path
						Call o.ExtractFile(path & file)
					End If
				End Forall 
			End If
		End If
	End If
	If file<>"" Then DetachFiles=path & file
ExitFunction:
	Exit Function
ErrorHandler:
	Call RaiseError()
	Erase filesList
	Resume ExitFunction
End Function

[DOUBLEPOST=1434622286,1434622000][/DOUBLEPOST]дополненная ф-ция:

Код:

%REM
*--------------------------------------------
Function DetachDocFiles
Description: выгружает файлы не только из RT полей (mime тоже)
%END REM
Function DetachDocFiles(objdoc As NotesDocument, Byval filter As String, filesList List As String) As String
	Dim file As String, path As String
	Dim fNames As Variant
	Dim o As NotesEmbeddedObject
	
	On Error Goto ErrorHandler
	Erase filesList
	
	path=Replace(GetNotesTempDirectory(),WINFS_SEP,FS_SEP) & FS_SEP
	file=""
	
	fNames=AttachmentsName(objdoc)
	Dim detach As Boolean, negative As Boolean
	If Left$(filter,1)={!} Then negative=True
	If negative And Len(filter)>0 Then filter=Right$(filter,Len(filter)-1)
	filter=Ucase(filter)
	Forall a In fNames
		Set o=objdoc.GetAttachment(a)
		detach=True
		If Len(filter)>0 Then
			If Not (Ucase(o.Name) Like filter) Then
				detach=False
			End If
			detach=detach Xor negative
		End If
		If detach Then
			file=o.Name
			If UNID_pref Then file=objdoc.UniversalID & PREF_SEP &file
			filesList(file)=path
			Call o.ExtractFile(path & file)
		End If
	End Forall
	If Len(file)>0 Then DetachDocFiles=path & file: Print {First Detached:} DetachDocFiles
Quit:
	Exit Function
ErrorHandler:
	Call RaiseError()
	Erase filesList
	Resume Quit
End Function

Shandrik · 18.06.2015

Покажите функцию fNames=AttachmentsName(objdoc)

lmike · 18.06.2015

Код:

%REM
*--------------------------------------------
Function AttachmentsName
Description: список имен приложенных файлов
%END REM
Function AttachmentsName(objdoc As NotesDocument) As Variant
	AttachmentsName=Evaluate("@AttachmentNames(0)", objdoc)
End Function

JohnLemon · 18.06.2015

Мыш сказал(а):
@JohnLemon, Domino как сервис работает? Если да, то под каким пользователем?

Я локально работаю, сервер вообще отключен )

lmike · 18.06.2015

LAX,SAX...

garrick · 18.06.2015

lmike сказал(а):
не уверен, яж не буду перебирать документы..., но надо тестить

У тебя же содержимое полей как-то должно попасть в XML. Вот тут-то и засада.

lmike · 18.06.2015

garrick сказал(а):
У тебя же содержимое полей как-то должно попасть в XML. Вот тут-то и засада.

надо смотреть, предположительно - просто будет пустое (или обрезанное), если поставить игнор ошибок
ведь иначе нельзя будет выгрузить БД с ошибочными доками, а механизм общий

lmike · 18.06.2015

набросал код, для создания невалидного поля

Код:

Sub Click(Source As Button)
On Error Goto ErrH
Dim ses As New NotesSession, wks As New NotesUIWorkspace
Dim doc As NotesDocument
Set doc=wks.CurrentDocument.Document
Dim v
v=Split({,},{,})
Dim item As New NotesItem(doc,{over32},v)
item.IsSummary=False
v(0)=Ustring(BIG, "*chars")
v(1)=Ustring(BIG, "*chars")
item.Values=v
item.IsSummary=True
Set item=doc.ReplaceItemValue({SaveOptions},{00})
item.SaveToDisk=False
Call doc.Save(True, False)
wks.CurrentDocument.Close True
Quit:
Exit Sub
ErrH:
Error Err, "Got error " & Error$ & " on line " & Cstr(Erl)
End Sub

lmike · 18.06.2015

проверил выгружает только db и только без документов (дизайн выгружает), если в доках есть поле >32K
коллекцию соответ. не выгрузит (просто файл с название БД забоянит)

Код:

%REM
*********************************************
Agent DXLfromSel
Created Jun 18, 2015 by Mikhail Cholokov/CRUINTERNET
Description: Comments for Agent
%END REM
Option Public
Option Declare
Use "Common.lib"
 
Sub Initialize
	On Error GoTo ErrH
	Debug=true
	Dim NDC As NotesDocumentCollection
	Set NDC=SelectedDocsUI
	Dim ses As New NotesSession, stream As NotesStream
	Dim db As NotesDatabase
	Set db=ses.Currentdatabase
	Set stream=ses.Createstream()
	stream.Open({/dxl.xml})
	Dim dxl As NotesDXLExporter
	Set dxl=ses.Createdxlexporter()
	Call dxl.SetOutput(stream)
	'Call dxl.Setinput(NDC)
	Call dxl.Setinput(db)
	dxl.Exitonfirstfatalerror=False
	Call dxl.Process()
Quit:
	Exit Sub
ErrH:
	If Not dxl Is Nothing Then
		If Len(dxl.Log)>0 Then MsgBox dxl.Log
	End If
	Error Err,RaiseError
End Sub

lmike · 18.06.2015

отмазка - код кот. выложил для создания "плохого" поля - не применять на рабочих БД - док будет утрачен

garrick · 19.06.2015

Всегда возмущался по поводу того, что Лотус имеет возможность сохранять такие поля, но не позволяет потом читать такие документы. :red:

Shandrik · 19.06.2015

lmike сказал(а):
набросал код, для создания невалидного поля
...
v(0)=Ustring(BIG, "*chars")
v(1)=Ustring(BIG, "*chars")
...

Что у Вас в BIG положено?

lmike · 22.06.2015

Shandrik сказал(а):
Что у Вас в BIG положено?

18000
[DOUBLEPOST=1434964106,1434964000][/DOUBLEPOST]

garrick сказал(а):
Всегда возмущался по поводу того, что Лотус имеет возможность сохранять такие поля, но не позволяет потом читать такие документы. :red:

чтобы сохранить - стоило поизвращаться

, без указанных кастылей - ничего не сохранит (правда - молча)

JohnLemon · 12.07.2015

Проблема с записью файлов была скорее всего из за того что папка не могла создаваться с тем же именем, не могу понять как проверить на существование.
Пытаюсь так:

Код:

Sub Click(Source As Button)
Dim session As NotesSession
Set session = New NotesSession
Set db = session.CurrentDatabase
pathName$ = "C:\Temp\"
If Dir$(pathName$ , ATTR_DIRECTORY) = "" Then
Msgbox "No Dir"
Else
Msgbox "Dir Found!"
End If
End Sub

Возвращает no dir хоть убейся ) А она есть (
Так пытаюсь он мне 1 док сохраняет в папку с ид дока, а второй не хочет и создает туже папку с только с -problem

Код:

Sub Click(Source As Button)
On Error Goto Handler
Dim ErrStr As String
Dim session As  New NotesSession
Set db = session.CurrentDatabase
Set view = db.GetView("all")
view.autoupdate = False
Set doc = view.GetFirstDocument
While Not(doc Is Nothing)
Set rtitem = doc.GetFirstItem( "Body" )
If (rtItem.Type = RICHTEXT) Then
Forall o In rtitem.EmbeddedObjects
If (o.Type = EMBED_ATTACHMENT) Then
Mkdir "c:\TEMP\" & doc.universalId & "\"
Call o.ExtractFile("C:\Temp\" & doc.universalId & "\"& o.Name)
End If
End Forall
End If
nextDoc:
Set doc = view.GetNextDocument(doc)
Wend
view.autoupdate = True
Exit Sub
Handler:
ErrStr = {Error: } & Error$ & { in line } & Erl
If Not doc Is Nothing Then ErrStr = ErrStr & Chr(10) & doc.universalId
If session.IsOnServer Then
Print ErrStr
Else
Print ErrStr
Mkdir "c:\TEMP\" & doc.universalId & "-problem\"
End If
If Not doc Is Nothing Then Resume nextDOc
If Not view Is Nothing Then view.autoupdate = True
Exit Sub
End Sub

savl · 13.07.2015

@JohnLemon,
Вот это работает,

Код:

DirectoryExist = (Dir$ (DirPath, 16) "" )

может сервер не видит папку или пользователь, доступ.
[DOUBLEPOST=1436771088,1436771040][/DOUBLEPOST]Ну если уже директория есть, то второй раз её создать нельзя:

Код:

Mkdir "c:\TEMP\" & doc.universalId & "\"

JohnLemon · 13.07.2015

savl сказал(а):
DirectoryExist = (Dir$ (DirPath, 16) "" )

А как проверить, что должна вернуть функция если не существует ? Про доступ должен быть папки и файлы то у меня создает там (

savl · 13.07.2015

съелось движком: DirectoryExist = (Dir$ (DirPath, 16) <> "" )
Возврат True/False, если true - существует.

JohnLemon · 13.07.2015

Отдельно да проверка работает но у меня

Код:

Sub Click(Source As Button)
On Error Goto Handler
Dim ErrStr As String
Dim session As  New NotesSession
Set db = session.CurrentDatabase
Set view = db.GetView("all")
view.autoupdate = False
Set doc = view.GetFirstDocument
While Not(doc Is Nothing)
Set rtitem = doc.GetFirstItem( "Body" )
If (rtItem.Type = RICHTEXT) Then
pathName = "C:\Temp\" & doc.universalId & "\"
DirectoryExist = (Dir$ (pathName, 16) <> "" )
If (DirectoryExist =False) Then
Mkdir "C:\Temp\" & doc.universalId & "\"
End If
Forall o In rtitem.EmbeddedObjects
If (o.Type = EMBED_ATTACHMENT) Then
Call o.ExtractFile("C:\Temp\" & doc.universalId & "\"& o.Name)
End If
End Forall
End If
nextDoc:
Set doc = view.GetNextDocument(doc)
Wend
view.autoupdate = True
Exit Sub
Handler:
ErrStr = {Error: } & Error$ & { in line } & Erl
If Not doc Is Nothing Then ErrStr = ErrStr & Chr(10) & doc.universalId
If session.IsOnServer Then
Print ErrStr
Else
Print ErrStr
Mkdir "c:\TEMP\" & doc.universalId & "-problem\"
End If
If Not doc Is Nothing Then Resume nextDOc
If Not view Is Nothing Then view.autoupdate = True
Exit Sub
End Sub

Почему то тут DirectoryExist = (Dir$ (pathName, 16) <> "" ) вываливается как я понимаю ошибка path not found (

Все сервисы Codeby

Поиск

Поиск

Решено Выгрузка всех файлов из базы..

Shandrik

Shandrik

lmike

нет, пердело совершенство

Shandrik

lmike

нет, пердело совершенство

JohnLemon

lmike

нет, пердело совершенство

garrick

lmike

нет, пердело совершенство

lmike

нет, пердело совершенство

lmike

нет, пердело совершенство

lmike

нет, пердело совершенство

garrick

Shandrik

lmike

нет, пердело совершенство

JohnLemon

savl

JohnLemon

savl

JohnLemon