-
Notifications
You must be signed in to change notification settings - Fork 83
Expand file tree
/
Copy pathArrayResizer.vb
More file actions
235 lines (191 loc) · 8.44 KB
/
Copy pathArrayResizer.vb
File metadata and controls
235 lines (191 loc) · 8.44 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
Imports System.Collections.Generic
Imports ExcelDna.Integration
Imports ExcelDna.Integration.XlCall
Namespace AsyncFunctions
' This class defines a few test functions that can be used to explore the automatic array resizing.
Public Module ResizeTestFunctions
' Just returns an array of the given size
Public Function dnaMakeArray(rows As Integer, columns As Integer) As Object
Dim result As Object(,) = New Object(rows - 1, columns - 1) {}
For i As Integer = 0 To rows - 1
For j As Integer = 0 To columns - 1
result(i, j) = i + j
Next
Next
Return result
End Function
Public Function dnaMakeArrayDoubles(rows As Integer, columns As Integer) As Double(,)
Dim result As Double(,) = New Double(rows - 1, columns - 1) {}
For i As Integer = 0 To rows - 1
For j As Integer = 0 To columns - 1
result(i, j) = i + (j / 1000.0)
Next
Next
Return result
End Function
' Makes an array, but automatically resizes the result
Public Function dnaMakeArrayAndResize(rows As Integer, columns As Integer) As Object
Dim result As Object = dnaMakeArray(rows, columns)
' Can also call Resize via Excel - so if the Resize add-in is not part of this code, it should still work
' (though calling direct is better for large arrays - it prevents extra marshaling).
' Return XlCall.Excel(XlCall.xlUDF, "Resize", result)
Return ArrayResizer.dnaResize(result)
End Function
Public Function dnaMakeArrayAndResizeDoubles(rows As Integer, columns As Integer) As Double(,)
Dim result As Double(,) = dnaMakeArrayDoubles(rows, columns)
' Call Resize via Excel - so if the Resize add-in is not part of this code, it should still work.
Return ArrayResizer.dnaResizeDoubles(result)
End Function
End Module
Public Module ArrayResizer
' This function will run in the UDF context.
' Needs extra protection to allow multithreaded use.
Public Function dnaResize(array As Object(,)) As Object
Dim caller As ExcelReference = TryCast(Excel(xlfCaller), ExcelReference)
If caller Is Nothing Then
Return array
End If
Dim rows As Integer = array.GetLength(0)
Dim columns As Integer = array.GetLength(1)
If rows = 0 OrElse columns = 0 Then
Return array
End If
' Nothing to do if Excel already supports Dynamic Arrays, and we get a single cell caller
If UtilityFunctions.dnaSupportsDynamicArrays() AndAlso caller.RowFirst = caller.RowLast AndAlso caller.ColumnFirst = caller.ColumnLast Then
Return array
End If
If (caller.RowLast - caller.RowFirst + 1 = rows) AndAlso (caller.ColumnLast - caller.ColumnFirst + 1 = columns) Then
' Size is already OK - just return result
Return array
End If
Dim rowLast = caller.RowFirst + rows - 1
Dim columnLast = caller.ColumnFirst + columns - 1
If rowLast > ExcelDnaUtil.ExcelLimits.MaxRows - 1 OrElse columnLast > ExcelDnaUtil.ExcelLimits.MaxColumns - 1 Then
' Can't resize - goes beyond the end of the sheet - just return #VALUE
' (Can't give message here, or change cells)
Return ExcelError.ExcelErrorValue
End If
' TODO: Add guard for ever-changing result?
ExcelAsyncUtil.QueueAsMacro(
Sub()
' Create a reference of the right size
Dim target = New ExcelReference(caller.RowFirst, rowLast, caller.ColumnFirst, columnLast, caller.SheetId)
' Will trigger a recalc by writing formula
DoResize(target)
End Sub)
' Return what we have - to prevent flashing #N/A
Return array
End Function
Public Function dnaResizeDoubles(array As Double(,)) As Double(,)
' Nothing to do if Excel already supports Dynamic Arrays
If UtilityFunctions.dnaSupportsDynamicArrays() Then
Return array
End If
Dim caller As ExcelReference = TryCast(Excel(xlfCaller), ExcelReference)
If caller Is Nothing Then
Return array
End If
Dim rows As Integer = array.GetLength(0)
Dim columns As Integer = array.GetLength(1)
If rows = 0 OrElse columns = 0 Then
Return array
End If
If (caller.RowLast - caller.RowFirst + 1 = rows) AndAlso (caller.ColumnLast - caller.ColumnFirst + 1 = columns) Then
' Size is already OK - just return result
Return array
End If
Dim rowLast = caller.RowFirst + rows - 1
Dim columnLast = caller.ColumnFirst + columns - 1
If rowLast > ExcelDnaUtil.ExcelLimits.MaxRows - 1 OrElse columnLast > ExcelDnaUtil.ExcelLimits.MaxColumns - 1 Then
' Can't resize - goes beyond the end of the sheet - just return null (for #NUM!)
' (Can't give message here, or change cells)
Return Nothing
End If
' TODO: Add guard for ever-changing result?
ExcelAsyncUtil.QueueAsMacro(
Sub()
' Create a reference of the right size
Dim target = New ExcelReference(caller.RowFirst, rowLast, caller.ColumnFirst, columnLast, caller.SheetId)
' Will trigger a recalc by writing formula
DoResize(target)
End Sub)
' Return what we have - to prevent flashing #N/A
Return array
End Function
Private Sub DoResize(target As ExcelReference)
' Get the current state for reset later
Dim oldEcho As Object = Excel(xlfGetWorkspace, 40)
Dim oldCalculationMode As Object = Excel(xlfGetDocument, 14)
Try
Excel(xlcEcho, False)
Excel(xlcOptionsCalculation, 3)
Dim firstCell As New ExcelReference(target.RowFirst, target.RowFirst, target.ColumnFirst, target.ColumnFirst, target.SheetId)
' Get the formula in the first cell of the target
Dim formula As String = DirectCast(Excel(xlfGetCell, 41, firstCell), String)
Dim isFormulaArray As Boolean = CBool(Excel(xlfGetCell, 49, firstCell))
If isFormulaArray Then
Dim oldSelectionOnActiveSheet As Object = Excel(xlfSelection)
Dim oldActiveCell As Object = Excel(xlfActiveCell)
' Remember old selection and select the first cell of the target
Dim firstCellSheet As String = DirectCast(Excel(xlSheetNm, firstCell), String)
Excel(xlcWorkbookSelect, New Object() {firstCellSheet})
Dim oldSelectionOnArraySheet As Object = Excel(xlfSelection)
Excel(xlcFormulaGoto, firstCell)
' Extend the selection to the whole array and clear
Excel(xlcSelectSpecial, 6)
Dim oldArray As ExcelReference = DirectCast(Excel(xlfSelection), ExcelReference)
oldArray.SetValue(ExcelEmpty.Value)
Excel(xlcSelect, oldSelectionOnArraySheet)
Excel(xlcFormulaGoto, oldSelectionOnActiveSheet)
End If
' Get the formula and convert to R1C1 mode
Dim isR1C1Mode As Boolean = CBool(Excel(xlfGetWorkspace, 4))
Dim formulaR1C1 As String = formula
If Not isR1C1Mode Then
' Set the formula into the whole target
Dim formulaR1C1Obj As Object
Dim formulaR1C1Return As XlReturn
formulaR1C1Return = TryExcel(xlfFormulaConvert, formulaR1C1Obj, formula, True, False, ExcelMissing.Value, firstCell)
If formulaR1C1Return <> XlReturn.XlReturnSuccess OrElse TypeOf formulaR1C1Obj Is ExcelError Then
Dim firstCellAddress As String
firstCellAddress = CStr(Excel(xlfReftext, firstCell, True))
Excel(xlcAlert, "Cannot resize array formula at " & firstCellAddress & " - formula might be too long when converted to R1C1 format.")
firstCell.SetValue("'" & formula)
Return
End If
formulaR1C1 = CStr(formulaR1C1Obj)
End If
' Must be R1C1-style references
Dim ignoredResult As Object = Nothing
'Debug.Print("Resizing START: " + target.RowLast);
Dim retval As XlReturn = TryExcel(xlcFormulaArray, ignoredResult, formulaR1C1, target)
'Debug.Print("Resizing FINISH");
' TODO: Find some dummy macro to clear the undo stack
If retval <> XlReturn.XlReturnSuccess Then
Dim firstCellAddress As String = DirectCast(Excel(xlfReftext, firstCell, True), String)
Excel(xlcAlert, (Convert.ToString("Cannot resize array formula at ") & firstCellAddress) + " - result might overlap another array.")
' Might have failed due to array in the way.
firstCell.SetValue(Convert.ToString("'") & formula)
End If
Finally
Excel(xlcEcho, oldEcho)
Excel(xlcOptionsCalculation, oldCalculationMode)
End Try
End Sub
End Module
Public Module UtilityFunctions
<ExcelFunction(IsHidden:=True)>
Public Function dnaSupportsDynamicArrays() As Boolean
Static supportsDynamicArrays? As Boolean
If Not supportsDynamicArrays.HasValue Then
Try
Dim result = XlCall.Excel(614, New Object() {1}, New Object() {True})
supportsDynamicArrays = True
Catch
supportsDynamicArrays = False
End Try
End If
Return supportsDynamicArrays.Value
End Function
End Module
End Namespace