Excel VBA: Communicating via named pipe - excel

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();
}
}

Related

Fastest way to conditionally strip off the right part of a string

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.

Datastructure for both sorting and filtering

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;
}
}
}

Displaying Excel data in a table in richtextbox vb.net

I am using gembox.spreadsheet to import data in rich text box, here's the code :
Private Sub OpenFileDialog1_FileOk(sender As Object, e As System.ComponentModel.CancelEventArgs) Handles OpenFileDialog1.FileOk
Dim ef As ExcelFile = ExcelFile.Load(OpenFileDialog1.FileName)
Dim sb As New StringBuilder()
For Each sheet As ExcelWorksheet In ef.Worksheets
sb.AppendLine()
sb.AppendFormat("{0} {1} {0}", New String("-"c, 25), sheet.Name)
For Each row As ExcelRow In sheet.Rows
sb.AppendLine()
For Each cell As ExcelCell In row.AllocatedCells
If cell.ValueType <> CellValueType.Null Then
sb.Append(String.Format("{0} [{1}]", cell.Value, cell.ValueType).PadRight(25))
Else
sb.Append(New String(" "c, 25))
End If
Next
Next
Next
bodytxt.Text = sb.ToString()
End Sub
The problem is , when the .xls file is imported/loaded in the bodytxt textbox, it looks very weird...Something like :
------------------------- Sheet1 -------------------------
[String] Pic [String] Unique id [String]
Prefix [String] First name [String] Last name [String]
Gender [String] Title [String] Company [String]
Phone [String] Mobile [String] Fax [String]
B.Email [String] P.Email [String] Reference [String]
Address [String] Address 2 [String] Country [String]
City [String] Zip [String] Facebook [String]
Is there any way to display the data like excel displays the data/show the data in a table/or at least arrange the data's properly one after one because it looks very messy(i arranged them in the post differently so that they would show in a code block).Any way to do so ?
UPDATE 1
I figured something out..And this may help every one who are looking for a way to create a table in rich textbox. Let me explain a few things first.Inserting a table in rich textbox is quiet impossible (as far as I think) or at least creating a cutomizable table in rtxtbox like MS WORD is quiet impossible/difficult.... But what if we can find another way to do so? Let us think for a while.... A DATA GRID VIEW CAN LOAD DATA FROM EXCEL, right? NOW HOW ABOUT LOADING THE DATA IN A DATAGRIDVIEW AND THEN ADDING THE ROWS' CELL VALUES IN THE RICH TEXT BOX ..AND AFTER EVERY ROW , WHY NOT ADD A BUNCH OF "---"(dashes)? THEN EVERY ROW WOULD LOOK SEPARATE AND WOULD GIVE US A TABLE-ish LOOK....! The code for both C++ and VB.net are given below :
C++
using System;
using System.Collections.Generic;
using System.ComponentModel;
using System.Data;
using System.Drawing;
using System.Linq;
using System.Text;
using System.Threading.Tasks;
using System.Windows.Forms
'populate your dgvw first
'Create a button to add data from dgvw to rtxtbox
private void button1_Click(object sender, EventArgs e)
{
for(int i = 0; i < dataGridView1.Rows.Count - 1; i++)
{
richTextBox1.Text = richTextBox1.Text + "-";
for(int j = 0; j < dataGridView1.Columns.Count; j++)
{
richTextBox1.Text = richTextBox1.Text + "\t" + dataGridView1.Rows[i].Cells[j].Value.ToString() + "\t";
}
richTextBox1.Text = richTextBox1.Text + "\n";
richTextBox1.Text = richTextBox1.Text + "----------------------------------------------------------------------------------------------------------"; 'the dashes vary on the cell width/cell number so add as many dashes as u need
richTextBox1.Text = richTextBox1.Text + "\n";
}
}
}
}
VB.NET
'use the same namespaces as c++(if required)
'populate dgvw
'add a button to transfer data from dgvw to richtxtbx
Public sub Button1_click
For i As Integer = 0 To dgvw1.Rows.Count - 2
RichTextBox1.Text = RichTextBox1.Text + "-"
For j As Integer = 0 To dgvw1.Columns.Count - 1
Try
RichTextBox1.Text = RichTextBox1.Text + vbTab + dgvw1.Rows(i).Cells(j).Value.ToString() + vbTab
Catch ex as exception
End try ' The try statement is used so that OBJECT REFERENCE NOT SET TO AN INSTANCE OF OBJECT error can be prevented as it happens when a cell value is null
RichTextBox1.Text = RichTextBox1.Text + vbLf
RichTextBox1.Text = RichTextBox1.Text + "----------------------------------------------------------------------------------------------------------"
RichTextBox1.Text = RichTextBox1.Text + vbLf
Next
Next
End Sub
This may not be the perfect solution but this will get the job done and you can make any changes you want.... THIS IS WHAT I GOT SO FAR AND I WILL UPDATE AS SOON AS I FIND SOMETHING NEW
It may not be an answer to your question but as far as i think,if any of your cell value is null then youl'ld get a "Object reference not set to an instance of object" error in
RichTextBox1.Text = RichTextBox1.Text + vbTab + dgvw1.Rows(i).Cells(j).Value.ToString() + vbTab
So i suggest you using a TRY STATEMENT here...

