COM Arrays

ARRAY function

Purpose: ARRAY will fill a range of rows and columns in a COM object with values from a comma separated string.

Syntax:


 COMobj.Range(A1:B1).Value = ARRAY("LiteralString", Number)

Parameters:

"LiteralString", Number a comma separated list of literal strings or numbers.

Return Value:

COMobj.Range(A1:B1).Value, specifies the range of cells in a COM object to be filled with the arguments specified in the parameter list of ARRAY.

Example:


 BCX_SHOW_COM_ERRORS(TRUE)
 
 $INCLUDE "Excel_Constants.INC"
 
 DIM sSaveAsFile$
 
 DIM oExcel AS OBJECT
 DIM oBook AS OBJECT
 DIM oSheet AS OBJECT
 DIM oRange AS OBJECT
 
 DIM xlCharts AS OBJECT
 DIM myChart AS OBJECT
 DIM chartPage AS OBJECT
 
 sSaveAsFile$ = APPEXEPATH$ & "chart_demo.xls"
 
 'Start a new workbook in Excel
 SET oExcel = CREATEOBJECT("Excel.Application")
 SET oBook = oExcel.Workbooks.Add
 SET oSheet = oBook.Worksheets(1)
 
 oSheet.Range("A1:D1").Value = ARRAY("","Student1","Student2","Student3")
 oSheet.Range("A2:D2").Value = ARRAY("Term1",80,65,45)
 oSheet.Range("A3:D3").Value = ARRAY("Term2",78,72,60)
 oSheet.Range("A4:D4").Value = ARRAY("Term3",82,80,65)
 oSheet.Range("A5:D5").Value = ARRAY("Term4",75,82,68)
 
 
 SET xlCharts = oSheet.ChartObjects()
 SET myChart = xlCharts.Add(10, 80, 300, 250)
 SET chartPage = myChart.Chart
 SET oRange = oSheet.Range("A1:D5")
 
 chartPage.SetSourceData(oRange, xlColumns)
 chartPage.ChartType = xlColumnClustered
 
 MSGBOX "File will be saved at " & sSaveAsFile$,"BCX Excel Chart Demo",64
 oBook.SaveAs sSaveAsFile$
 
 oExcel.Quit
 
 SET chartPage = NOTHING
 SET myChart = NOTHING
 SET xlCharts = NOTHING
 SET oRange = NOTHING
 SET oSheet = NOTHING
 SET oBook = NOTHING
 SET oExcel = NOTHING

SAFEARRAY functions

INITSAFEARRAY function

Purpose: Creates a SAFEARRAY structure, allocates and initializes the data for the array and passes, by reference, a pointer to the new SAFEARRAY structure.

In the Syntax description below, two dimensions are used as an example. However, up to ten dimensions can be specified when using the INITSAFEARRAY function.

Syntax:


 HRslt = INITSAFEARRAY(safearrayptr, variabletype, dimensions, lowerbound1, numberofelements1, lowerbound2, numberofelements2, ...)

Parameters:

safearrayptr is a pointer to a pointer of a SAFEARRAY structure.
variabletype specifies the base type (VARTYPE) of the array. The variabletype does not allow the VT_ARRAY and VT_BYREF flags to be set and VT_EMPTY and VT_NULL are not a valid variabletype for the array. All other variable types are legal.
dimensions specifies the number of dimensions in the array.
lowerbound1 specifies the lower bound for the first dimension of the array. This value can be negative.
numberofelements1 specifies the number of elements in the first dimension of the array.
lowerbound2 specifies the lower bound for the second dimension of the array. This value can be negative.
numberofelements2 specifies the number of elements in the second dimension of the array.

Return Value:

HRslt is an HRESULT which will contain S_OK, that is a value of 0, if the function returned successfully. If the function fails, the return value will be E_OUTOFMEMORY which has a hex value of 0x8007000E.

ARRAYPUTELEMENT function

Purpose: ARRAYPUTELEMENT assigns a single element to the array.

In the Syntax description below, two dimensions are used as an example. However, up to ten dimensions can be specified when using the ARRAYPUTELEMENT function.

