Programming Tool Box/SIMS_2.iso/vb_code1/ole_demo/oleacces.bas

BASIC Source File | 1994-01-27 | 13KB | 390 lines

Option Explicit

'Global Constants

Global Const LENGTH_FOR_SIZE = 4
Global Const OBJECT_SIGNATURE = &H1C15
Global Const OBJECT_HEADER_SIZE = 20
Global Const CHECKSUM_SIGNITURE = &HFE05AD00
Global Const CHECKSUM_STRING_SIZE = 4

'PT : Window sizing information for object
'     Used in OBJECTHEADER type
Type PT
    Width As Integer
    Height As Integer
End Type

'OBJECTHEADER : Contains relevant information about object
'
Type OBJECTHEADER
    Signature As Integer         'Type signiture (0x1c15)
    HeaderSize As Integer        'Size of header (sizeof(struct OBJECTHEADER) + cchName + cchClass)
    ObjectType As Long           'OLE Object type code (OT_STATIC, OT_LINKED, OT_EMBEDDED)
    NameLen As Integer           'Count of characters in object name (CchSz(szName) + 1)
    ClassLen As Integer          'Count of characters in class name (CchSz(szClass) + 1)
    NameOffset As Integer        'Offset of object name in structure (sizeof(OBJECTHEADER))
    ClassOffset As Integer       'Offset of class name in structure (ibName + cchName)
    ObjectSize As PT             'Original size of object (see code below for value)
    NameAndClass As String * 255 'Name and class of object
End Type



'Windows kernel function for unique temporary filename
Declare Function GetTempFileName Lib "Kernel" (ByVal cDriveLetter As Integer, ByVal lpPrefixString As String, ByVal wUnique As Integer, ByVal lpTempFileName As String) As Integer

'This DANGEROUS function allows copying data between different variable types
Declare Sub hmemcpy Lib "Kernel" (dest As Any, source As Any, ByVal bytes As Long)

'Checksum function put in DLL for speed
Declare Sub ComputeCheckSum Lib "OLECS.DLL" (CheckSum As Integer, ByVal s As String, ByVal Length As Long)

'Ole declarations
'Comment out if declared elsewhere
Global Const OLE_SAVE_TO_FILE = 11
Global Const OLE_READ_FROM_FILE = 12
Global Const OLE_SAVE_TO_OLE1FILE = 18

Sub CopyAccess1xOleToField (OleObject As Control, FieldObject As Field)
    '
    ' Copies Ole object to Field Control
    ' writing Access 1.x ole storage format.
    ' Useful for cross compatibility with
    ' Access 1.x, but saves object as Ole1.
    '
    ' OleObject   :   Ole2 control to save
    ' FieldObject :   Database field control to write
    '
    Dim FileNumber As Integer
    Dim FileName As String * 255
    Dim OleHeaderString As String
    Dim oh As OBJECTHEADER
    Dim FileBuffer As String
    Dim CheckSum As Integer
    Dim FileLength As Long
    Dim FileOffset As Long
    Dim BufferLength As Integer
    Dim HeaderLength As Integer
    Dim DocumentClass As String
    Dim DocumentName As String
    Dim CheckSumString As String
    Dim CheckSumCompare As String
    Dim Result%

    BufferLength = 5128

    DocumentClass = OleObject.Class
    DocumentName = OleObject.HostName

    'Write ole object to temporary file
    'We do this first in case it fails
    Result% = GetTempFileName(0, "OLE", -1, FileName)
    FileNumber = FreeFile
    Open FileName For Binary As FileNumber
    OleObject.FileNumber = FileNumber
    OleObject.Action = OLE_SAVE_TO_OLE1FILE
    Close FileNumber

    'Create object header
    'The extra 2 for Headersize are the null characters
    oh.Signature = OBJECT_SIGNATURE
    oh.HeaderSize = OBJECT_HEADER_SIZE + Len(DocumentName) + Len(DocumentClass) + 2
    oh.ObjectType = OleObject.OLEType
    oh.NameLen = Len(DocumentName) + 1
    oh.ClassLen = Len(DocumentClass) + 1
    oh.NameOffset = OBJECT_HEADER_SIZE
    oh.ClassOffset = OBJECT_HEADER_SIZE + oh.NameLen
    oh.ObjectSize.Width = OleObject.Width
    oh.ObjectSize.Height = OleObject.Height
    oh.NameAndClass = DocumentName + Chr$(0) + DocumentClass + Chr$(0)

    'Transfer this to a string
    OleHeaderString = String$(oh.HeaderSize, 0)
    Call hmemcpy(ByVal OleHeaderString, oh, oh.HeaderSize)

    'Write this string to Access OLE field
    FieldObject.AppendChunk (OleHeaderString)

    'Initialize Checksum byte
    CheckSum = 0

    'Write ole object from file to Access, calculating checksum
    FileLength = FileLen(FileName)
    Open FileName For Binary As FileNumber
    Do While FileLength > 0

        'Get file buffer
        If BufferLength > FileLength Then
            BufferLength = FileLength
        End If
        FileBuffer = String$(BufferLength, 32)
        Get FileNumber, , FileBuffer

        'Calculate checksum
        Call ComputeCheckSum(CheckSum, FileBuffer, Len(FileBuffer))

        'Write this chunk to access
        FieldObject.AppendChunk (FileBuffer)

        'Decrement file length
        FileLength = FileLength - BufferLength

    Loop

    'Close and kill file
    Close FileNumber
    Kill FileName

    'Write the checksum string:
    CheckSumString = String$(CHECKSUM_STRING_SIZE, 32)
    Call hmemcpy(ByVal CheckSumString, CHECKSUM_SIGNITURE Or CheckSum, CHECKSUM_STRING_SIZE)
    FieldObject.AppendChunk CheckSumString

