FazBrowse GitHub Viewer
|
Trending
|
URL:
|
Home
Tools:
[Download Repo ZIP]
[View Raw Code]
[Original HTTPS Page]
Samples/ArrayResizer/VisualBasic/ArrayResizer.vb at ReturnConversion · Excel-DNA/Samples · GitHub
Uh oh!
There was an error while loading.
Please reload this page
.
Excel-DNA
/
Samples
Public
Notifications
You must be signed in to change notification settings
Fork
83
Star
134
Code
Issues
12
Pull requests
1
Actions
Security and quality
0
Insights
Additional navigation options
Code
Issues
Pull requests
Actions
Security and quality
Insights
Expand file tree
Breadcrumbs
Samples
/
ArrayResizer
/
VisualBasic
/
ArrayResizer.vb
Copy path
More file actions
More file actions
Latest commit
History
History
History
235 lines (191 loc) · 8.44 KB
Breadcrumbs
Samples
/
ArrayResizer
/
VisualBasic
/
ArrayResizer.vb
Copy path
File metadata and controls
235 lines (191 loc) · 8.44 KB
Raw
Copy raw file
Download raw file
Open symbols panel
Edit and raw actions
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
Back
|
FazBrowse Home
|
New Git URL