home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code1
/
oletools
/
oletools.bas
< prev
Wrap
BASIC Source File
|
1993-12-27
|
5KB
|
181 lines
Option Explicit
Const OLE_SAVE_TO_FILE = 11
Const OLE_READ_FROM_FILE = 12
Const BuffSize = 1024 * 16
Function CopyOLEData (SourceOLE As OLE, TargetOLE As OLE) As Integer
Dim FileNum As Integer
Dim OLESize As Long
Dim FileName As String
CopyOLEData = True
FileName = TempOLEFileName()
On Error GoTo CopyOLEData_CantWriteTemp
FileNum = FreeFile
Open FileName For Binary As #FileNum
SourceOLE.FileNumber = FileNum
SourceOLE.Action = OLE_SAVE_TO_FILE
Close #FileNum
OLESize = FileLen(FileName)
On Error GoTo CopyOLEData_CantReadFromTemp
FileNum = FreeFile
Open FileName For Binary As #FileNum
TargetOLE.FileNumber = FileNum
TargetOLE.Action = OLE_READ_FROM_FILE
Close #FileNum
On Error GoTo CopyOLEData_CouldntKillTemp:
Kill FileName
Exit Function
' ##### ERROR HANDLER #####
CopyOLEData_CantWriteTemp:
Debug.Print "ERROR: CopyOLEData_CantWriteTemp - " & Error$
CopyOLEData = False
Exit Function
CopyOLEData_CantReadFromTemp:
Debug.Print "ERROR: CopyOLEData_CantReadFromTemp - " & Error$
CopyOLEData = False
Exit Function
CopyOLEData_CouldntKillTemp:
Debug.Print "ERROR: CopyOLEData_TempNotFound - " & Error$
CopyOLEData = False
Exit Function
End Function
Function DBField2OLEObj (TheField As Field, OLE1 As OLE) As Integer
Dim FileNum As Integer
Dim OLESize As Long
Dim Buffer As String
Dim Offset As Long
Dim FileName As String
Dim RestLen As Long
DBField2OLEObj = True
FileName = TempOLEFileName()
OLESize = TheField.FieldSize()
FileNum = FreeFile
On Error GoTo DbField2OLEObj_CouldntWriteTemp
Open FileName For Binary As #FileNum
RestLen = OLESize
Offset = 0
While RestLen > BuffSize
Buffer = ""
Buffer = TheField.GetChunk(Offset, BuffSize)
If Len(Buffer) <> BuffSize GoTo DbField2OLEObj_InvalidGetChunkLen
On Error GoTo DbField2OLEObj_CouldntWriteTemp
Put FileNum, , Buffer
RestLen = RestLen - BuffSize
Offset = Offset + BuffSize
Wend
Buffer = ""
Buffer = TheField.GetChunk(Offset, RestLen)
If Len(Buffer) <> RestLen GoTo DbField2OLEObj_InvalidGetChunkLen
On Error GoTo DbField2OLEObj_CouldntWriteTemp
Put FileNum, , Buffer
Close FileNum
FileNum = FreeFile
Open FileName For Binary As #FileNum
OLE1.FileNumber = FileNum
OLE1.Action = OLE_READ_FROM_FILE
Close #FileNum
On Error GoTo DbField2OLEObj_CouldntKillTemp:
Kill FileName
Exit Function
' ##### ERROR HANDLERS #####
DbField2OLEObj_InvalidGetChunkLen:
Debug.Print "ERROR: DbField2OLEObj_InvalidGetChunkLen - " & "GetChunk returned invalid len!"
DBField2OLEObj = False
Exit Function
DbField2OLEObj_CouldntWriteTemp:
Debug.Print "ERROR: DbField2OLEObj_CouldntWriteTemp - " & Error$
DBField2OLEObj = False
Exit Function
DbField2OLEObj_CouldntKillTemp:
Debug.Print "ERROR: DbField2OLEObj_TempNotFound - " & Error$
DBField2OLEObj = False
Exit Function
End Function
Function OLEObj2DbField (OLE1 As OLE, TheField As Field) As Integer
Dim FileNum As Integer
Dim OLESize As Long
Dim FileName As String
Dim RestLen As Long
Dim Buffer As String
Dim DbgOLESize As Long
OLEObj2DbField = True
FileName = TempOLEFileName()
On Error GoTo OLEObj2DbField_CantCreateTemp
FileNum = FreeFile
Open FileName For Binary As #FileNum
OLE1.FileNumber = FileNum
On Error GoTo OLEObj2DbField_DiskSpace
OLE1.Action = OLE_SAVE_TO_FILE
Close #FileNum
OLESize = FileLen(FileName)
FileNum = FreeFile
On Error GoTo OLEObj2DbField_CantCreateTemp
Open FileName For Binary As #FileNum
RestLen = OLESize
While RestLen > BuffSize
Buffer = String$(BuffSize, 32)
Get FileNum, , Buffer
TheField.AppendChunk (Buffer)
RestLen = RestLen - BuffSize
Wend
Buffer = String$(RestLen, 32)
Get FileNum, , Buffer
TheField.AppendChunk (Buffer)
DbgOLESize = TheField.FieldSize()
Close FileNum
On Error GoTo OLEObj2DbField_CouldntKillTemp
Kill FileName
Exit Function
' ##### ERROR HANDLER #####
OLEObj2DbField_CantCreateTemp:
Debug.Print "ERROR: OLEObj2DbField_CantCreateTemp - " & Error$
OLEObj2DbField = False
Exit Function
OLEObj2DbField_DiskSpace:
Debug.Print "ERROR: OLEObj2DbField_DiskSpace - " & Error$
OLEObj2DbField = False
Exit Function
OLEObj2DbField_CantOpenTemp:
Debug.Print "ERROR: OLEObj2DbField_TempNotFound - " & Error$
OLEObj2DbField = False
Exit Function
OLEObj2DbField_CouldntKillTemp:
Debug.Print "ERROR: OLEObj2DbField_TempNotFound - " & Error$
OLEObj2DbField = False
Exit Function
End Function
Function TempOLEFileName () As String
TempOLEFileName = App.Path + "\$OLETMP$.TMP"
End Function