Small function to rearrange string array in VBA - vba

I've been writing a macro for Solidworks in VBA, and at one point I'd like to rearrange the sheets in a drawing in the following way--if any of the sheets are named "CUT", bring that sheet to the front. Solidworks API provides a way to rearrange the sheets, but it requires an array of sheet names sorted into the correct order--fair enough. The way to get the sheet names looks to be this method.
So, I tried to write a small function to rearrange the sheets in the way I want. The function call I'm trying to use and the function are shown here
Function Call
Dim swApp As SldWorks.SldWorks
Dim swDrawing As SldWorks.DrawingDoc
Dim bool As Boolean
Set swApp = Application.SldWorks
Set swDrawing = swApp.ActiveDoc
.
.
.
bool = swDrawing.ReorderSheets(bringToFront(swDrawing.GetSheetNames, "CUT"))
Function Definition
Private Function bringToFront(inputArray() As String, _
stringToFind As String) As String()
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
Dim outputArray() As String
first = LBound(inputArray)
last = UBound(inputArray)
ReDim outputArray(first to last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
outputArray(j + 1) = inputArray(j)
Next j
For j = (i + 1) To last
outputArray(j) = inputArray(j)
Next j
outputArray(first) = stringToFind
End If
Next i
bringToFront = outputArray
End Function
The error I get is "Type mismatch: array or user defined type expected" on the function call line. I've done quite a bit of searching and I think what I'm messing up has to do with static vs dynamic arrays, but I haven't quite been able to get to the solution on my own.

Besides the corrections suggested in the comments, what is happening is that at the lines
bringToFront(j + 1) = inputArray(j)
and
bringToFront(first) = stringToFind
the compiler thinks you are trying to call recursively the function bringToFront. That is why it complains about the number of parameters in the error message. To fix this, just create another array as local array variable, with a different name, let us name it "ret", fill it appropriately, and assign it at the end before returning.
EDIT: Also, it is better to declare the arrays as Variant types to avoid interoperability problems between VB6 and .Net . This was the final issue
Private Function bringToFront(inputArray As Variant, _
stringToFind As String) As Variant
Dim i As Integer
Dim j As Integer
Dim first As Integer
Dim last As Integer
first = LBound(inputArray)
last = UBound(inputArray)
Dim ret() As String
ReDim ret(first To last)
For i = first To last
If inputArray(i) = stringToFind Then
For j = first To (i - 1)
ret(j + 1) = inputArray(j)
Next j
ret(first) = stringToFind
End If
Next i
bringToFront = ret
End Function

Related

Pass array function into user defined function

I have a standard user defined function that concationates all the unique values. What I am trying to do is to perform this function on a range that satisfies a condition.
Function ConcatUniq(xRg As Range, xChar As String) As String
'updateby Extendoffice 20151228
Dim xCell As Range
Dim xDic As Object
Set xDic = CreateObject("Scripting.Dictionary")
For Each xCell In xRg
xDic(xCell.Value) = Empty
Next
ConcatUniq = Join$(xDic.Keys, xChar)
Set xDic = Nothing
End Function
Lets make an example:
If we have the following data:
A1:A5 = {1,2,2,4,1}
B1:B5 = {"group1", "group1","group1", "group2", "group2"}
C1 = "group1"
Now I want to find the unique values using the ConcatUniq function for all numbers that are in group1. Usually, if I want to perform another function for example the median I would do the following:
=MEDIAN(IF(B1:B5=C1,A1:A5))
Activate it using cntrl shift enter which gives 2 (create an array function from it).
For some reasons this does not work in combination with a user defined function.
=ConcatUniq(IF(B1:B5=C1,A1:A5)," ")
Desired result:
1 2
Does someone know how I could fix this problem?
You need to use ParamArray to accommodate array returned from Excel's array formula. As ParamArray should always be the last one, so your method signature will change.
This will work with =ConcatUniq(" ",IF(B1:B5=C1,A1:A5)) on CTRL + SHIFT + ENTER
Public Function ConcatUniq(xChar As String, ParamArray args())
Dim xDic As Object
Dim xVal
Set xDic = CreateObject("Scripting.Dictionary")
For Each xVal In args(0)
If Not Not xVal Then
xDic(xVal) = Empty
End If
Next
ConcatUniq = Join$(xDic.Keys, xChar)
End Function
Perhaps something like this:
Public Function ConcatUniq(ByVal rangeOrArray As Variant, ByVal xChar As String) As String
Dim generalArray As Variant
If IsArray(rangeOrArray) Then
'operate on it as if was an array
generalArray = rangeOrArray
Else
If TypeName(rangeOrArray) = "Range" Then
'operate on it as if was a Range
If rangeOrArray.Cells.Count > 1 Then
generalArray = rangeOrArray.Value
Else
generalArray = Array(rangeOrArray.Value)
End If
Else
'Try to process as if it was a derivative of a value of a single cell range.....
generalArray = Array(rangeOrArray)
End If
End If
Dim xDic As Object
Set xDic = CreateObject("Scripting.Dictionary")
Dim xCell As Variant
For Each xCell In generalArray
If xCell <> False Then xDic(xCell) = Empty ' EDIT - HACKY....
Next
ConcatUniq = Join$(xDic.Keys, xChar)
End Function
You can see that that whole block of if-elses can be factored out to be a separate function to transform worksheet input to a unified form for operating on values of a worksheet.
The easiest solution would probably be to introduce an additional function. This function would take care of the condition and would generate an array consisting only of data fulfilling the condition.
Try something like this:
function condition_check(data1() as integer, data2() as string, condition_value as string) as integer
number_of_elements = Ubound(data1)
j = 0
for i = 0 to number_of_elements
if data2(i) = condition_value then
condition_check(j) = data1(i)
j = j+1
end if
next i
end function

Spliting large imported text file into a dynamic 2d array in VB 2015

I am currently trying to code a way to read a text file filled with LOTS of data and create a dynamic 2d array to hold each numeric value in its own cell. The text file has data formatted like this
150.00 0.00030739 0.00030023 21.498 0.00024092
150.01 0.00030778 0.00030061 21.497 0.00024122
150.02 0.00030818 0.00030100 21.497 0.00024151
150.03 0.00030857 0.00030138 21.496 0.00024181
150.04 0.00030896 0.00030177 21.496 0.00024210
150.05 0.00030935 0.00030216 21.496 0.00024239
where the spaces are denoted by a vbTab. This is what I have so far.
Dim strfilename As String
Dim num_rows As Long
Dim num_cols As Long
Dim x As Integer
Dim y As Integer
strfilename = "Location of folder holding file" & ListBox1.SelectedItem
If File.Exists(strfilename) Then
Dim sReader As StreamReader = File.OpenText(strfilename)
Dim strLines() As String
Dim strLine() As String
'Load content of file to strLines array
strLines = sReader.ReadToEnd().Split(Environment.NewLine)
'redimension the array
num_rows = UBound(strLines)
strLine = strLines(0).Split(vbTab)
num_cols = UBound(strLine)
ReDim sMatrix(num_rows, num_cols)
'Copy Data into the array
For x = 0 To num_rows
strLine = strLines(x).Split(vbTab)
For y = 0 To num_cols
sMatrix(x, y) = strLine(y).Trim()
Next
Next
End If
When I run this code I get only the first number in the first column of the array and everything else is missing. I need something that shows all of the values. Any help or guidance would be greatly appreciated
Edit:
Here's a picture of what I'm seeing.
What I'm Seeing
You don't need to read all the data in one lump - you can read it line-by-line and process each line.
I assume that the data is machine-generated so that you know there are no errors. I did however put in a check for the required quantity of items on a line.
I copied the data you gave as an example and edited it to change the spaces to tabs.
Option Strict On
Option Infer On
Imports System.IO
Module Module1
Class Datum
Property Time As Double
Property X As Double
Property Y As Double
Property Z As Double
Property A As Double
Sub New(t As Double, x As Double, y As Double, z As Double, a As Double)
Me.Time = t
Me.X = x
Me.Y = y
Me.Z = z
Me.A = z
End Sub
Sub New()
' empty constructor
End Sub
Overrides Function ToString() As String
Return String.Format("(T={0}, X={1}, Y={2}, Z={3}, A={4}", Time, X, Y, Z, A)
' if using VS2015, you can use the following line instead:
' Return $"T={Time}, X={X}, Y={Y}, Z={Z}, A={A}"
End Function
End Class
Function LoadData(srcFile As String) As List(Of Datum)
Dim data = New List(Of Datum)
Using sr As New StreamReader(srcFile)
While Not sr.EndOfStream()
Dim thisLine = sr.ReadLine()
Dim parts = thisLine.Split({vbTab}, StringSplitOptions.RemoveEmptyEntries)
If parts.Count = 5 Then
data.Add(New Datum(CDbl(parts(0)), CDbl(parts(1)), CDbl(parts(2)), CDbl(parts(3)), CDbl(parts(4))))
End If
End While
End Using
Return data
End Function
Sub Main()
Dim src = "C:\temp\testdata2.txt"
Dim myData = LoadData(src)
For Each datum In myData
Console.WriteLine(datum.ToString())
Next
Console.ReadLine()
End Sub
End Module
As you can see, if you use a class to hold the data then you can usefully give it other methods like .ToString().
Option Strict On makes sure that you do not do anything which is meaningless, like trying to store a string in a numeric data type. It is strongly recommended that you set Option Strict On as the default for all projects.
Option Infer On lets the compiler figure out what data type you want when you use something like Dim k = 1.0, so you don't have to type Dim k As Double = 1.0, but note that if you used Dim k = 1 it would infer k to be an Integer.
Once the data is in instances of a class in a list, you can use LINQ to process it in a fairly easy-to-read fashion, for example you could do
Console.WriteLine("The average X value is " & (myData.Select(Function(d) d.X).Average()).ToString())

Report's textbox function call from ControlSource not firing

Firstly, here's a pic on my report in design mode:
The underlying query for the report returns values like so:
Allen Nelli 3:A,5:B,7:A,8:A, etc.
Breton Micheline 1:A,3:A,5:B,7:A, etc
Caporale Jody 1:A,3:A,5:B,7:A, etc
I had to use a subquery to get the third field which concatenates the number : letter combinations. These values actually represent day of month and designation to a particular shift in a schedule. So basically, for a given month, each individual works the designated shift indicated by the day value.
The intention is to call a user defined public function named PopulateTextboxes(Value as String) to be called from the first textbox in the report from the textbox's ControlSource property. The third field in the query is actually named Expr1 and that is being passed as a parameter to the function. The function is designed to populate all the textboxes with the appropriate letter designation: A or B or C or D, etc. The function itself is not being fired when I run the report.
The function is as follows:
Public Function PopulateTextboxes(Expr As String) As String
'Each element of Expr should be a number followed by a colon followed by a letter: 10:A,12:B,15:C, etc.
Dim shiftData() As String
Dim Data As Variant
Dim i As Integer
Dim j As Integer
Dim temp() As String
Dim txt As TextBox
Dim rpt As Report
Dim strCtrl As String
If Expr = "" Then Exit Function
If IsNull(Expr) Then Exit Function
shiftData = Split(Expr, ",")
If UBound(shiftData) > 0 Then
'Make a 2D array
ReDim Data(UBound(shiftData), 2)
'Load up 2D array
For i = 0 To UBound(shiftData) - 1
If shiftData(i) <> "" Then
temp = SplitElement(shiftData(i), ":")
Data(i, 0) = temp(0)
Data(i, 1) = temp(1)
End If
Next i
Set rpt = Reports.item("Multi_Locations_Part_1")
If UBound(days) = 0 Then
MsgBox "days array not populated"
Exit Function
End If
'Populate each Textbox in the Multi_Locations_Part_1 Report
For i = 1 To UBound(days)
strCtrl = "txtDesig_" & CStr(i)
Set txt = rpt.Controls.item(strCtrl)
For j = 0 To UBound(Data) - 1
If Data(j, 0) = days(i) Then
txt.Value = Data(j, 1) 'A,B,C,etc.
Exit For
End If
Next j
Next i
End If
PopulateTextboxes = Expr
End Function
Private Function SplitElement(Value As String, Delim As String) As String()
Dim result() As String
result = Split(Value, Delim)
SplitElement = result
End Function
Please advise.
The best way is to call your function from the Format event of the Detail section, so it will be called for each record.
Private Sub Detail_Format(Cancel As Integer, FormatCount As Integer)
Call PopulateTextboxes(Me.Expr1)
End Sub
If PopulateTextboxes is in a separate module, I suggest to pass Me as additional parameter for the report, so you don't have to hardcode the report name.
Also note that you need the Set keyword when assigning object variables, e.g.
Set txt = rpt.Controls.item("txtDesig_" & CStr(i))

Number of indices is less than the number of dimensions of the indexed array in SSRS VBA Code

I have written below Code in SSRS Report and calling it from expression as =Code.convertCode(Parameters!ProcessingStatus.Value,"Reject,Fail")).Value , but on previewing report I am getting the error : "Number of indices is less than the number of dimensions of the indexed array"
Public Function convertCode(ParamValues As String, findString As String) As String()
Dim SrcArray() As String
Dim FndArray() As String
Dim DstArray() As String
Dim i As Integer
Dim j As Integer
Dim k As Integer
SrcArray() = Split(ParamValues, ",")
FndArray() = Split(FindString,",")
For k = LBound(FndArray) To UBound(FndArray)
For i = LBound(SrcArray) To UBound(SrcArray)
If (InStr(SrcArray(i), FndArray(k)) > 0) Then
ReDim Preserve DstArray(j) As String
DstArray(j) = SrcArray(i)
j = j + 1
End If
Next i
Next k
arr = DstArray
End Function
At the end of your function you have
arr = DstArray
which should be
convertCode = DstArray
Not sure if that's already the problem.
Note: Option Explicit would prevent this error.
I think the problem is that you're not declaring the first dimension in your arrays.
Dim SrcArray() As String
Dim FndArray() As String
Dim DstArray() As String
Should be:
Dim SrcArray(10) As String
Dim FndArray(10) As String
Dim DstArray(10) As String
Or whatever the number of the Array you'll need.
The error message indicates that the number of indices you have (none) is less that what you need (variables I, k, j).