Syntax:


 ARRAYPUTELEMENT(safearrayptr, vardata, dimensions, dim1, dim2, ...)

Parameters:

safearrayptr is a pointer to an SAFEARRAY descriptor created by the INITSAFEARRAY function.
vardata specifies a VARIANT storing the data to be assigned to the array.
dimensions specifies the number of dimensions in the array.
dim1 specifies the right-most (least significant) dimension of the array where the data is to be assigned.
dim2 specifies the next-most significant dimension of the array where the data is to be assigned.

ARRAYGETELEMENT function

Purpose: ARRAYGETELEMENT retrieves a single element from the array.

In the Syntax description below, two dimensions are used as an example. However, up to ten dimensions can be specified when using the ARRAYGETELEMENT function.

Syntax:


 ARRAYGETELEMENT(safearrayptr, vardata, dimensions, dim1, dim2, ...)

Parameters:

safearrayptr is a pointer to an SAFEARRAY descriptor created by the INITSAFEARRAY function.
vardata specifies the location of a VARIANT in which to place the retrieved element of the array.
dimensions specifies the number of dimensions in the array.
dim1 specifies the right-most (least significant) dimension of the array where the data is to be retrieved.
dim2 specifies the next-most significant dimension of the array where the data is to be retrieved.

DESTROYSAFEARRAY function

Purpose: destroys a SAFEARRAY structure and all the data in the array.

Syntax:


 HRslt = DESTROYSAFEARRAY(safearrayptr)

Parameters:

safearrayptr is a pointer to an SAFEARRAY descriptor created by the INITSAFEARRAY function.

Return Value:

HRslt can return
- S_OK if the function has succeded
- DISP_E_ARRAYISLOCKED if the array is currently locked.
- E_INVALIDARG if the item pointed to by safearrayptr is not a safearray descriptor.

Example: This example contains two parts. The first part creates a Microsoft Access database in which data will be created for retrieval by the second part of the example. The second part of the example will retrieve the data and place it in a Microsoft Excel spreadsheet.

