Related
Typically the accepted approach is to do the following
Number to Letter
public function numberToLetter(ByVal i as long) as string
Dim s as string: s = cells(1,i).address(false,false)
numberToLetter = left(s,len(s)-1)
end function
Letter to Number
Public Function letterToNumber(ByVal s As String) As Long
letterToNumber = Range(s & 1).Column
End Function
However neither of these are particular optimal, as in each case we are creating an object, and then calling a property accessor on the object. Is there a faster approach?
Summary
The core thing to realise is that the lettering system used in Excel is also known as Base26. NumberToLetter is encoding to Base26 from decimal, and LetterToNumber is decoding from Base26 to decimal.
Base conversion can be done with simple loops and
Function base26Encode(ByVal iDecimal As Long) As String
if iDecimal <= 0 then Call Err.Raise(5, "base26Encode" ,"Argument cannot be less than 0")
if iDecimal >= 16384 then Call Err.Raise(5, "base26Encode" ,"There are only 16384 columns in a spreadsheet, thus this function is limited to this number.")
Dim s As String: s = ""
Do
Dim v As Long
v = (iDecimal - 1) Mod 26 + 1
iDecimal = (iDecimal - v) / 26
s = Chr(v + 64) & s
Loop Until iDecimal = 0
base26Encode = s
End Function
Function base26Decode(ByVal sBase26 As String) As Long
sBase26 = UCase(sBase26)
Dim sum As Long: sum = 0
Dim iRefLen As Long: iRefLen = Len(sBase26)
For i = iRefLen To 1 Step -1
sum = sum + (Asc((Mid(sBase26, i))) - 64) * 26 ^ (iRefLen - i)
Next
base26Decode = sum
End Function
Performance
I tested the performance of these functions against the original functions. To do this I used the stdPerformance class of stdVBA.
The code used for testing is as follows:
Sub testPerf()
Dim cMax As Long: cMax = 16384
With stdPerformance.Measure("Encode Original")
For i = 1 To cMax
Call numberToLetter(i)
Next
End With
With stdPerformance.Measure("Encode Optimal")
For i = 1 To cMax
Call base26Encode(i)
Next
End With
With stdPerformance.Measure("Decode Original")
For i = 1 To cMax
Call letterToNumber(base26Encode(i))
Next
End With
With stdPerformance.Measure("Decode Optimal")
For i = 1 To cMax
Call base26Decode(base26Encode(i))
Next
End With
End Sub
The results for which are as follows:
Encode Original: 78 ms
Encode Optimal: 31 ms
Decode Original: 172 ms
Decode Optimal: 63 ms
As shown this is a slightly faster approach (2-3x faster). I am fairly surprised that object creation and property access performed so well however.
I need to remove the numeric part at the end of a string. Here are some examples:
"abcd1234" -> "abcd"
"a3bc45" -> "a3bc"
"kj3ih5" -> "kj3ih"
You get the idea.
I implemented a function which works well for this purpose.
Function VarStamm(name As String) As String
Dim i, a As Integer
a = 0
For i = Len(name) To 1 Step -1
If IsNumeric(Mid(name, i, 1)) = False Then
i = i + 1
Exit For
End If
Next i
If i <= Len(name) Then
VarStamm = name.Substring(0, i - 1)
Else
VarStamm = name
End If
End Function
The question is: is there any faster (more efficient in speed) way to do this? The problem is, I call this function within a loop with 3 million iterations and it would be nice to have it be more efficient.
I know about the String.LastIndexOf method, but I don't know how to use it when I need the index of the last connected number within a string.
You can use Array.FindLastIndex and then Substring:
Dim lastNonDigitIndex = Array.FindLastIndex(text.ToCharArray(), Function(c) Not char.IsDigit(c))
If lastNonDigitIndex >= 0
lastNonDigitIndex += 1
Dim part1 = text.Substring(0, lastNonDigitIndex)
Dim part2 = text.Substring(lastNonDigitIndex)
End If
I was skeptical that the Array.FindLastIndex method was actually faster, so I tested it myself. I borrowed the testing code posted by Amessihel, but added a third method:
Function VarStamm3(name As String) As String
Dim i As Integer
For i = name.Length - 1 To 0 Step -1
If Not Char.IsDigit(name(i)) Then
Exit For
End If
Next i
Return name.Substring(0, i + 1)
End Function
It uses your original algorithm, but just swaps out the old VB6-style string methods for newer .NET equivalent ones. Here's the results on my machine:
RunTime :
- VarStamm : 00:00:07.92
- VarStamm2 : 00:00:00.60
- VarStamm3 : 00:00:00.23
As you can see, your original algorithm was already quite well tuned. The problem wasn't the loop. The problem was Mid, IsNumeric, and Len. Since Tim's method didn't use those, it was much faster. But, if you stick with a manual for loop, it's twice as fast as using Array.FindLastIndex, all things being equal
Given your function VarStamm and Tim Schmelter's one named VarStamm2, here is a small test performance I wrote. I typed an arbitrary long String with a huge right part, and ran the functions one million times.
Module StackOverlow
Sub Main()
Dim testStr = "azekzoerjezoriezltjreoitueriou7657678678797897898997897978897898797989797"
Console.WriteLine("RunTime :" + vbNewLine +
" - VarStamm : " + getTimeSpent(AddressOf VarStamm, testStr) + vbNewLine +
" - VarStamm2 : " + getTimeSpent(AddressOf VarStamm2, testStr))
End Sub
Function getTimeSpent(f As Action(Of String), str As String) As String
Dim sw As Stopwatch = New Stopwatch()
Dim ts As TimeSpan
sw.Start()
For i = 1 To 1000000
f(str)
Next
sw.Stop()
ts = sw.Elapsed
Return String.Format("{0:00}:{1:00}:{2:00}.{3:00}",
ts.Hours, ts.Minutes, ts.Seconds,
ts.Milliseconds / 10)
End Function
Function VarStamm(name As String) As String
Dim i, a As Integer
a = 0
For i = Len(name) To 1 Step -1
If IsNumeric(Mid(name, i, 1)) = False Then
i = i + 1
Exit For
End If
Next i
If i <= Len(name) Then
VarStamm = name.Substring(0, i - 1)
Else
VarStamm = name
End If
End Function
Function VarStamm2(name As String) As String
Dim lastNonDigitIndex = Array.FindLastIndex(name.ToCharArray(), Function(c) Not Char.IsDigit(c))
If lastNonDigitIndex >= 0 Then
lastNonDigitIndex += 1
Return name.Substring(0, lastNonDigitIndex)
End If
Return name
End Function
End Module
Here is the output I got:
RunTime :
- VarStamm : 00:00:38.33
- VarStamm2 : 00:00:02.72
So yes, you should choose his answer, his code is both pretty and efficient.
Is there any data structure I have access to with efficient sorting and filtering of objects?
For sorting, the System.Collections.ArrayList is perfect, as I simply add a load of classes which Implement IComparable and .Sort(). However I can't find a .Filter() method, as some articles hint may be present (section 9.3).
Is there a good collection type for filtering and sorting custom objects? Preferably something written in a pre-compiled language.
A simple object would look like this:
Implements IComparable 'requires mscorlib.dll, allows sorting
Public itemIndex As Long 'simplest, sorting by an integer value
Private Function IComparable_CompareTo(ByVal obj As Variant) As Long
'for sorting, itemindex is based on current grid sorting mode
If TypeOf obj Is clsGridItem Then
Dim other As clsGridItem: Set other = obj
Dim otherIndex As Long: otherIndex = other.itemIndex
Dim thisIndex As Long: thisIndex = Me.itemIndex
If thisIndex > otherIndex Then
IComparable_CompareTo = 1
ElseIf thisIndex < otherIndex Then
IComparable_CompareTo = -1
Else
IComparable_CompareTo = 0
End If
Else
Err.Raise 5 'obj is wrong type
End If
End Function
And I have an arrayList of them populated with random indices. Of course anything could go in the compare routine (I actually use Select Case for different comparison routines, based on different properties of the classes). A simple filter loop could just check when IComparable_CompareTo = 0
Sort functionality is built-in to the ArrayList Objects, and Filtering is nothing more than "only using the items you need".
For example, this populates an object with random numbers and then filters results to display only those divisible by 42:
Option Explicit
Sub testSort()
Const filter = 42
Dim arr As Object, x As Long, y As Long
Set arr = CreateObject("System.Collections.ArrayList")
' populate array with 100 random numbers
For x = 1 To 420
arr.Add Int(Rnd() * 10000)
Next
' "sort" array
arr.Sort
' dump array to immediate window; "filter" to show only even numbers
For x = 0 To arr.Count - 1
If arr(x) / filter = arr(x) \ filter Then
'item mnatches filter
Debug.Print "arr(" & x & ") = " & arr(x)
y = y + 1
End If
Next x
Debug.Print "Returned " & y & " sorted results (Filter=" & filter & ")"
End Sub
Other Possibilities
You haven't shared much detail on what you need to filter and how, but I was thinking about it further, and you might want to check these out to see if they can be applied to your task:
MSDN: Filter Function (VBA)
Returns a zero-based array containing subset of a string array based on a specified filter criteria
excelfunctions.net: FILTER Function (VBA)
MSDN: Filtering Items in a Collection (VBA)
msdocs: CreateObject("System.Collections.ArrayList") (VB)
Filters the elements of an IEnumerable based on a specified type
msdocs: ArrayList Class Constructors (VB)
Stack Overflow: How to implement class constructor in Visual Basic? (VB)
Stack Overflow: VBA array sort function (VB/VBA)
Wikipedia : Comparison of popular sorting algorithms
Arbitrary filtering of anything enumerable is something Enumerable.Where does, and it does it with the help of delegates, something VBA has no knowledge of, or ability to implement.
WARNING what follows is experimental code that is not intended for production use. It is provided as-is for educational purposes. Use at your own risk.
You can simulate it though. see Wait, is this... LINQ? and Generating and calling code on the fly on Code Review - below is a class I've called Delegate - note that it has its PredeclaredId attribute set to True, so that its Create factory method can be invoked from the default instance. It uses the Regular Expressions library for parsing the definition of the function, and the VBE Extensibility API library to literally generate an "anonymous function" given a string, for example:
Set x = Delegate.Create("(x) => MsgBox(""Hello, "" & x & ""!"")")
x.Execute "Mug"
The above code generates and invokes this function:
Public Function AnonymousFunction(ByVal x As Variant) As Variant
AnonymousFunction = MsgBox("Hello, " & x & "!")
End Function
Which produces what you would expect:
Delegate class
Option Explicit
Private Type TDelegate
Body As String
Parameters As New Collection
End Type
Private Const methodName As String = "AnonymousFunction"
Private this As TDelegate
Friend Property Get Body() As String
Body = this.Body
End Property
Friend Property Let Body(ByVal value As String)
this.Body = value
End Property
Public Function Create(ByVal expression As String) As Delegate
Dim result As New Delegate
Dim regex As New RegExp
regex.Pattern = "\((.*)\)\s\=\>\s(.*)"
Dim regexMatches As MatchCollection
Set regexMatches = regex.Execute(expression)
If regexMatches.Count = 0 Then
Err.Raise 5, "Delegate", "Invalid anonymous function expression."
End If
Dim regexMatch As Match
For Each regexMatch In regexMatches
If regexMatch.SubMatches(0) = vbNullString Then
result.Body = methodName & " = " & Right(expression, Len(expression) - 6)
Else
Dim params() As String
params = Split(regexMatch.SubMatches(0), ",")
Dim i As Integer
For i = LBound(params) To UBound(params)
result.AddParameter Trim(params(i))
Next
result.Body = methodName & " = " & regexMatch.SubMatches(1)
End If
Next
Set Create = result
End Function
Public Function Execute(ParamArray params()) As Variant
On Error GoTo CleanFail
Dim paramCount As Integer
paramCount = UBound(params) + 1
GenerateAnonymousMethod
'cannot break beyond this point
Select Case paramCount
Case 0
Execute = Application.Run(methodName)
Case 1
Execute = Application.Run(methodName, params(0))
Case 2
Execute = Application.Run(methodName, params(0), params(1))
Case 3
Execute = Application.Run(methodName, params(0), params(1), params(2))
Case 4
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3))
Case 5
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4))
Case 6
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5))
Case 7
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6))
Case 8
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7))
Case 9
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8))
Case 10
Execute = Application.Run(methodName, params(0), params(1), params(2), _
params(3), params(4), params(5), _
params(6), params(7), params(8), _
params(9))
Case Else
Err.Raise 5, "Execute", "Too many parameters."
End Select
CleanExit:
DestroyAnonymousMethod
Exit Function
CleanFail:
Resume CleanExit
End Function
Friend Sub AddParameter(ByVal paramName As String)
this.Parameters.Add "ByVal " & paramName & " As Variant"
End Sub
Private Sub GenerateAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
Dim params As String
If this.Parameters.Count > 0 Then
params = Join(Enumerable.FromCollection(this.Parameters).ToArray, ", ")
End If
Dim signature As String
signature = "Public Function " & methodName & "(" & params & ") As Variant" & vbNewLine
Dim content As String
content = vbNewLine & signature & this.Body & vbNewLine & "End Function" & vbNewLine
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
component.CodeModule.AddFromString content
End Sub
Private Sub DestroyAnonymousMethod()
Dim component As VBComponent
Set component = Application.VBE.VBProjects("Reflection").VBComponents("AnonymousCode")
component.CodeModule.DeleteLines 1, component.CodeModule.CountOfLines
End Sub
You'll want to change the VBProjects("Reflection").VBComponents("AnonymousCode") to point to some empty standard module in your VBA project... or have a project named Reflection with an empty standard module named AnonymousCode for the Execute method to generate the function into.
As an artifact of how VBA code is compiled, the generated code can be executed, but you can't place a breakpoint in it, and the VBE will refuse to break inside the generated code - so whatever string you supply the factory method with, you better be sure it's simple enough to be 100% bug-free.
What this gives you, is an object that encapsulates a specific action: this object can then be passed around as a parameter, like any other object - so if you have your own collection class implementation (here LinqEnumerable), then you can use it to implement a Where method that takes a Delegate parameter, assuming the predicate parameter encapsulates a function that returns a Boolean:
Public Function Where(ByVal predicate As Delegate) As LinqEnumerable
Dim result As LinqEnumerable
Set result = New LinqEnumerable
Dim element As Variant
For Each element In encapsulated
If predicate.Execute(element) Then result.Add element
Next
Set Where = result
End Function
So given that custom collection class, you can create a Delegate instance that defines your custom criteria, pass it to the Where method, and get the filtered results back.
You can even push it further and implement an Aggregate method:
Public Function Aggregate(ByVal accumulator As Delegate) As Variant
Dim result As Variant
Dim isFirst As Boolean
Dim value As Variant
For Each value In encapsulated
If isFirst Then
result = value
isFirst = False
Else
result = accumulator.Execute(result, value)
End If
Next
Aggregate = result
End Function
And run it pretty much as you would with C# LINQ, minus compile-time type safety and deferred execution:
Dim accumulator As Delegate
Set accumulator = Delegate.Create("(work,value) => value & "" "" & work")
Debug.Print LinqEnumerable.FromList(List.Create("the", "quick", "brown", "fox")) _
.Aggregate(accumulator)
Output:
fox brown quick the
This work was the basis of the Lambda stuff in the VBEX repository on GitHub (originally by Chris McClellan, co-founder of the Rubberduck project; most of the work can be credited to Philip Wales though) - a 100%-VBA project that gives you several other classes to play with. I'd encourage you to explore these and see if any of it is more appropriate for production use.
Thanks for setting this question. I had been planning blog entries on using features from C# in VBA and this question prompted me. I have written a comprehensive blog entry on this topic. (I've even made a Youtube video discussing the solution's source code).
My offered solution is to use C# to write a Class Library DLL that does COM interop. It subclasses a Generic List, it also has a lambda expression parser so VBA code can pass a lambda into a Where method and get a filtered list.
You didn't give a class in your question for us to experiment with. So, I will give a class here called CartesianPoint which ships an Angle method and a Magnitude method which we can use the filter on. The class also implements IComparable so it can participate in sorting. The class implements an interface that is sufficient for it to run the lambda expressions.
Option Explicit
'written by S Meaden
Implements mscorlib.IComparable '* Tools->References->mscorlib
Implements LinqInVBA.ICartesianPoint
Dim PI
Public x As Double
Public y As Double
Public Function Magnitude() As Double
Magnitude = Sqr(x * x + y * y)
End Function
Public Function Angle() As Double
Angle = WorksheetFunction.Atan2(x, y)
End Function
Public Function AngleInDegrees() As Double
AngleInDegrees = Me.Angle * (360 / (2 * PI))
End Function
Private Sub Class_Initialize()
PI = 4 * Atn(1)
End Sub
Private Function ICartesianPoint_AngleInDegrees() As Double
ICartesianPoint_AngleInDegrees = Me.AngleInDegrees
End Function
Private Function ICartesianPoint_Magnitude() As Double
ICartesianPoint_Magnitude = Me.Magnitude
End Function
Private Property Get ICartesianPoint_ToString() As String
ICartesianPoint_ToString = ToString
End Property
Private Function IComparable_CompareTo(ByVal obj As Variant) As Long
Dim oPoint2 As CartesianPoint
Set oPoint2 = obj
IComparable_CompareTo = Sgn(Me.Magnitude - oPoint2.Magnitude)
End Function
Public Function ToString() As String
ToString = "(" & x & "," & y & ")"
End Function
Public Function Equals(ByVal oPoint2 As CartesianPoint) As Boolean
Equals = oPoint2.Magnitude = Me.Magnitude
End Function
Private Property Get IToStringable_ToString() As String
IToStringable_ToString = ToString
End Property
Sample VBA client code is given by this test routine. SO highlights the lambda strings.
Public Sub TestObjects2()
Dim oList As LinqInVBA.ListOfPoints
Set oList = New LinqInVBA.ListOfPoints
Dim o(1 To 3) As CartesianPoint
Set o(1) = New CartesianPoint
o(1).x = 3: o(1).y = 4
Set o(2) = New CartesianPoint
o(2).x = 0.25: o(2).y = 0.5
Debug.Assert o(2).Magnitude <= 1
Set o(3) = New CartesianPoint
o(3).x = -0.25: o(3).y = 0.5
Debug.Assert o(3).Magnitude <= 1
oList.Add o(1)
oList.Add o(2)
oList.Add o(3)
Debug.Print oList.ToString2 'prints (3,4),(0.25,0.5),(-0.25,0.5)
oList.Sort
Debug.Print oList.ToString2 'prints (-0.25,0.5),(0.25,0.5),(3,4)
Dim oFiltered As LinqInVBA.ListOfPoints
Set oFiltered = oList.Where("(o)=>o.Magnitude() <= 1")
Debug.Print oFiltered.ToString2 'prints (-0.25,0.5),(0.25,0.5)
Dim oFiltered2 As LinqInVBA.ListOfPoints
Set oFiltered2 = oFiltered.Where("(o)=>o.AngleInDegrees()>=0 && o.AngleInDegrees()<=90")
Debug.Print oFiltered2.ToString2 'prints (0.25,0.5)
' Dim i
' For i = 0 To oFiltered.Count - 1
' Debug.Print oFiltered.Item(i).ToString
' Next i
End Sub
The (shortened) C# code is given here
using System;
using System.Collections.Generic;
using System.Linq;
using System.Linq.Expressions;
using System.Runtime.InteropServices;
using myAlias = System.Linq.Dynamic; //install package 'System.Linq.Dynamic' v.1.0.7 with NuGet
//https://stackoverflow.com/questions/49453260/datastructure-for-both-sorting-and-filtering/49453892
//https://www.codeproject.com/Articles/17575/Lambda-Expressions-and-Expression-Trees-An-Introdu
//https://stackoverflow.com/questions/821365/how-to-convert-a-string-to-its-equivalent-linq-expression-tree
//https://stackoverflow.com/questions/33176803/linq-dynamic-parselambda-not-resolving
//https://www.codeproject.com/Articles/74018/How-to-Parse-and-Convert-a-Delegate-into-an-Expres
//https://stackoverflow.com/questions/30916432/how-to-call-a-lambda-using-linq-expression-trees-in-c-sharp-net
namespace LinqInVBA
{
// in project properties, build tab, check the checkbox "Register for Interop", run Visualstudio in admin so it can registers changes
// in AssemblyInfo.cs change to [assembly: ComVisible(true)]
public class LambdaExpressionHelper
{
public Delegate ParseAndCompile(string wholeLambda, int expectedParamsCount, Type[] paramtypes)
{
string[] split0 = wholeLambda.Split(new string[] { "=>" }, StringSplitOptions.None);
if (split0.Length == 1) { throw new Exception($"#Could not find arrow operator in expression {wholeLambda}!"); }
if (split0.Length != 2) { throw new Exception($"#Expecting only single arrow operator not {split0.Length - 1}!"); }
string[] args = split0[0].Trim().Split(new char[] { '(', ',', ')' }, StringSplitOptions.RemoveEmptyEntries);
if (args.Length != expectedParamsCount) { throw new Exception($"#Paramtypes array is of different length {expectedParamsCount} to argument list length{args.Length}"); }
var expression = split0[1];
List<ParameterExpression> pList = new List<ParameterExpression>();
for (int lArgLoop = 0; lArgLoop < args.Length; lArgLoop++)
{
Type typLoop = paramtypes[lArgLoop];
var p = Expression.Parameter(typLoop, args[lArgLoop]);
pList.Add(p);
}
var e = myAlias.DynamicExpression.ParseLambda(pList.ToArray(), null, expression);
return e.Compile();
}
}
public interface IFilterableListOfPoints
{
void Add(ICartesianPoint x);
string ToString2();
IFilterableListOfPoints Where(string lambda);
int Count();
ICartesianPoint Item(int idx);
void Sort();
}
public interface ICartesianPoint
{
string ToString();
double Magnitude();
double AngleInDegrees();
// add more here if you intend to use them in a lambda expression
}
[ClassInterface(ClassInterfaceType.None)]
[ComDefaultInterface(typeof(IFilterableListOfPoints))]
public class ListOfPoints : IFilterableListOfPoints
{
private List<ICartesianPoint> myList = new List<ICartesianPoint>();
public List<ICartesianPoint> MyList { get { return this.myList; } set { this.myList = value; } }
void IFilterableListOfPoints.Add(ICartesianPoint x)
{
myList.Add(x);
}
int IFilterableListOfPoints.Count()
{
return myList.Count();
}
ICartesianPoint IFilterableListOfPoints.Item(int idx)
{
return myList[idx];
}
void IFilterableListOfPoints.Sort()
{
myList.Sort();
}
string IFilterableListOfPoints.ToString2()
{
List<string> toStrings = new List<string>();
foreach (ICartesianPoint obj in myList)
{
toStrings.Add(obj.ToString());
}
return string.Join(",", toStrings.ToArray());
}
IFilterableListOfPoints IFilterableListOfPoints.Where(string wholeLambda)
{
Type[] paramtypes = { typeof(ICartesianPoint) };
LambdaExpressionHelper lh = new LambdaExpressionHelper();
Delegate compiled = lh.ParseAndCompile(wholeLambda, 1, paramtypes);
System.Func<ICartesianPoint, bool> pred = (System.Func<ICartesianPoint, bool>)compiled;
ListOfPoints newList = new ListOfPoints();
newList.MyList = (List<ICartesianPoint>)myList.Where(pred).ToList();
return newList;
}
}
}
I am trying to setup communication via a named pipe in VBA unfortunately for some reason it never gets to the line Debug.Print "Connected in the server, nor does the client connect. Seems like a simple scenario but been trying to get this going for hours.
Server
Public Sub Server()
Const szPipeName = "\\.\pipe\bigtest"
Dim hPipe As Long, readVal As Long, readBytes As Long, sendVal As Long, sentBytes As Long
Dim sa As SECURITY_ATTRIBUTES
'Create the NULL security token for the pipe
pSD = GlobalAlloc(GPTR, SECURITY_DESCRIPTOR_MIN_LENGTH)
res = InitializeSecurityDescriptor(pSD, SECURITY_DESCRIPTOR_REVISION)
res = SetSecurityDescriptorDacl(pSD, -1, 0, 0)
sa.nLength = LenB(sa)
sa.lpSecurityDescriptor = pSD
sa.bInheritHandle = True
'Create the Named Pipe
hPipe = CreateNamedPipe(szPipeName, PIPE_ACCESS_DUPLEX, PIPE_WAIT Or PIPE_TYPE_MESSAGE Or PIPE_READMODE_MESSAGE, 10, 1000, 1000, 10000, sa)
'Create separate thread as client
ID = CreateThread(nil, 0, AddressOf ClientThread, nil, 0, nil)
Debug.Print "Created thread: " & ID
Debug.Print "Connecting named pipe: " & hPipe
res = ConnectNamedPipe(hPipe, ByVal 0)
'XXXXXXXXXXXXXXXXX NEVER GETS HERE XXXXXXXXXXXXXXXXXXx
Debug.Print "Connected"
'Read/Write data over the pipe
res = ReadFile(hPipe, readVal, LenB(readVal), readBytes, ByVal 0)
Debug.Print "Read file: " & readVal
'res = WriteFile(hPipe, sendVal , LenB(sendVal ), sendBytes, ByVal 0)
res = FlushFileBuffers(hPipe)
res = DisconnectNamedPipe(hPipe)
'Close the pipe handle
CloseHandle hPipe
GlobalFree (pSD)
End Sub
Client
Public Sub ClientThread()
Const szPipeName As String = "\\.\pipe\bigtest"
Dim sentBytes As Long, sendVal As Long, fSuccess As Boolean, readVal As Long, readBytes As Long
sendVal = 500
'Give server time to ConnectNamedPipe
Sleep 2000
Debug.Print "Connecting to pipe..."
fSuccess= CallNamedPipe(szPipeName, sendVal, LenB(sendVal), readVal, LenB(readVal), readBytes, 5000)
'XXXXXXXXXXXXXX NEVER GETS HERE XXXXXXXXXXXXXX
Debug.Print "Successful: " & fSuccess
'...
End Sub
(this is my first answer -- time to give back)
Let me show you an example of this working. In the following example, I'll give you the VBA macro module code for a a function Excel to send an message to a server, the server to read the message, the server to compose a response, and excel to receive the response. we'll do this using a message that is a string, but you can take this further and create a protocol you would like to use over this pipe.
Remember that Excel macros are single threaded and event driven -- and so the way it makes sense to use named pipes in excel is as a client -- to in response to an event, send a request to a server and receive a response from that server (much like a web GET or POST sends a request and gets a response then closes the connection)
In this example, we used the method CallNamedPipeA in kernel32
(note that this is written for 64 bit excel. If using 32 bit, you exclude the "PtrSafe") This method connects to a named pipe in Message Mode, sends a message, receives a message, and then closes the connection.
The c# server code is taken largely from a Microsoft example, but we must convert it to handle message mode and had it restart a new thread when each pipe is closed. Thus there are always 4 threads waiting for clients to connect.
Quick note on Strings. Remember Excel uses Unicode. We should use UTF8 or byte arrays over named pipes.
Call the sub testPipe in Excel to see this work.
Excel VBA (client)
Option Explicit
Declare PtrSafe Function CallNamedPipe Lib "kernel32" Alias _
"CallNamedPipeA" ( _
ByVal lpNamedPipeName As String, _
lpInBuffer As Any, _
ByVal nInBufferSize As Long, _
lpOutBuffer As Any, _
ByVal nOutBufferSize As Long, _
lpBytesRead As Long, _
ByVal nTimeOut As Long) As Long
Private Sub testPipe()
Dim ms As String
Dim mr As String
Dim returncode As Long
ms = "Message from client;Hello World"
returncode = namedPipeMessageExchange("testpipe", ms, mr)
If returncode <> 0 Then
Debug.Print "Sent: " & ms
Debug.Print "received: " & mr
End If
End Sub
Public Function namedPipeMessageExchange(pipe As String, messageToSend As String, messageReceived As String) As Long
Dim res As Long, myStr As String, i As Long, cbRead As Long, sm As String
Dim numBytes As Long, bArray() As Byte, temp As String
Dim b() As Byte
Dim blen As Long
b = StrConv(messageToSend, vbFromUnicode)
blen = UBound(b) - LBound(b) + 1
If blen = 0 Then b = Array(1)
numBytes = 1000000
ReDim bArray(numBytes) 'Build the return buffer
'Call CallNamedPipe to do the transaction all at once
res = CallNamedPipe("\\.\pipe\" + pipe, b(0), blen, _
bArray(0), numBytes, _
cbRead, 3000) 'Wait up to 3 seconds for a response
If res > 0 Then
ReDim Preserve bArray(0 To cbRead - 1)
messageReceived = StrConv(bArray, vbUnicode)
'Debug.Print "received: " & messageReceived
Else
Debug.Print "Error number " & Err.LastDllError & _
" attempting to call CallNamedPipe.", vbOKOnly
End If
namedPipeMessageExchange = res
End Function
c# (server)
using System;
using System.Collections.Generic;
using System.IO;
using System.IO.Pipes;
using System.Text;
using System.Threading;
public class PipeServer
{
private static int numThreads = 4;
public static void Main()
{
int i;
Thread[] servers = new Thread[numThreads];
Console.WriteLine("\n*** Named pipe server stream with impersonation example ***\n");
Console.WriteLine("Waiting for client connect...\n");
for (i = 0; i < numThreads; i++)
{
servers[i] = new Thread(ServerThread);
servers[i].Start();
}
Thread.Sleep(250);
while (i > 0)
{
for (int j = 0; j < numThreads; j++)
{
if (servers[j] != null)
{
if (servers[j].Join(250))
{
Console.WriteLine("Server thread[{0}] finished.", servers[j].ManagedThreadId);
servers[j] = null;
servers[j] = new Thread(ServerThread);
servers[j].Start();
//i--; // decrement the thread watch count
}
}
}
}
Console.WriteLine("\nServer threads exhausted, exiting.");
}
private static void ServerThread(object data)
{
NamedPipeServerStream pipeServer =
new NamedPipeServerStream("testpipe", PipeDirection.InOut, numThreads, PipeTransmissionMode.Message);
int threadId = Thread.CurrentThread.ManagedThreadId;
// Wait for a client to connect
pipeServer.WaitForConnection();
Console.WriteLine("Client connected on thread[{0}].", threadId);
try
{
List<byte> intext = new List<byte>();
do
{
byte[] x = new byte[1024*16];
int read = 0;
read = pipeServer.Read(x);
Array.Resize(ref x, read);
intext.AddRange(x);
} while (!pipeServer.IsMessageComplete);
string receivedText = System.Text.Encoding.UTF8.GetString(intext.ToArray());
string sentText = "I am the server!";
pipeServer.Write(System.Text.Encoding.UTF8.GetBytes(sentText));
Console.WriteLine("Received Text: "+receivedText);
Console.WriteLine("Sent Text: " + sentText);
}
// Catch the IOException that is raised if the pipe is broken
// or disconnected.
catch (IOException e)
{
Console.WriteLine("ERROR: {0}", e.Message);
}
//pipeServer.WaitForPipeDrain();
pipeServer.Close();
}
}
I am writing a code where one of the lines( Range("H5").value = 10 ) should assign a specific value to a specific cell. However it gives me an #VALUE! error on my cell. Here is my code please help!!:
Function TotalAdUnits(Money As Currency, CycleEarning As Integer) As Integer
TapCost = 16
TotalAdUnits = 0
AdUnit = 0
i = 1
Money = Money + CycleEarning
Do While (Money >= TapCost)
Money = Money - TapCost
TotalAdUnits = TotalAdUnits + Range("L1").Offset(i, 0)
TapCost = Range("J2").Offset(i, 0)
Range("H5").value = 10
i = i + 1
Loop
End Function
You cannot set a cells value from a UDF - a function used in this way can only return a value to the calling cell (or range, if it's used as an array function). Edit your function to return the value, instead of trying to set it directly.
Having said that, I'm not clear on exactly what you're trying to do with that function. Why set the same value in a loop?
Also, if you reference ranges directly from your function, and those ranges are not passed as parameters, you need to include
Application.Volatile
in your function so Excel knows to recalculate it any time the sheet changes.
Function TotalAdUnits(Money As Currency, CycleEarning As Integer) As Integer
TapCost = 16
TotalAdUnits = 0
AdUnit = 0
i = 1
Money = Money + CycleEarning
Do While (Money >= TapCost)
Money = Money - TapCost
TotalAdUnits = TotalAdUnits + Range("L1").Offset(i, 0)
TapCost = Range("J2").Offset(i, 0)
Range("H5").value = 10
i = i + 1
Loop
'need to return a value...
TotalAdUnits = 10 '?
End Function