ARRAY function

Purpose:

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

Syntax:

COMObject.Range(A1:B1).Value = ARRAY(A comma separated list of "literal strings" or numbers)

Return Value:

Data type: OBJECT
COMObject.Range(A1:B1).Value , The range of cells in a COM object to be filled with the arguments specified in the parameter list of ARRAY.

Parameters:

Data type: STRING
A comma separated list of "literal strings" or numbers.

Example:

' BCX COM Demos *** com_test4 *** 
' Creates Excel.Application, demonstration of ARRAY keyword. 
' Requirements: MS Excel   
' By Ljubisa Knezevic 

BCX_SHOW_COM_ERRORS(TRUE)

DIM app as OBJECT
COMSET app = CREATEOBJECT("Excel.Application")

app.workbooks.add
app.visible = TRUE
app.ActiveSheet.Range("B2:K2").Value = ARRAY("Week1","Week2", "Week3","Week4", "Week5", "Week6", "Week7", "Week8","Week9", "Week10")
app.ActiveSheet.Range("B3:k3").Value = ARRAY("67", "87", "5", "9", "7", "45", "45", "54", "54", "10")
app.ActiveSheet.Range("B4:k4").Value = ARRAY("10", "10", "8", "27", "33", "37", "50", "54", "10", "10")
app.ActiveSheet.Range("B5:k5").Value = ARRAY("23", "3", "86", "64", "60", "18", "5", "1", "36", "80")

app.ActiveSheet.Cells(3,1).Value="Hello"
app.ActiveSheet.Cells(4,1).Value="From BCX"
app.ActiveSheet.Cells(5,1).Value="Console program!"

DIM temp_var$

temp_var$ = app.ActiveSheet.Cells(3,1).Value
MSGBOX temp_var$, "value of cell(3,1)", 4096

MSGBOX "BCX COM Example!" & CRLF$ & _
       "Using Office automation to manipulate Excel." &CRLF$ & _
       "Program will close Excel in 1 second.","finished!", 4096
SLEEP(1000)
app.activeworkbook.saved = TRUE
app.quit
COMSET app = NOTHING

SAFEARRAY functions

INITSAFEARRAY function

Purpose:

INITSAFEARRAY 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 AS PTR PTR, _
                      variabletype AS VARTYPE, _
                        dimensions AS INTEGER, _
                       lowerbound1 AS INTEGER, _
                 numberofelements1 AS INTEGER, _
                       lowerbound2 AS INTEGER, _
                 numberofelements2 AS INTEGER, _
                                           ...)

Return Value:

Data type: HRESULT
HRslt Contains S_OK, that is, a value of 0, if the function returned successfully. If the function fails, HRslt will be E_OUTOFMEMORY which has a hex value of 0x8007000E.

Parameters:

Data type: PTR PTR
safearrayptr A pointer to a pointer of a SAFEARRAY structure.
Data type: VARTYPE
variabletype The variable type of the array. VT_ARRAY and VT_BYREF flags are not allowed to be set and VT_EMPTY and VT_NULL are not a valid variabletype. All other variable types are legal.
Data type: INTEGER
dimensions The number of dimensions in the array.
Data type: INTEGER
lowerbound1 The lower bound for the first dimension of the array. This value can be negative.
Data type: INTEGER
numberofelements1 The number of elements in the first dimension of the array.
Data type: INTEGER
lowerbound2 The lower bound for the second dimension of the array. This value can be negative.
Data type: INTEGER
numberofelements2 The number of elements in the second dimension of the array.

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 AS PTR, _
                 vardata AS VARTYPE, _
              dimensions AS INTEGER, _
                    dim1 AS INTEGER, _
                    dim2 AS INTEGER, _
                                 ...)

Parameters:

Data type: PTR
safearrayptr A pointer to an SAFEARRAY descriptor created by the INITSAFEARRAY function.
Data type: VARTYPE
vardata The VARIANT storing the data to be assigned to the array.
Data type: INTEGER
dimensions The number of dimensions in the array.
Data type: INTEGER
dim1 The right-most (least significant) dimension of the array where the data is to be assigned.
Data type: INTEGER
dim2 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 AS PTR, _
                 vardata AS VARTYPE, _
              dimensions AS INTEGER, _
                    dim1 AS INTEGER, _
                    dim2 AS INTEGER, _
                                 ...)

Parameters:

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

DESTROYSAFEARRAY function

Purpose:

DESTROYSAFEARRAY destroys a SAFEARRAY structure and all the data in the array.

Syntax:

HRslt = DESTROYSAFEARRAY(safearrayptr)

Return Value:

Data type: HRESULT
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.
Parameters:
- Data type: PTR
  safearrayptr is a pointer to an SAFEARRAY descriptor created by the INITSAFEARRAY function.

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. Please note that the example below requires the Excel_Constants.inc file which is available for download at

https://bcxbasiccoders.com/archives/YahooGroups/Com/Excel_Constants.inc

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$
COMSET 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
COMSET 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"

COMSET 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
  COMSET oDB = CREATEOBJECT("ADOX.Catalog")
  Provider$ = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DBname$
  oDB.Create Provider$
  COMSET oDB = NOTHING
END SUB       ' End CreateAccessDatabase

Part Two: Translate, compile and run the following code in the same directory 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$
COMSET 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$

COMSET 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

COMSET 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"

COMSET 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
COMSET 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

COMSET 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

COMSET 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

COMSET xlCharts = oSheet.ChartObjects()
IF BCX_GET_COM_STATUS(&xlCharts) = FALSE THEN
  MSGBOX "Failed to create xlCharts object"
  CALL SetObjects2Nothing()

  END = 1
END IF

COMSET 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


COMSET 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

COMSET 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
    COMSET oRecSet = NOTHING
  END IF
  IF BCX_GET_COM_STATUS(&oConn) THEN
    oConn.Close
    COMSET oConn = NOTHING
  END IF
  IF BCX_GET_COM_STATUS(&oRange) THEN COMSET oRange = NOTHING
  IF BCX_GET_COM_STATUS(&chartPage) THEN COMSET chartPage = NOTHING
  IF BCX_GET_COM_STATUS(&myChart) THEN COMSET myChart = NOTHING
  IF BCX_GET_COM_STATUS(&xlCharts) THEN COMSET xlCharts = NOTHING
  IF BCX_GET_COM_STATUS(&oSheet) THEN COMSET oSheet = NOTHING
  IF BCX_GET_COM_STATUS(&oBook) THEN COMSET oBook = NOTHING
  IF BCX_GET_COM_STATUS(&oExcel) THEN
    oExcel.Quit
    COMSET 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