Part One: Translate, compile and run the following code.


 BCX_SHOW_COM_ERRORS(TRUE)
 
 DIM szDatabase$
 DIM oConn AS OBJECT
 DIM rs AS OBJECT
 DIM Provider$
 DIM Sql$
 
 'Create Database
 szDatabase$ = APPEXEPATH$ & "MYDB.MDB"
 IF EXIST(szDatabase$) THEN KILL szDatabase$
 CreateAccessDatabase (szDatabase$)
 
 
 'Connect to Database
 Provider$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & szDatabase$
 SET oConn = CREATEOBJECT("ADODB.Connection")
 oConn.OPEN Provider$
 
 ' Create Student table
 Sql$ = "CREATE TABLE tblStudents (Student_Number COUNTER PRIMARY KEY, FirstName TEXT(24), LastName TEXT(24), Address TEXT(30), City TEXT(28), State TEXT(2), ZipCode TEXT(5))"
 oConn.Execute Sql$
 
 ' Create Grades table
 Sql$ = "CREATE TABLE tblGrades (Student_Number INT, Semester INT, Score INT)"
 oConn.Execute Sql$
 
 ' Add students
 Sql$ = "INSERT INTO tblStudents (FirstName, LastName, Address, City, State, ZipCode ) VALUES ('Larry', 'Stooge', 'Address', 'City', 'St', 'Zip')"
 oConn.Execute Sql$
 
 Sql$ = "INSERT INTO tblStudents (FirstName, LastName, Address, City, State, ZipCode ) VALUES ('Moe', 'Stooge', 'Address', 'City', 'St', 'Zip')"
 oConn.Execute Sql$
 
 Sql$ = "INSERT INTO tblStudents (FirstName, LastName, Address, City, State, ZipCode ) VALUES ('Curly', 'Stooge', 'Address', 'City', 'St', 'Zip')"
 oConn.Execute Sql$
 
 ' Add some grades
 SET rs = CREATEOBJECT("ADODB.recordset")
 
 rs.OPEN "SELECT FirstName, LastName, Student_Number FROM tblStudents", oConn, 3, 3
 
 DIM A$
 DIM B$
 DIM C$
 DIM D$
 DIM rc
 DIM i
 DIM j
 DO
   rc = rs.EOF
   IF rc <> 0 THEN EXIT LOOP
   C$ = rs.fields("Student_Number")
   C$ = ENC$(C$,ASC("'"))
   FOR i = 1 TO 4
         j = 70 + 30 * RND
     A$ = ENC$(STR$(i),ASC("'"))
     B$ = ENC$(STR$(j),ASC("'"))
       Sql$ = "INSERT INTO tblGrades (Student_Number, Semester, Score) VALUES (" & C$ & "," & A$ & "," & B$ & ")"
         oConn.Execute Sql$
   NEXT
   rs.movenext
 LOOP
 
 rs = NOTHING
 
 'show the data that was put into the database
 DIM sSelectSQL$
 sSelectSQL$ = "SELECT tblStudents.FirstName, tblStudents.LastName, tblGrades.Semester, tblGrades.Score "
 sSelectSQL$ = sSelectSQL$ & "FROM tblGrades INNER JOIN tblStudents ON tblGrades.Student_Number = tblStudents.Student_Number "
 sSelectSQL$ = sSelectSQL$ & "ORDER BY tblStudents.FirstName, tblStudents.LastName, tblGrades.Semester"
 
 SET rs = CREATEOBJECT("ADODB.recordset")
 rs.OPEN sSelectSQL$, oConn, 3, 3
 
 DO
   rc = rs.EOF
   IF rc <> 0 THEN EXIT LOOP
   A$ = rs.fields("FirstName")
   B$ = rs.fields("LastName")
   C$ = rs.fields("Semester")
   D$ = rs.fields("Score")
   PRINT A$;" ";B$;"   Semester ";C$;"  Score ";D$
   rs.movenext
 LOOP
 
 ' Clean up
 rs = NOTHING
 oConn = NOTHING
 
 PAUSE
 
 
 SUB CreateAccessDatabase (DBname$)
   RAW Provider$
   RAW oDB AS OBJECT
   SET oDB = CREATEOBJECT("ADOX.Catalog")
   Provider$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBname$
   oDB.Create Provider$
   SET oDB = Nothing
 END SUB       ' End CreateAccessDatabase