Can't get LibXL xlSheetGetNamedRange to work

I am trying to work with LibXL. I can extract data from sheets, but need a function to transform a string with Excel row and column indices into startRow, endRow, startCol, endCol i.e.
"A1:B3" into startRow = 0, endRow = 2, startCol = 0, endCol = 1 (LibXL uses 0 based indexing)
I have tried everything I can think of. The library does not come with any examples that use this function and the documentation is quite sparse. What am I doing wrong?
Here is my code:
int main()
{
const char range[] = "B2:C3";
int i, ret, rowFirst=0, rowLast=0, colFirst=0, colLast=0;
BookHandle book;
SheetHandle sheet;
book = xlCreateBook();
ret = xlBookLoad(book, "/home/jason/Downloads/panel.xls");
sheet = xlBookGetSheet(book, 0);
ret = xlSheetGetNamedRange(sheet, &range[0], &rowFirst, &rowLast, &colFirst, &colLast);
printf("ret from xlSheet...Range = %d\n", ret);
printf("%s\n", xlBookErrorMessage(book));
printf("rowLast = %d\n", rowLast);
printf("rowLast = %d\n", rowLast);
printf("colFirst = %d\n", colFirst);
printf("colLast = %d\n", colLast);
return 0;
}
use xlSheetAddrToRowCol() function for this purpose:
int rowStart, colStart, rowEnd, colEnd;
int rowRelativeStart, colRelativeStart, rowRelativeEnd, colRelativeEnd;
xlSheetAddrToRowCol(sheet, "B2", &rowStart, &colStart, &rowRelativeStart, &colRelativeStart);
xlSheetAddrToRowCol(sheet, "C3", &rowEnd, &colEnd, &rowRelativeEnd, &colRelativeEnd);

How can I find user's time zone offset in excel

I am using an excel macro to generate an RSS feed. The user's timezone offset needs to go in the field of the RSS feed. How can I do this programatically in the excel macro function?
Paste the following code into a module in Excel:
Private Declare Function GetTimeZoneInformationAny Lib "kernel32" Alias _
"GetTimeZoneInformation" (buffer As Any) As Long
Function GetTimeZone() As Single
Dim retval As Long
Dim buffer(0 To 42) As Long
Const TIME_ZONE_ID_INVALID = &HFFFFFFFF
Const TIME_ZONE_ID_UNKNOWN = 0
Const TIME_ZONE_ID_STANDARD = 1
Const TIME_ZONE_ID_DAYLIGHT = 2
retval = GetTimeZoneInformationAny(buffer(0))
Select Case retval
Case TIME_ZONE_ID_INVALID
GetTimeZone = 0
Case TIME_ZONE_ID_STANDARD, TIME_ZONE_ID_UNKNOWN
GetTimeZone = (buffer(0) + buffer(21)) / -60
Case TIME_ZONE_ID_DAYLIGHT
GetTimeZone = (buffer(0) + buffer(42)) / -60
Case Else
GetTimeZone = 0
End Select
End Function
(From http://binaryworld.net/Main/CodeDetail.aspx?CodeId=152)

Resources