home *** CD-ROM | disk | FTP | other *** search
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 