Can't get sensible co-ordinates for note blocks

I've been trying to resurrect an existing drawing check macro, and want to find the co-ordinates of any note blocks on each sheet. I've been modifying code found here using the GetAttachPos method from this page, but for some reason any co-ordinates returned come back around (8.80942311664557E-03,2.24429295226372E-03).
I'm thinking that the problem is that I've missed a reference somewhere, but I'm not sure where. Although it's definitely finding the notes since it passes back their text. Anyway, here's the method I'm testing at the moment:
Sub Main()
Dim swApp As SldWorks.SldWorks
Set swApp = CreateObject("SldWorks.Application")
Dim NoteNumbersText As String
Dim NoteText As String
Dim NumberofSheets As Integer ' The number of sheets in this drawing
Dim NamesOfSheets As Variant ' Names of all of the sheets
Dim sheet As SldWorks.sheet ' The Sheet that we are working on
Dim LocalView As SldWorks.View ' Current View that we are looking at
Dim LocalNote As SldWorks.Note ' Current Note that we are looking at
Dim TextFormat As SldWorks.TextFormat ' Current text format object of a note
Dim Xpos As Double ' X, Y Z position on the drawing in Metres
Dim Ypos As Double
Dim SizeOfSheet As Double
Dim x As Integer ' general Loop Variables
Dim j As Integer
Dim k As Integer
Dim l As Integer
Dim vPosition As Variant
Dim vNote As Variant ' Single note
Dim swNote As SldWorks.Note ' Single Solidworks Note Object
Dim ThisAnnotation As SldWorks.Annotation
Dim swBlockInst As SldWorks.SketchBlockInstance
Dim swBlockDef As SldWorks.SketchBlockDefinition
Dim NumofNotes As Integer
Dim ArrayOfNotes() As NoteInfo
Dim LocalDrawingDoc As SldWorks.DrawingDoc ' Declared as an Object so that non Drawings can be detected!
Dim LocalPart As SldWorks.ModelDoc2 ' Declared as an Object so that non Drawings can be detected!
Dim strShtProp As Variant
Set LocalDrawingDoc = swApp.ActiveDoc
Set LocalPart = swApp.ActiveDoc
ReDim ArrayOfNotes(0)
' Get the sheet names and the number of them
NamesOfSheets = LocalDrawingDoc.GetSheetNames()
NumberofSheets = LocalDrawingDoc.GetSheetCount
' store this sheet name
Set sheet = LocalDrawingDoc.GetCurrentSheet()
strShtProp = sheet.GetProperties() ' get the sheet properties use much later for converting position into ref
SizeOfSheet = strShtProp(5)
Dim SwSketchMgr As SldWorks.SketchManager
Set SwSketchMgr = LocalDrawingDoc.SketchManager
Dim i As Integer
Dim vBlockDef As Variant
Dim vBlockInst As Variant
Dim strReturn As String
' Dim bret As Boolean
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
For x = NumberofSheets - 1 To 0 Step -1
If LocalDrawingDoc.GetCurrentSheet.GetName <> NamesOfSheets(x) Then LocalDrawingDoc.ActivateSheet NamesOfSheets(x)
Set LocalView = LocalDrawingDoc.GetFirstView
While Not LocalView Is Nothing
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
vNote = swBlockDef.GetNotes
If Not IsEmpty(vNote) Then
For j = 0 To UBound(vNote)
Set swNote = vNote(j)
NoteNumbersText = Trim(swNote.GetText)
If Left(NoteNumbersText, 1) = "n" And Len(NoteNumbersText) > 1 And Len(NoteNumbersText) < 4 Then
Set ThisAnnotation = swNote.GetAnnotation
'vPosition = swNote.GetAttachPos
vPosition = ThisAnnotation.GetPosition
Xpos = vPosition(0)
Ypos = vPosition(1)
Debug.Print ("Note " & NoteNumbersText & ": " & Xpos & "," & Ypos)
End If
Next j
End If
Next i
End If
Set LocalView = LocalView.GetNextView
Wend
Next x
End Sub
Turns out that SolidWorks is set up to return positions of blocks relative to the drawing view on which they're placed. Calling GetXForm for the view which they are placed on then provides a way of calculating the absolute position of each note.