1. Es geht um ein Attachment
2. der Code liegt in der Scriptlibrary
Declare Function GetTempFileNameA Lib "Kernel32" (Byval lpszPath As String, Byval lpPrefixString As String, Byval wUnique As Integer, Byval lpTempFileName As String) As Long
Declare Function GetTempFileName Lib "Kernel" (Byval cDriveLetter As Integer, Byval lpPrefixString As String, Byval wUnique As Integer, Byval lpTempFileName As String) As Integer
Declare Function GetTempDrive Lib "Kernel" (Byval cDriveLetter As Integer) As Integer
Declare Function FindWindowA Lib "user32" (Byval lpClassName As String, Byval lpWindowName As String) As Long
Declare Function SetActiveWindow Lib "user32" (Byval hwnd As Long) As Integer
Declare Function RegCloseKey Lib "advapi32.dll" (Byval hKey As Long) As Long
Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (Byval hKey As Long, Byval lpSubKey As String, Byval ulOptions As Long, Byval samDesired As Long, phkResult As Long) As Long
Declare Function RegQueryValueExString Lib "advapi32.dll" Alias "RegQueryValueExA" (Byval hKey As Long, Byval lpValueName As String, Byval lpReserved As Long, lpType As Long, Byval lpData As String, lpcbData As Long) As Long
Declare Function RegQueryValueExLong Lib "advapi32.dll" Alias "RegQueryValueExA" (Byval hKey As Long, Byval lpValueName As String, Byval lpReserved As Long, lpType As Long, lpData As Long, lpcbData As Long) As Long
Declare Function RegQueryValueExNULL Lib "advapi32.dll" Alias "RegQueryValueExA" (Byval hKey As Long, Byval lpValueName As String, Byval lpReserved As Long, lpType As Long, Byval lpData As Long, lpcbData As Long) As Long
Const REG_SZ = 1
Const REG_DWORD = 4
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const ERROR_NONE = 0
Const ERROR_BADDB = 1
Const ERROR_BADKEY = 2
Const ERROR_CANTOPEN = 3
Const ERROR_CANTREAD = 4
Const ERROR_CANTWRITE = 5
Const ERROR_OUTOFMEMORY = 6
Const ERROR_INVALID_PARAMETER = 7
Const ERROR_ACCESS_DENIED = 8
Const ERROR_INVALID_PARAMETERS = 87
Const ERROR_NO_MORE_ITEMS = 259
Const KEY_READ = &H19
Const KEY_ALL_ACCESS = &H3F
Const REG_OPTION_NON_VOLATILE = 0
Const DEBUGMODEScriptLibrary = False
Public Class twCompScan
' #################################################################################################
'
' Member Variables
'
' #################################################################################################
Private ScanOLEObjectName As String ' Name of object to create for using
Private ScanOLEObjectFileName As String ' Name of File Object to generate for loading
Private ScanObject As Variant ' Handle to automation object
Private LocalFileName As String ' File name of attachment when saving it to the local harddisk
Private InternalFileNameDefault As String ' Default File name of attachment in current document: scan.tif
Private InternalFileName As String ' File name of attachment in current document, usually scan.tif, set in New sub
Private InternalRTItemName As String ' Name of rich text field containing the attachment, usually twCompScanBody, set in New sub
Private InternalOCRItemName As String ' Name of rich text field containing the OCR'ed text, usually twCompScanBodyText, set in New sub
Private session As NotesSession
Private UiDoc As NotesUiDocument
Private Workspace As NotesUiWorkspace
Private DebugMode As String
' #################################################################################################
'
' Internal Functions
'
' #################################################################################################
Private Function DisplayError ( displayText As String ) As Integer
' call the internal error handling functions
' Messagebox displayText, MB_OK + MB_ICONEXCLAMATION, str_twCScanErrorHeader
Print str_twCScanErrorHeader & ": " & displayText
DisplayError = True
End Function
Private Sub DisplayStatus ( displayText As String )
If Me.DebugMode = "1" Then Print ( displayText & str_twCScanErrorPlace )
End Sub
Private Function RaiseError ( method As String ) As Integer
' Checks to see if the object produced an error or not.
' method: String containing method name to display
DisplayStatus ( "twCompScan.RaiseError" )
If ( Me.ScanObject.ReturnCode() <> 0) Then
Call DisplayError ( method & ": " & Me.ScanObject.ReturnMessage() )
RaiseError = True
Else
RaiseError = False
End If
End Function
' #################################################################################################
'
' External Functions
'
' #################################################################################################
Public Sub New ( Byval RTItemName As String, Byval OCRItemName As String, Byval FileName As String )
' Constructor for setting different variables, determing the path where Watermark is installed,
' setting global member variables for current NotesSession, NotesUiWorkspace, NotesUiDocument
' RTItemName: String containing the name of the rich text item with the attachment
' OCRItemName: String containing the name of the rich text item with the OCR'ed text
' Filename: String containing the file name of the attachment
' Set default values
Stop
ScanOLEObjectName = "AcroExch.App"
ScanOLEObjectFileName = "AcroExch.PDDoc"
Me.InternalFileNameDefault = "scan.pdf"
If RTItemName = "" Then
Me.InternalRTItemName = "twCompScanBody"
Else
Me.InternalRTItemName = RTItemName
End If
Dim sKeyName As String
Dim sValueName As String
Dim ret As Integer
Dim regObject As New twRegistry
sKeyName = "AcroExch.App"
sValueName = "(Standard)"
If OCRItemName = "" Then
Me.InternalOCRItemName = "twCompScanBodyText"
Else
Me.InternalOCRItemName = OCRItemName
End If
Set Me.session = New NotesSession
Set Me.workspace = New NotesUIWorkspace
Set Me.uidoc = workspace.CurrentDocument
' Check Debug Mode
Me.DebugMode = Me.session.GetEnvironmentString ( "twCompScanAcrobatDebugMode" )
' Get installation path
On Error Resume Next
sKeyName = "AcroExch.App"
ret= regObject.QueryKeyExists ( HKEY_CLASSES_ROOT, sKeyName )
If ret = False Then
Call Me.UiDoc.Document.ReplaceItemvalue ( "twCompScanInstalled", "0" )
Call DisplayError ( str_twCScanErrorMissing )
Call Me.UiDoc.RefreshHideFormulas ()
Exit Sub
Else
Call Me.UiDoc.Document.ReplaceItemvalue ( "twCompScanInstalled", "1" )
End If
Me.LocalFileName = ""
Me.InternalFileName = fileName
' Identify attachment
Dim doc As NotesDocument
Dim rtItem As NotesRichTextItem
Set doc = Me.UiDoc.Document
Set rtItem = doc.GetFirstItem ( Me.InternalRTItemName )
If rtItem.Type = RICHTEXT Then
Forall RTObjects In rtItem.EmbeddedObjects
If ( RTObjects.Type = EMBED_ATTACHMENT ) Then
Me.InternalFileName = RTObjects.Name
Exit Forall
End If
End Forall
End If
' Get temporary filename
Dim tempPath As String
Dim tempFileName As String * 256
Dim tempNewName As String
tempPath = Environ$ ( "TEMP" )
If Mid ( tempPath, Len(tempPath), 1 ) <> "\" Then
tempPath = tempPath & "\"
End If
ret = GetTempFileNameA ( tempPath, "tws", 0, tempFileName )
tempFileName = Left ( tempFileName, Instr ( tempFileName, Chr (0) ) - 1 )
On Error Goto ErrorRename
tempNewName = Strleft ( tempFileName, "." )
tempNewName = tempNewName + ".pdf"
Name tempFileName As tempNewName
Me.LocalFileName = tempNewName
Call Me.UiDoc.RefreshHideFormulas ()
Exit Sub
ErrorRename:
Call DisplayError ( str_twCScanErrorRename )
Call Me.UiDoc.Document.ReplaceItemvalue ( "twCompScanInstalled", "0" )
Call Me.UiDoc.RefreshHideFormulas ()
Exit Sub
End Sub
' #################################################################################################
Public Sub Delete
' Shut down scan software if not already done
Dim ScanObjectAVDoc As Variant
Dim numberOfDocs As Long
Dim i As Long
DisplayStatus ( "twCompScan.Delete")
On Error Resume Next
If (Not Isempty( Me.ScanObject )) Then
numberOfDocs = Me.ScanObject.GetNumAVDocs
For i = 1 To numberOfDocs
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Call ScanObjectAVDoc.Close (True)
Next
Me.ScanObject.Exit
Set Me.ScanObject = Nothing ' shut down scan software
End If
Kill Me.LocalFileName
End Sub
' #################################################################################################
Public Function Launch (bShowWindow As Integer)
' If not already done, create a OLE object and store it in Me.ScanObject
' bShowWindow: Boolean parameter, indicating whether the scan window
' should be displayed or not
DisplayStatus ( "twCompScan.Launch")
On Error Goto ErrorLocal
If ( Isempty(Me.ScanObject) ) Then
Set Me.ScanObject = CreateObject( ScanOLEObjectName )
End If
If (bShowWindow) Then
Me.ScanObject.Show
Me.ScanObject.Restore (True)
End If
Launch = True
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorLaunch )
Launch = False
Exit Function
End Function
' #################################################################################################
Public Function Open As Integer
' Display the "Open Document" Dialogbox to the user and let him choose a file
Dim numberOfDocs As Long
DisplayStatus ( "twCompScan.Open" )
On Error Goto ErrorLocal
Call Me.Launch ( True )
numberOfDocs = Me.ScanObject.GetNumAVDocs
Me.ScanObject.Restore (True)
Me.ScanObject.MenuItemExecute "Open" ' prompt user for existing document
Doevents
If (numberOfDocs = Me.ScanObject.GetNumAVDocs) Then
DisplayError ( str_twCScanErrorOpen )
Me.Open = False
Exit Function
End If
Me.Open = True
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorOpen & Error$ )
Me.Open = False
Exit Function
End Function
' #################################################################################################
Public Function Print As Integer
' Prints the current document in the window on the default printer
DisplayStatus ( "twCompScan.Print" )
On Error Goto ErrorLocal
Dim ScanObjectAVDoc As Variant
Dim ScanObjectPDDoc As Variant
Dim numPages As Long
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Set ScanObjectPDDoc = ScanOBjectAVDoc.GetPDDoc
numPages = ScanObjectPDDoc.GetNumPages
If (Not ScanObjectAVDoc.PrintPagesSilent (0, numPages - 1, 0, False, True)) Then
Me.Print = False
Exit Function
End If
Me.Print = True
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorPrint & Error$ )
Me.Print = False
Exit Function
End Function
' #################################################################################################
Public Function Save As Integer
' Save the current image on local hard disk
Dim ScanObjectAVDoc As Variant
Dim ScanObjectPDDoc As Variant
DisplayStatus ( "twCompScan.Save" )
On Error Goto ErrorLocal
If ( Isempty (ScanObject) ) Then
Exit Function
End If
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Set ScanObjectPDDoc = ScanOBjectAVDoc.GetPDDoc
' save file with all pages and overwrite any existing file
If ( ScanObjectPDDoc.Save ( 1, Me.LocalFileName ) ) Then
Call Me.UiDoc.Document.ReplaceItemValue ( "twCompScanDoSave", "1" )
Me.Save = True
Else
Me.Save = False
End If
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorSave & Error$ )
Save = False
Exit Function
End Function
' #################################################################################################
Public Function SaveNotes As Integer
' Transfer the current image fromlocal hard disk to the document
Dim doc As NotesDocument
Dim rtItem As NotesRichTextItem
Dim tempItemValue As Variant
DisplayStatus ( "twCompScan.SaveNotes" )
On Error Goto ErrorLocal
Set doc = Me.UiDoc.Document
SaveNotes = True
tempItemValue = doc.GetItemValue ( "twCompScanDoSave" )
If tempItemValue(0) <> "1" Then
Exit Function
End If
Call doc.removeitem( Me.InternalRTItemName )
Call doc.removeItem ( "twCompScanDoSave" )
Set rtitem = New NotesRichTextItem( doc, Me.InternalRTItemName )
Call rtItem.AppendText ( " " ) ' Needed to display the embedded object
' at the right position
Call rtitem.EmbedObject ( EMBED_ATTACHMENT, "", Me.LocalFileName, Me.InternalFileName )
Call doc.Save ( True, True )
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorSaveNotes & Error$ )
SaveNotes = False
Exit Function
End Function
' #################################################################################################
Public Function Load As Integer
' Load the file which is saved in the current NotesDocument into Watermark
Dim doc As NotesDocument
Dim rtItem As NotesRichTextItem
Dim ScanObjectAVDoc As Variant
Dim retCode As Variant
DisplayStatus ( "twCompScan.Load" )
On Error Goto ErrorLocal
Call Me.Launch ( True )
Set doc = Me.UiDoc.Document
Set rtItem = doc.GetFirstItem ( Me.InternalRTItemName )
If rtItem.Type = RICHTEXT Then
Forall RTObjects In rtItem.EmbeddedObjects
If ( RTObjects.Type = EMBED_ATTACHMENT ) Then
Call RTObjects.ExtractFile( Me.LocalFileName )
Exit Forall
End If
End Forall
End If
retCode = Me.ScanObject.CloseAllDocs
Set ScanObjectAVDoc = CreateObject ( "AcroExch.AVDoc" )
retCode = ScanObjectAVDoc.Open ( Me.LocalFileName, "" )
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
If ( retCode ) Then
Load = True
Exit Function
End If
ErrorLocal:
Call DisplayError ( str_twCScanErrorLoad & Error$ )
Load = False
Exit Function
End Function
' #################################################################################################
Public Function Scan As Integer
' Scan all pages in automatic feeder (or one page w/o ADF) into the current document
Dim retCode As Long
Dim ScanObjectAVDoc As Variant
Dim ScanObjectPDDoc As Variant
Dim numPages1 As Long
Dim numPages2 As Long
DisplayStatus ( "twCompScan.Scan" )
Call Me.Launch ( True )
On Error Resume Next ' ignore exceptions
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Set ScanObjectPDDoc = ScanOBjectAVDoc.GetPDDoc
numPages1 = ScanObjectPDDoc.GetNumPages
Me.ScanObject.Restore (True)
retCode = Me.ScanObject.MenuItemExecute ( "Scan" )
Doevents
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Set ScanObjectPDDoc = ScanOBjectAVDoc.GetPDDoc
numPages2 = ScanObjectPDDoc.GetNumPages
If (numPages1 = numPages2) Then
DisplayError ( str_twCScanErrorScan )
Scan = False
Exit Function
Else
Scan = True
End If
End Function
' #################################################################################################
Public Function OCR As Integer
' OCR's the current document
Dim retCode As Long
Dim ScanObjectAVDoc As Variant
Dim AcrobatWindowTitle As String
Dim AcrobatWindowHandle As Long
DisplayStatus ( "twCompScan.OCR" )
On Error Goto ErrorLocal
' Activate window of scan modul by finding it with win32 functions
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc ()
AcrobatWindowTitle = ScanObjectAVDoc.GetTitle ()
AcrobatWindowHandle = FindWindowA ( "", AcrobatWindowTitle )
Call SetActiveWindow ( AcrobatWindowHandle )
retCode = Me.ScanObject.MenuItemExecute ( "Cpt:CapturePages" )
Me.OCR = True
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorOcr & Error$ )
Me.OCR = False
Exit Function
End Function
' #################################################################################################
Public Function OCRText As Integer
' Put the OCR'ed text in a field of the current document
Dim ScanObjectAVDoc As Variant
Dim ScanObjectPDDoc As Variant
Dim ScanObjectAVPageView As Variant
Dim numPages As Long
Dim i As Long
DisplayStatus ( "twCompScan.OCRText" )
Set ScanObjectAVDoc = Me.ScanObject.GetActiveDoc
Set ScanObjectPDDoc = ScanOBjectAVDoc.GetPDDoc
Set ScanObjectAVPageView = ScanObjectAVDoc.GetAVPageView
numPages = ScanObjectPDDoc.GetNumPages
Me.UiDoc.EditMode = True
If Me.UiDoc.EditMode = False Then
Call DisplayError ( str_twCScanErrorOcrTextNoEdit )
Me.OcrText = False
Exit Function
Else
Call Me.uiDoc.GotoField ( Me.InternalOCRItemName )
For i = 0 To numPages - 1
Call ScanObjectAVPageView.Goto (i)
Call Me.ScanObject.MenuItemExecute ( "SelectAll")
Call Me.ScanObject.MenuItemExecute ( "Copy")
Call Me.uiDoc.Paste ()
Next
Me.OcrText = True
End If
Exit Function
ErrorLocal:
Call DisplayError ( str_twCScanErrorOcrTextCopy & Error$ )
Me.OCRText = False
Exit Function
End Function
End Class