End Sub

Sub CopyFieldToAccess1xOle (FieldObject As Field, OleObject As Control)
    '
    ' Copies Field Control to Ole Object
    ' reading Access 1.x ole storage format.
    ' Useful for cross compatibility with
    ' Access 1.x.  You would use this
    ' function to read an Ole object
    ' created by Access (1.x) or CopyAccess1xOleToField.
    '
    ' FieldObject :  Database field control to read
    ' OleObject   :  Ole2 control to load
    '
    Dim FileNumber As Integer
    Dim FileName As String * 255
    Dim OleHeaderString As String
    Dim oh As OBJECTHEADER
    Dim FileBuffer As String
    Dim CheckSum As Integer
    Dim FileLength As Long
    Dim FileOffset As Long
    Dim BufferLength As Integer
    Dim HeaderLength As Integer
    Dim DocumentName As String
    Dim DocumentClass As String
    Dim CheckSumString As String
    Dim CheckSumCompare As String
    Dim Result%

    BufferLength = 5128

    'Get first four bytes of the object to determine length of header
    OleHeaderString = FieldObject.GetChunk(0, LENGTH_FOR_SIZE)

    'Copy this to oh structure
    Call hmemcpy(oh, ByVal OleHeaderString, LENGTH_FOR_SIZE)
    HeaderLength = oh.HeaderSize

    'Note: You could test first element of oh for
    '      OBJECT_SIGNATURE here.

    'Now get all of the header
    OleHeaderString = FieldObject.GetChunk(0, HeaderLength)

    'Translate this to OBJECTHEADER structure
    Call hmemcpy(oh, ByVal OleHeaderString, HeaderLength)

    'Note: Now you could check variables in OBJECTHEADER structure.
    '      This is what Access does to display class name without
    '      loading the object into an ole container.

    'Now write the rest of the Access OLE object, minus Checksum bytes,
    'to temporary file
    Result% = GetTempFileName(0, "OLE", -1, FileName)
    FileNumber = FreeFile
    Open FileName For Binary As FreeFile

    FileLength = FieldObject.FieldSize() - HeaderLength - CHECKSUM_STRING_SIZE
    FileOffset = HeaderLength

    'Reset checksum
    CheckSum = 0

    'Loop through file
    Do While FileLength > 0

        If BufferLength > FileLength Then
            BufferLength = FileLength
        End If
        FileBuffer = FieldObject.GetChunk(FileOffset, BufferLength)

        'Calculate checksum
        Call ComputeCheckSum(CheckSum, FileBuffer, Len(FileBuffer))

        'Write to temp file
        Put FileNumber, , FileBuffer

        'Resize FileLength and FileOffset
        FileLength = FileLength - BufferLength
        FileOffset = FileOffset + BufferLength

    Loop

    'Get the Checksum string from Access object
    CheckSumString = FieldObject.GetChunk(FileOffset, CHECKSUM_STRING_SIZE)

    'Create comparison string and compare to string from Access.
    CheckSumCompare = String$(CHECKSUM_STRING_SIZE, 32)
    Call hmemcpy(ByVal CheckSumCompare, CHECKSUM_SIGNITURE Or CheckSum, CHECKSUM_STRING_SIZE)

    'Now compare the strings
    If CheckSumCompare <> CheckSumString Then
        MsgBox ("Checksum failed: " & Asc(Mid$(CheckSumCompare, 1, 1)) & "." & Asc(Mid$(CheckSumCompare, 2, 1)) & "." & Asc(Mid$(CheckSumCompare, 3, 1)) & "." & Asc(Mid$(CheckSumCompare, 4, 1)) & ". vs " & Asc(Mid$(CheckSumString, 1, 1)) & "." & Asc(Mid$(CheckSumCompare, 2, 1)) & "." & Asc(Mid$(CheckSumCompare, 3, 1)) & "." & Asc(Mid$(CheckSumCompare, 4, 1)))
    End If

    'Close temp file
    Close FileNumber

    'Reopen temp file and load into Ole object
    Open FileName For Binary As FileNumber
    OleObject.FileNumber = FileNumber
    OleObject.Action = OLE_READ_FROM_FILE

    'Kill and close the file
    Close FileNumber
    Kill FileName

