Было в SandBox.... + мои наработки.....

Замечание к документу "редактирование вложений на месте" >>>

Тема: Было в SandBox.... + мои наработки.....

Создан:

Du ChAN 08/19/2002 07:51 AM

Папка:
03. Русские буквы и Notes, 04. Специфичное "русскому" Lotus Notes, 06. Разработка Notes-приложений

Тип сообщения:
Решение

Сообщение:
По поводу редактирования аттачмента было на нотсовском "сэндбоксе"...
там фронтэнд...
а это переработанный-доработанный мной вариант для "бакэнда"
(выдрал целиком из работающего приложения, описывать лень - разбирайся сам, дополнительные приколы связанные с этим классом - придумывай сам (ну щас я все свои тайны и открыл, и так раззорился... :))))
'НЕ ДЛЯ КОММЕРЧЕСКОГО ИСПОЛЬЗОВАНИЯ!
'DuChan /Черепанов Андрей/duchan@mail.ru/, 2001
Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
Const HKEY_DYN_DATA = &H80000006
Const REG_SZ = 1 ' Unicode nul terminated string
Const REG_BINARY = 3 ' Free form binary
Const REG_DWORD = 4 ' 32-bit number
Const ERROR_SUCCESS = 0&

Const cMAXLEN_BUFFER = 255
Const NORMAL_PRIORITY_CLASS = &H20&
Const INFINITE = -1&

Type STARTUPINFO
cb As Long
lpReserved As String
lpDesktop As String
lpTitle As String
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type

Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessID As Long
dwThreadID As Long
End Type