Part Two: Translate, compile and run the following code in the same folder as Part One.


 BCX_SHOW_COM_ERRORS(TRUE)
 
 $INCLUDE "Excel_Constants.INC"
 
 DIM sDest$
 DIM szDatabase$
 DIM oConn as OBJECT
 DIM oRecSet as OBJECT
 DIM sProvider$
 DIM iCols
 DIM iRows
 'Connect to Database
 szDatabase$ = APPEXEPATH$ & "MYDB.MDB"
 sProvider$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & szDatabase$
 SET oConn = CREATEOBJECT("ADODB.Connection")
 IF BCX_GET_COM_STATUS(&oConn) = FALSE THEN
   MSGBOX "Failed to create oConn object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 oConn.Open sProvider$
 
 SET oRecSet = CREATEOBJECT("ADODB.recordset")
 IF BCX_GET_COM_STATUS(&oRecSet) = FALSE THEN
   MSGBOX "Failed to create oRecSet object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 oRecSet.Open "SELECT * FROM tblStudents", oConn, 3, 3
 iCols = oRecSet.recordcount
 iCols++
 oRecSet = NOTHING
 
 SET oRecSet = CREATEOBJECT("ADODB.recordset")
 IF BCX_GET_COM_STATUS(&oRecSet) = FALSE THEN
   MSGBOX "Failed to create oRecSet object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 oRecSet.Open "SELECT Max(tblGrades.Semester) AS MaxOfSemester FROM tblGrades;", oConn, 3, 3
 iRows = oRecSet.fields("MaxOfSemester")
 iRows++
 oRecSet = NOTHING
 
 DIM psA AS SAFEARRAY PTR
 DIM hRET AS HRESULT
 DIM vArray AS VARIANT
 DIM pVariant AS VARIANT PTR
 DIM lComVariant AS VARIANT
 DIM sBuf$
 
 hRET = INITSAFEARRAY(psA, VT_VARIANT, 2, 0, iRows, 0, iCols)
 IF hRET THEN
   CALL Error(hRET)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 ' Set the safe arraydescriptor in VARIANT
 vArray.vt = VT_ARRAY | VT_VARIANT
 vArray.parray = psA
 
 ' SafeArrayAccessData
 hRET = SafeArrayAccessData(psA, (VOID PTR PTR)&pVariant)
 IF hRET THEN
   CALL Error(hRET)
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 ' Get data values for the safe array
 DIM sSelectSQL$
 sSelectSQL$ = "SELECT tblStudents.Student_Number, tblStudents.FirstName, tblStudents.LastName, tblGrades.Semester, tblGrades.Score "
 sSelectSQL$ = sSelectSQL$ & "FROM tblGrades INNER JOIN tblStudents ON tblGrades.Student_Number = tblStudents.Student_Number "
 sSelectSQL$ = sSelectSQL$ & "ORDER BY tblStudents.FirstName, tblStudents.LastName, tblGrades.Semester"
 
 SET oRecSet = CREATEOBJECT("ADODB.recordset")
 IF BCX_GET_COM_STATUS(&oRecSet) = FALSE THEN
   MSGBOX "Failed to create oRecSet object"
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
   END = 1
 END IF
 oRecSet.Open sSelectSQL$, oConn, 3, 3
 
 DIM iCol
 DIM iRow
 DIM iRecSetFlag
 DIM iSN
 DIM iLastSN
 DIM sFioRecSettName$
 DIM sLastName$
 DIM iScore
 
 iCol = 0
 iLastSN = 0
 
 DO
   iRecSetFlag = oRecSet.EOF
   If iRecSetFlag <> 0 Then Exit Loop    ' VARIANT_BOOL returns -1  for FALSE
   iSN = oRecSet.fields("Student_Number")
   IF iSN <> iLastSN THEN
     iLastSN = iSN
     iCol++
     sFioRecSettName$ = oRecSet.fields("FirstName")
     sLastName$ = oRecSet.fields("LastName")
     sBuf$ = sFioRecSettName$ & " " & sLastName$
     str2variant(sBuf,lComVariant)
     ARRAYPUTELEMENT(psA,lComVariant, 2, 0, iCol)
   END IF
 
   iRow = oRecSet.fields("Semester")
   iScore = oRecSet.fields("Score")
   lComVariant.vt = VT_I4
   lComVariant.intVal = iScore
   ARRAYPUTELEMENT(psA,lComVariant, 2, iRow, iCol)
   ARRAYGETELEMENT(psA,lComVariant, 2, iRow, 0)
   IF lComVariant.vt <> VT_BSTR THEN
     sBuf$ = "Semester" & STR$(iRow)
     str2variant(sBuf,lComVariant)
     ARRAYPUTELEMENT(psA,lComVariant, 2, iRow, 0)
   END IF
 
   oRecSet.movenext
 LOOP
 
 oConn.Close
 oRecSet = NOTHING
 oConn = NOTHING
 
 hRET = SafeArrayUnaccessData(psA)
 IF hRET THEN
   CALL Error(hRET)
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 DIM oExcel AS Object
 DIM oBook AS Object
 DIM oSheet AS Object
 DIM oRange AS OBJECT
 
 DIM xlCharts AS OBJECT
 DIM myChart AS OBJECT
 DIM chartPage AS OBJECT
 
 DIM sSaveAs$
 
 'Start a new workbook in Excel
 SET oExcel = CREATEOBJECT("Excel.Application")
 IF BCX_GET_COM_STATUS(&oExcel) = FALSE THEN
   MSGBOX "Failed to create oExcel object"
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 SET oBook = oExcel.Workbooks.Add
 IF BCX_GET_COM_STATUS(&oBook) = FALSE THEN
   MSGBOX "Failed to create oBook object"
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 SET oSheet = oBook.Worksheets(1)
 IF BCX_GET_COM_STATUS(&oSheet) = FALSE THEN
   MSGBOX "Failed to create oSheet object"
   DESTROYSAFEARRAY(psA)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 DIM iC1, iC2
 
 iC1 = IMOD((iCols-1),26)
 iC2 = (iCols-1) / 26
 
 IF iC2 = 0 THEN
   sDest$ = "A1:" & CHR$(iC1+65) & TRIM$(STR$(iRows))
 ELSE
   sDest$ = "A1:" & CHR$(iC2+65) & CHR$(iC1+65) & TRIM$(STR$(iRows))
 END IF
 
 oSheet.Range(sDest$).Value = vArray  'psA '
 oSheet.Range(sDest$).ColumnWidth = 11
 
 SET xlCharts = oSheet.ChartObjects()
 IF BCX_GET_COM_STATUS(&xlCharts) = FALSE THEN
   MSGBOX "Failed to create xlCharts object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 SET myChart = xlCharts.Add(10, 80, 300, 250)
 IF BCX_GET_COM_STATUS(&myChart) = FALSE THEN
   MSGBOX "Failed to create myChart object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 
 
 SET chartPage = myChart.Chart
 IF BCX_GET_COM_STATUS(&chartPage) = FALSE THEN
   MSGBOX "Failed to create chartPage object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 'SET chartPage = NOTHING
 
 SET oRange = oSheet.Range(sDest$)
 IF BCX_GET_COM_STATUS(&oRange) = FALSE THEN
   MSGBOX "Failed to create oRange object"
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 'SET oRange = NOTHING
 
 
 chartPage.SetSourceData(oRange, xlColumns)
 chartPage.ChartType = xlColumnClustered
 
 'Save the Workbook and Quit Excel
 
 sSaveAs$ = APPEXEPATH$ & "CHART_FROM_ACCESS.XLS"
 oBook.SaveAs sSaveAs$
 
 CALL SetObjects2Nothing()
 
 ' Free SafeArray
 hRET = DESTROYSAFEARRAY(psA)
 IF hRET THEN
   CALL Error(hRET)
   CALL SetObjects2Nothing()
 
   END = 1
 END IF
 END = 0
 
 SUB SetObjects2Nothing()
   IF BCX_GET_COM_STATUS(&oRecSet) THEN
     oConn.Close
     SET oRecSet = NOTHING
   END IF
   IF BCX_GET_COM_STATUS(&oConn) THEN
     oConn.Close
     SET oConn = NOTHING
   END IF
   IF BCX_GET_COM_STATUS(&oRange) THEN SET oRange = NOTHING
   IF BCX_GET_COM_STATUS(&chartPage) THEN SET chartPage = NOTHING
   IF BCX_GET_COM_STATUS(&myChart) THEN SET myChart = NOTHING
   IF BCX_GET_COM_STATUS(&xlCharts) THEN SET xlCharts = NOTHING
   IF BCX_GET_COM_STATUS(&oSheet) THEN SET oSheet = NOTHING
   IF BCX_GET_COM_STATUS(&oBook) THEN SET oBook = NOTHING
   IF BCX_GET_COM_STATUS(&oExcel) THEN
     oExcel.Quit
     SET oExcel = NOTHING
   END IF
 END SUB
 
 SUB DEBUGLOGGER(sDEBUG$)
   OPEN "ERROR.LOG.TXT" FOR APPEND AS FPAPP
   FPRINT FPAPP, sDEBUG$
   CLOSE
 END SUB
 
 SUB Error(hError AS HRESULT)
 
   SELECT CASE hError
 
     CASE S_OK
       '"Success."
 
     CASE DISP_E_BADINDEX
       DEBUGLOGGER("The specified index was invalid.")
 
     CASE E_INVALIDARG
       DEBUGLOGGER("One of the arguments is invalid.")
 
     CASE E_OUTOFMEMORY
       DEBUGLOGGER("Memory could not be allocated for the element.")
 
     CASE DISP_E_ARRAYISLOCKED
       DEBUGLOGGER("The array is currently locked.")
 
     CASE ELSE
       RAW sBUF$
       sprintf(sBUF,"Error %i (0x%X)",hError,hError)
       DEBUGLOGGER(sBUF)
 
   END SELECT
 
 END SUB