Un ejemplo de exportacion de anexos
Sub Initialize
On Error Goto Fallos
Dim ns As New notessession
Dim ndb As notesdatabase
Dim nd As notesdocument
Dim anexo As NotesEmbeddedobject
Dim ndcol As notesdocumentcollection
Set ndb=ns.currentdatabase
Set ndcol=ndb.unprocesseddocuments
Set nd=ndcol.getfirstdocument
peticionunidad: ' Etiqueta para que vuelva el script a esta linea cuando el usuario mete más de una letra o ninguna como unidad de disco
unidad=Inputbox$( "Escribe la unidad del disco" , "Introduce la Unidad de Disco. Ejemplo C" , "C" )
longitud=Len(unidad)
'comprobamos la longitud del texto introducido como unidad de disco
If longitud=0 Or longitud>1 Then
opcion=Msgbox ("Introduce solo una letra",1,"Error")
If opcion=2 Then
Exit Sub
End If
Goto peticionunidad
End If
unidad2=Left$(unidad,1)+":"
disco=unidad2
'peticion del path
directorio=Inputbox$( "Escribe la ruta" , "Introduce la ruta Ejemplo: videos o videos/humor" , "" )
longituddir=Len(directorio)
inicio=Left$(directorio,1)
Dim final As Integer
final=longituddir-1
fin=Right$(directorio,1)
'comprobamos que el path se de tipo \nombredirectorio\....
barrainicio=Strcompare("\", inicio, 1)
barrafin=Strcompare("\", fin, 1)
If barrainicio=0 And barrafin=0 Then
pathName$=disco+directorio
Elseif barrainicio><0 And barrafin=0 Then
pathName$=disco+"\"+directorio
Elseif barrainicio=0 And barrafin><0 Then
pathName$=disco+directorio+"\"
Elseif barrainicio<>0 And barrafin>0 Then
pathName$=disco+"\"+directorio+"\"
End If
etiqueta$="1"
'cambiamos la unidad del disco
Chdrive unidad
ruta=pathName$
'Recorremos los documentos seleccionados
For i = 1 To ndcol.count
Set rtitem = nd.GetFirstItem( "Fichero" )
If ( rtitem.Type = RICHTEXT ) Then
Forall o In rtitem.EmbeddedObjects
If ( o.Type = EMBED_ATTACHMENT )Then
etiqueta$="2"
extraer:
'extraemos todos los anexos de cada documentos
Call o.ExtractFile( pathname$ & o.Source)
Print "Ficheros extraidos:" & Cstr(o.source) & " del formulario nº "&Cstr(ndcol.count)
End If
End Forall
End If
Set nd=ndcol.getnextdocument(nd)
Next
Exit Sub
Fallos:
Select Case etiqueta$
Case"1"
'si no existe la unidad de disco salimos de la rutina
Msgbox "No existe la unidad de Disco","0","Vuelve a ejecutarlo"
Exit Sub
Case "2"
' sino existe el directorio preguntamos si se quiere crear y volvemos a la extraccion de anexos
directorios=Msgbox ("No existe el directorio","1","Desea crearlo")
If directorios=1 Then
Mkdir ruta
Goto extraer
End If
End Select
End Sub
|
Otros documentos de LotusScript
|