Declare Function RegCloseKey Lib "advapi32.dll" (Byval hKey As Long) As Long
Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (Byval hKey As Long, Byval lpSubKey As String, phkResult As Long) As Long
Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (Byval hKey As Long, Byval lpValueName As String, Byval lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long

Declare Function WaitForSingleObject Lib "kernel32" (Byval hHandle As Long, Byval dwMilliseconds As Long) As Long
Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (Byval hwnd As Long, Byval lpOperation As String, Byval lpFile As String, Byval lpParameters As String, Byval lpDirectory As String, Byval nShowCmd As Long) As Long
Declare Function CreateProcessA Lib "kernel32" (Byval lpApplicationName As Long, Byval lpCommandLine As String, Byval lpProcessAttributes As Long, Byval lpThreadAttributes As Long, Byval bInheritHandles As Long, Byval dwCreationFlags As Long, _
Byval lpEnvironment As Long, Byval lpCurrentDirectory As Long, lpStartupInfo As STARTUPINFO, lpProcessInformation As PROCESS_INFORMATION) As Long
Declare Function CloseHandle Lib "kernel32" (Byval hObject As Long) As Long

Class RTAttachment
' Свойства
Public Path As String
Public ProcessInfo As PROCESS_INFORMATION

'--------------------
Private ppParent As notesRichTextItem
Private ppEmbeddedObject As notesEmbeddedObject
Private ppIsExtract As Variant
Private ppFileName As String
Private LastModifed As Variant
Private ParentDoc As notesDocument
Private ItemName As String

'-----------------------

Public Property Get Parent As notesRichTextItem
Set Parent = ppParent
End Property

Public Property Get EmbeddedObject As notesEmbeddedObject
Set EmbeddedObject = ppEmbeddedObject
End Property

Public Property Get Source As String
Source = ppEmbeddedObject.Source
End Property

Public Property Get FileSize As Integer
FileSize = ppEmbeddedObject.FileSize
End Property

Public Property Get IsExtract As Variant
IsExtract = ppIsExtract
End Property

Public Property Get FileName As String
FileName = ppFileName
End Property

Public Property Get IsModifed As Variant
NewLastModifed = Filedatetime(Me.Path+Me.FileName)
If NewLastModifed=LastModifed Then
IsModifed=False
Else
IsModifed=True
End If
End Property

' Методы
'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub New(doc As notesDocument, item As String, aName As String)
Set ParentDoc = doc
ItemName = item
Set ppParent = ParentDoc.GetFirstItem(ItemName)
' On Error Goto ErrorCode
Forall Obj In ppParent.EmbeddedObjects
If Obj.Type = EMBED_ATTACHMENT Then
If aName="" Then
Set ppEmbeddedObject = Obj
Exit Forall
Else
If Obj.Source = aName Then
Set ppEmbeddedObject = Obj
Exit Forall
End If
End If
End If
End Forall
If ppEmbeddedObject Is Nothing Then
ErrorCode:
Error 10000,"No Element"
Exit Sub
End If
Me.ppIsExtract = False
Me.Path = Environ$("TEMP")
If Right$(Trim$(filePath),1)<>"\"Then
Me.Path = Me.Path + "\"
End If
End Sub

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub extractFile(newName As String, filePath As String)
If filePath<>"" Then
Me.Path = filePath
End If
If Right$(Trim$(Me.Path),1)<>"\"Then
Me.Path = Me.Path + "\"
End If
If newName="" Then
Me.ppFileName=Me.Source
Else
Me.ppFileName=newName
End If
Call ppEmbeddedObject.ExtractFile(Me.Path+Me.FileName)
ppIsExtract=True
LastModifed = Filedatetime(Me.Path+Me.FileName)
End Sub

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub ExtractAndEdit(newName As String, AutoSave As Variant, Blocked As Variant)
Call ExtractFile(newName,"")
Call Edit( AutoSave, Blocked)
If Blocked Then
If isModifed Then
Call Attach
End If
KillFile
End If
End Sub

Private Function FullPathMake As String
Ext$=Strrightback(FileName,".")
AppStr$ = FindApplication(Ext$)
If Instr(AppStr$,"%1") <>0 Then
FullPath$= Strleft(AppStr$, "%1")+Me.Path+Me.FileName+Strright(AppStr$, "%1")
Elseif Instr(AppStr$,"%L") <>0 Then
FullPath$= Strleft(AppStr$, "%L")+Me.Path+Me.FileName+Strright(AppStr$, "%L")
Else
FullPath$=AppStr$+" "+Me.Path+Me.FileName
End If

FullPath$=Ucase(FullPath$)

If Instr(FullPath$,"%SYSTEMROOT%") <>0 Then
ss$=Environ$("SYSTEMROOT")
FullPath$= Strleft(FullPath$, "%SYSTEMROOT%")+ss$+Strright(FullPath$, "%SYSTEMROOT%")
End If

If Instr(FullPath$,"%TEMP%") <>0 Then
ss$=Environ$("TEMP")
FullPath$= Strleft(FullPath$, "%TEMP%")+ss$+Strright(FullPath$, "%TEMP%")
End If

If Instr(FullPath$,"%PROGRAMFILES%") <>0 Then
ss$=Environ$("PROGRAMFILES")
FullPath$= Strleft(FullPath$, "%PROGRAMFILES%")+ss$+Strright(FullPath$, "%PROGRAMFILES%")
End If
FullPathMake = FullPath$
End Function

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub Edit( AutoSave As Variant, Blocked As Variant)
' Autosave - следить за изменением файла и сохранять сразу после изменения
'Blocked - блокировать ли выполнения Notes
FullPath$ = FullPathMake()
Call ShellAndWait(FullPath$, AutoSave, Blocked)
End Sub

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub Attach
Call Me.Remove
Set ppEmbeddedObject = ppParent.EmbedObject(EMBED_ATTACHMENT, "" , Me.Path+Me.FileName, Me.FileName)
LastModifed = Filedatetime(Me.Path+Me.FileName)
Delete ppEmbeddedObject
Delete ppParent
Call ParentDoc.Save(True,True)
Set ppParent = ParentDoc.GetFirstItem(ItemName)
Forall Obj In ppParent.EmbeddedObjects
If Obj.Type = EMBED_ATTACHMENT Then
If Obj.Source = Me.FileName Then
Set ppEmbeddedObject = Obj
Exit Forall
End If
End If
End Forall
End Sub

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub KillFile
Kill Me.Path+Me.FileName
End Sub

'----------------------------------------------------------------------------------------------------------------------------------------------
Public Sub Remove
Call ppEmbeddedObject.Remove
Call ParentDoc.Save(True,True)
Set ppParent = ParentDoc.GetFirstItem(ItemName)
End Sub

'-----------------------------------------------------------------------------------------------------------------------------------------------------
Private Function GetRegValue ( hKey As Long , strPath As String , strValue As String ) As String
'// Retrieves a value from the Windows registry
'// Called by : Method
'// Calls : none
Dim hCurKey As Long
Dim lResult As Long
Dim lValueType As Long
Dim strBuffer As String
Dim lDataBufferSize As Long
Dim intZeroPos As Integer
Dim lRegResult As Long
GetSettingString = ""
lRegResult = RegOpenKey(hKey, strPath, hCurKey)
lRegResult = RegQueryValueEx(hCurKey, strValue, 0&, lValueType, Byval 0&, lDataBufferSize)
If lRegResult = ERROR_SUCCESS Then
If lValueType <= 2 Then
strBuffer = String(lDataBufferSize, " ")
lResult = RegQueryValueEx(hCurKey, strValue, 0&, 0&, Byval strBuffer, lDataBufferSize)
intZeroPos = Instr(strBuffer, Chr$(0))
If intZeroPos > 0 Then
GetRegValue = Left$(strBuffer, intZeroPos - 1)
Else
GetRegValue = strBuffer
End If
End If
Else
End If
lRegResult = RegCloseKey(hCurKey)
End Function

Private Function FindApplication(Ext As String) As String
Key$=GetRegValue(HKEY_CLASSES_ROOT,"."+Ext,"")
FindApplication = GetRegValue(HKEY_CLASSES_ROOT,Key$+"\shell\open\command","")
End Function

Private Sub ShellAndWait ( Byval RunProg As String, AutoSave As Variant, Blocked As Variant )
'// Starts an external application and wait for the application to end
'// Called by :
'// Calls :
Dim StartInf As STARTUPINFO
StartInf.cb = Len ( StartInf )
RetVal = CreateProcessA ( 0&, RunProg , 0& , 0& , 1&, NORMAL_PRIORITY_CLASS , 0& , 0& , StartInf , ProcessInfo )
If (Not Autosave) And Blocked Then
RetVal = WaitForSingleObject ( ProcessInfo.hProcess , INFINITE )
Else
If AutoSave And Blocked Then
RetVal = 1
While(RetVal<>0)
RetVal = WaitForSingleObject ( ProcessInfo.hProcess , 0 )
If isModifed Then
Call Attach
Print "Save file ["+Me.FileName+"]: "+Cstr(Now)
End If
Wend
RetVal = CloseHandle ( ProcessInfo.hProcess )
End If
End If
'
End Sub

Public Sub Shell
FullPath$ = FullPathMake()
RunS$=Strleft(FullPath$,".EXE") +".EXE"
If Left(RunS$,1)="""" Then RunS$=RunS$+""""
ParamS$ = Strright(FullPath$,".EXE")
If Left(ParamS$,1)="""" Then ParamS$=Right(ParamS$,Len(ParamS$)-1)
' Messagebox RunS$+Chr$(13)+ParamS$
A=ShellExecute(0&,"open",Trim(RunS$), Trim(ParamS$),"",1&)
End Sub
End Class