End Sub

Sub CopyFieldToOle2 (FieldObject As Field, OleObject As Control)
    '
    ' Copies Field Control to Ole Object
    ' reading Ole2 storage format.
    '
    ' FieldObject :  Database field control to read
    ' OleObject   :  Ole2 control to load
    '
    Dim FileNumber As Integer
    Dim FileName As String * 255
    Dim FileBuffer As String
    Dim FileLength As Long
    Dim FileOffset As Long
    Dim BufferLength As Integer
    Dim Result%

    BufferLength = 5128

    'Write Ole object from Access field to file
    'to temporary file
    Result% = GetTempFileName(0, "OLE", -1, FileName)
    FileNumber = FreeFile
    Open FileName For Binary As FreeFile

    FileLength = FieldObject.FieldSize()
    FileOffset = 0

    'Loop through file
    Do While FileLength > 0

        'Fill buffer from field
        If BufferLength > FileLength Then
            BufferLength = FileLength
        End If
        FileBuffer = FieldObject.GetChunk(FileOffset, BufferLength)

        'Write to temp file
        Put FileNumber, , FileBuffer

        'Resize FileLength and FileOffset
        FileLength = FileLength - BufferLength
        FileOffset = FileOffset + BufferLength

    Loop

    'Close temp file
    Close FileNumber

    'Reopen temp file and load into Ole object
    Open FileName For Binary As FileNumber
    OleObject.FileNumber = FileNumber
    OleObject.Action = OLE_READ_FROM_FILE

    'Kill and close the file
    Close FileNumber
    Kill FileName

End Sub

Sub CopyOle2ToField (OleObject As Control, FieldObject As Field)
    '
    ' Copies Ole object to Field Control
    ' writing Ole2 fstorage ormat.  Access would not
    ' be able to activate the object.
    '
    ' OleObject   :   Ole2 control to save
    ' FieldObject :   Database field control to write
    '
    Dim FileNumber As Integer
    Dim FileName As String * 255
    Dim FileBuffer As String
    Dim FileLength As Long
    Dim FileOffset As Long
    Dim BufferLength As Integer
    Dim Result%

    BufferLength = 5128

    'Write ole object to temporary file
    'We do this first in case it fails
    Result% = GetTempFileName(0, "OLE", -1, FileName)
    FileNumber = FreeFile
    Open FileName For Binary As FileNumber
    OleObject.FileNumber = FileNumber
    OleObject.Action = OLE_SAVE_TO_FILE
    Close FileNumber


    'Write ole object from file to field object
    FileLength = FileLen(FileName)
    Open FileName For Binary As FileNumber
    Do While FileLength > 0

        'Get file buffer
        If BufferLength > FileLength Then
            BufferLength = FileLength
        End If
        FileBuffer = String$(BufferLength, 32)
        Get FileNumber, , FileBuffer

        'Write this chunk to field
        FieldObject.AppendChunk (FileBuffer)

        'Decrement file length
        FileLength = FileLength - BufferLength

    Loop

    'Close and kill file
    Close FileNumber
    Kill FileName

End Sub

Sub VBComputeCheckSum (CheckSum As Integer, ByVal s As String, ByVal Length As Long)
    '
    ' Calculates Checksum of Access Ole Object.
    ' It is highly recommended that the DLL version
    ' of this function (ComputeCheckSum) be used instead.
    ' The difference in execution speed is phenomenal.
    ' Although the last parameter (Length) is redundant,
    ' it's included so that the arguments are identical
    ' to the DLL version.
    '
    ' Checksum :  Stores the passed and calculated checksum
    ' s        :  String used to perform checksum
    ' Length   :  Length of string used to perform checksum
    '
    Dim l As Long

    For l = 1 To Length
        CheckSum = CheckSum Xor Asc(Mid$(s, l, 1))
    Next

End Sub