Blog

VBA Concave Hull

In previous post was shown an algorithm to obtain the convex hull of a set of points. But the convex hull, beeing extremely fast, has some disadvantages, finding the most important that it acts like a rubber bounding a figurine so, although  it can embrace all the set of points, it will left big spare spaces from that set to the hull. A more interesting bounding polygon will be a concave hull. Found this paper about an algorithm to do so, and two implementations, one in JavaScript and the other in C++. Trying to port to VBA, here I left them, so they are far from finished and tested, but for sure will return to it since it should be the algorithm on preference to the convex hull. There is more information on this topic on this paper on this other one,  also on this one, and finally this other. First the JS version, that I think is more interesting:
'https://github.com/mapbox/concaveman/blob/master/index.js

Option Explicit

Private Function concaveman(ByRef points() As tXYZ, ByVal concavity As Boolean, ByVal lengthThreshold As Double)
    ' a relative measure of concavity; higher value means simpler hull
    concavity = fMax(0, VBA.IIf(concavity = undefined, 2, concavity))
    
    ' when a segment goes below this length threshold, it won't be drilled down further
    lengthThreshold = (lengthThreshold Or 0)
    
    ' start with a convex hull of the points
    Dim hull: hull = fastConvexHull(points)
    
    ' index the points with an R-tree
    Dim tree:tree  = rbush(16, [, Microsoft.VisualBasic.ChrW(91), Microsoft.VisualBasic.ChrW(91), Microsoft.VisualBasic.ChrW(91), Microsoft.VisualBasic.ChrW(91))
    Load (points)
    
    ' turn the convex hull into a linked list and populate the initial edge queue with the nodes
    Dim queue
    Dim last
    
    Do While (i < hull.Length)
        Dim p: p = hull(i)
        Dim i: i = 0
        tree.Remove (p)
        last = insertNode(p, last)
        queue.push (last)
        i = (i + 1)
    Loop
    
    ' index the segments with an R-tree (for intersection checks)
    Dim segTree: segTree = rbush(16)
    
    i = 0
    Do While (i < queue.Length)
        segTree.Insert (updateBBox(queue(i)))
        i = (i + 1)
    Loop
    
    Dim sqConcavity: sqConcavity = (concavity * concavity)
    Dim sqLenThreshold: sqLenThreshold = (lengthThreshold * lengthThreshold)
    
    ' process edges one by one
    While queue.Length
        Dim node: node = queue.Shift
        Dim a: a = node.p
        Dim b: b = node.Next.p
        
        ' skip the edge if it's already short enough
        Dim sqLen: sqLen = getSqDist(a, b)
        If (sqLen < sqLenThreshold) Then
            'TODO: Warning!!! continue If
        End If
        
        Dim maxSqLen: maxSqLen = (sqLen / sqConcavity)
        ' find the best connection point for the current edge to flex inward to
        p = findCandidate(tree, node.prev.p, a, b, node.Next.Next.p, maxSqLen, segTree)
        ' if we found a connection and it satisfies our concavity measure
        If (p And (Math.Min(getSqDist(p, a), getSqDist(p, b)) <= maxSqLen)) Then
            ' connect the edge endpoints through this point and add 2 new edges to the queue
            queue.push (node)
            queue.push (insertNode(p, node))
            ' update point and segment indexes
            tree.Remove (p)
            segTree.Remove (node)
            segTree.Insert (updateBBox(node))
            segTree.Insert (updateBBox(node.Next))
        End If
    Loop
    
    ' convert the resulting hull linked list to an array of points
    node = last
    Dim concave
    
    Do
        concave.push (node.p)
        node = node.Next
    Loop While node <> last
    
    concave.push (node.p)
    concaveman() = concave()
End Function

Private Function findCandidate(ByVal tree, ByVal a, ByVal b, ByVal c, ByVal d, ByVal maxDist, ByVal segTree) As tXYZ
    Dim queue: queue = NewQueue(Nothing, compareDist)
    Dim node: node = tree.Data
    
    ' search through the point R-tree with a depth-first search using a priority queue
    ' in the order of distance to the edge (b, c)
    While node
        Dim i: i = 0
        Do While (i < node.Children.Length) Dim child = node.children(i) Dim dist = node.leaf 'TODO: Warning!!!, inline IF is not supported ? If (dist > maxDist) Then
                'TODO: Warning!!! continue If
            End If
            
            ' skip the node if it's farther than we ever need
            queue.push({, node:= child, dist:= dist)
            i = (i + 1)
        Loop
    End While
    
    
    While (queue.Length And Not queue.peek.node.Children)
        Dim item: item = queue.pop
        Dim p: p = item.node
        ' skip all points that are as close to adjacent edges (a,b) and (c,d),
        ' and points that would introduce self-intersections when connected
        Dim d0: d0 = sqSegDist(p, a, b)
        Dim d1: d1 = sqSegDist(p, c, d)
        If ((item.dist < d0) And ((item.dist < d1) And (noIntersections(b, p, segTree) And noIntersections(c, p, segTree)))) Then Return p End If Loop node = queue.pop If node Then node = node.node End Function Private Function compareDist(ByVal a, ByVal b) As Boolean compareDist = (a.dist - b.dist) End Function ' square distance from a segment bounding box to the given one Private Function sqSegBoxDist(ByVal a, ByVal b, ByVal bbox) As Double If (inside(a, bbox) Or inside(b, bbox)) Then sqSegBoxDist = 0: Exit Function Dim d1 = sqSegSegDist(a(0), a(1), b(0), b(1), bbox.minX, bbox.minY, bbox.maxX, bbox.minY) If d1 = 0 Then sqSegBoxDist = 0: Exit Function Dim d2 = sqSegSegDist(a(0), a(1), b(0), b(1), bbox.minX, bbox.minY, bbox.minX, bbox.maxY) If d2 = 0 Then sqSegBoxDist = 0: Exit Function Dim d3 = sqSegSegDist(a(0), a(1), b(0), b(1), bbox.maxX, bbox.minY, bbox.maxX, bbox.maxY) If d3 = 0 Then sqSegBoxDist = 0: Exit Function Dim d4 = sqSegSegDist(a(0), a(1), b(0), b(1), bbox.minX, bbox.maxY, bbox.maxX, bbox.maxY) If d4 = 0 Then sqSegBoxDist = 0: Exit Function sqSegBoxDist = fMin(d1, d2, d3, d4) End Function Private Function inside(ByVal a, ByVal bbox) As Boolean inside = ((a(0) >= bbox.minX) And _
             ((a(0) <= bbox.maxX) And _ ((a(1) >= bbox.minY) And _
             (a(1) <= bbox.maxY))))
End Function

Private Function noIntersections(ByVal a, ByVal b, ByVal segTree) As Boolean
' check if the edge (a,b) doesn't intersect any other edges
    Dim minX: minX = fMin(a(0), b(0))
    Dim minY: minY = fMin(a(1), b(1))
    Dim maxX: maxX = fMax(a(0), b(0))
    Dim maxY: maxY = fMax(a(1), b(1))
    Dim edges
    
    edges = segTree.Search(minX:=minX, minY:=minY, maxX:=maxX, maxY:=maxY)
    For i = 0 To edges.Length
        If (intersects(edges(i).p, edges(i).Next.p, a, b)) Then
            noIntersections = False: Exit Function
        End If
    Next i
    
    noIntersections = True
End Function

Private Function intersects(ByRef p1, ByRef q1, ByRef p2, ByRef q2) As Boolean
' check if the edges (p1,q1) and (p2,q2) intersect
    intersects = (p1 <> q2) And _
                 (q1 <> p2) And _
                 (orient(p1, q1, p2) > 0) <> (orient(p1, q1, q2) > 0) And _
                 (orient(p2, q2, p1) > 0) <> (orient(p2, q2, q1) > 0)
End Function

Private Function updateBBox(ByVal p As tXYZ) As Boolean
' update the bounding box of a node's edge
    Dim p1 = node.p
    Dim p2 = node.next.p
    node.minX = Math.Min(p1(0), p2(0))
    node.minY = Math.Min(p1(1), p2(1))
    node.maxX = Math.Max(p1(0), p2(0))
    node.maxY = Math.Max(p1(1), p2(1))
    Return node
End Function

Private Function fastConvexHull(ByVal Unknown As points) As tXYZ()
' speed up convex hull by filtering out points inside quadrilateral formed by 4 extreme points
    Dim left = points(0)
    Dim top = points(0)
    Dim right = points(0)
    Dim bottom = points(0)
    
    ' find the leftmost, rightmost, topmost and bottommost points
    Dim i = 0
    Do While (i < points.Length)
        Dim p = points(i)
        If (p(0) < Left(0)) Then Left = p End If If (p(0) > Right(0)) Then
            Right = p
        End If
        
        If (p(1) < Top(1)) Then Top = p End If If (p(1) > Bottom(1)) Then
            Bottom = p
        End If
        
        i = (i + 1)
    Loop
    
    ' filter out points that are inside the resulting quadrilateral
    Dim cull
    Left
    Top
    Right
    Bottom
    Dim filtered = cull.slice
    i = 0
    Do While (i < points.Length)
        If Not pointInPolygon(points(i), cull) Then
            filtered.push (points(i))
        End If
        
        i = (i + 1)
    Loop
    
    ' get convex hull around the filtered points
    Dim indices = convexHull(filtered)
    ' return the hull as array of points (rather than indices)
    Dim hull
    i = 0
    Do While (i < indices.Length) hull.push (filtered(indices(i))) i = (i + 1) Loop Return hull End Function ' create a new node in a doubly linked list Private Function insertNode(ByRef p, ByRef prev) As tXYZ Dim node p: p prev: Nothing Next: Nothing minX: 0 minY: 0 maxX: 0 maxY: 0 If Not prev Then node.prev = node node.Next = node Else node.Next = prev.Next node.prev = prev prev.Next.prev = node prev.Next = node End If Return node End Function Private Function getSqDist(ByRef p1 As tXYZ, ByRef p2 As tXYZ) As Double ' square distance between 2 points Dim dy As Double: dy = (p1(1) - p2(1)) Dim dx As Double: dx = (p1(0) - p2(0)) getSqDist = ((dx * dx) + (dy * dy)) End Function Private Function sqSegDist(ByRef p As tXYZ, ByRef p1 As tXYZ, ByRef p2 As tXYZ) As Double ' square distance from a point to a segment Dim dy As Double: dy = (p2(1) - y) Dim x As Double: x = p1(0) Dim y As Double: y = p1(1) Dim dx As Double: dx = (p2(0) - x) Dim t As Double t = ((((p(0) - x) * dx) + ((p(1) - y) * dy)) _ / ((dx * dx) + (dy * dy))) If (t > 1) Then
        x = p2(0)
        y = p2(1)
    ElseIf (t > 0) Then
        x = (x + (dx * t))
        y = (y + (dy * t))
    End If
    
    dx = (p(0) - x)
    dy = (p(1) - y)
    
    sqSegDist = ((dx * dx) + (dy * dy))
End Function
    
Private Function sqSegSegDist(ByVal x0 As Double, _
                              ByVal y0 As Double, _
                              ByVal x1 As Double, _
                              ByVal y1 As Double, _
                              ByVal x2 As Double, _
                              ByVal y2 As Double, _
                              ByVal x3 As Double, _
                              ByVal y3 As Double) As Double
' segment to segment distance, ported from http://geomalgorithms.com/a07-_distance.html by Dan Sunday
    
    Dim ux As Double: ux = (x1 - x0)
    Dim uy As Double: uy = (y1 - y0)
    Dim vx As Double: vx = (x3 - x2)
    Dim vy As Double: vy = (y3 - y2)
    Dim wx As Double: wx = (x0 - x2)
    Dim wy As Double: wy = (y0 - y2)
    Dim a As Double: a = ((ux * ux) + (uy * uy))
    Dim b As Double: b = ((ux * vx) + (uy * vy))
    Dim c As Double: c = ((vx * vx) + (vy * vy))
    Dim d As Double: d = ((ux * wx) + (uy * wy))
    Dim e As Double: e = ((vx * wx) + (vy * wy))
    Dim D_ As Double: D_ = ((a * c) - (b * b))
    Dim tN As Double
    Dim sc As Double
    Dim sN As Double
    Dim tc As Double
    Dim sD As Double: sD = D_
    Dim tD As Double: tD = D_
    
    sN = 0
    sD = 1
    tN = e
    tD = c
    sN = ((b * e) - (c * d))
    tN = ((a * e) - (b * d))
    
    If (sN < 0) Then sN = 0 tN = e tD = c ElseIf (sN > sD) Then
        sN = sD
        tN = (e + b)
        tD = c
    End If
    
    If (tN < 0) Then
        tN = 0
        If ((d * -1) < 0) Then sN = 0 ElseIf ((d * -1) > a) Then
            sN = sD
        Else
            sN = (d * -1)
            sD = a
        End If
        
    ElseIf (tN > tD) Then
        tN = tD
        If (((d * -1) + b) < 0) Then sN = 0 ElseIf ((d * -1) + (b > a)) Then
            sN = sD
        Else
            sN = ((d * -1) + b)
            sD = a
        End If
        
    End If

    sc = VBA.IIf(sN = 0, 0, sN / sD)
    tc = VBA.IIf(tN = 0, 0, tN / tD)
    
    Dim cx As Double: cx = (((1 - sc) * x0) + (sc * x1))
    Dim cy As Double: cy = (((1 - sc) * y0) + (sc * y1))
    Dim cx2 As Double: cx2 = (((1 - tc) * x2) + (tc * x3))
    Dim cy2 As Double: cy2 = (((1 - tc) * y2) + (tc * y3))
    Dim dx As Double: dx = (cx2 - cx)
    Dim dy As Double: dy = (cy2 - cy)
    
    sqSegSegDist = ((dx * dx) + (dy * dy))
End Function


For the C++ version (it seems that the C++ source code gets stuck on some test, so watch out):
'https://www.researchgate.net/publication/220868874_Concave_hull_A_k-nearest_neighbours_approach_for_the_computation_of_the_region_occupied_by_a_set_of_points
'https://www.codeproject.com/Articles/1201438/The-Concave-Hull-of-a-Set-of-Points


'Option Explicit
'
'Private Type PointValue
'    point As tXYZ
'    distance As Double
'    Angle As Double
'End Type
'
'Const stride As Long = 24 ' size in bytes of x, y, id
'
'using PointVector = std::vector;
'using PointValueVector = std::vector;
'using LineSegment = std::pair<Point, Point>;
'
''' Floating point comparisons
''Private Function Equal(double a, double b) As boolean;
''Private Function Zero(double a) As boolean;
''Private Function LessThan(double a, double b) As boolean;
''Private Function LessThanOrEqual(double a, double b) As boolean;
''Private Function GreaterThan(double a, double b) As boolean;
'
''' I/O
''Private Function Usage() As void;
''Private Function FindArgument(int argc, char **argv, const std::string &name) As int;
''Private Function ParseArgument(int argc, char **argv, const std::string &name, std::string &val) As int;
''Private Function ParseArgument(int argc, char **argv, const std::string &name, int &val) As int;
''Private Function HasExtension(const std::string &filename, const std::string &ext) As boolean;
''Private Function ReadFile(const std::string &filename, int fieldX = 1, int fieldY = 2) As PointVector;
''Private Function Print(const std::string &filename, const PointVector &points) As void;
''Private Function Print(FILE *out, const PointVector &points, const char *format = "%.3f  %.3f\n") As void;
''Private Function Split(const std::string &value, const char *delims) As std::vector;
'
''' Algorithm-specific
''Private Function NearestNeighboursFlann(flann::Index<flann::L2> &index, const Point &p, size_t k) As PointValueVector;
''Private Function ConcaveHull(PointVector &dataset, size_t k, bool iterate) As PointVector;
''Private Function ConcaveHull(PointVector &dataset, size_t k, PointVector &hull) As boolean;
''Private Function SortByAngle(PointValueVector &values, const Point &p, double prevAngle) As PointVector;
''Private Function AddPoint(PointVector &points, const Point &p) As void;
'
''' General maths
''Private Function PointsEqual(const Point &a, const Point &b) As boolean;
''Private Function Angle(const Point &a, const Point &b) As double;
''Private Function NormaliseAngle(double radians) As double;
''Private Function PointInPolygon(const Point &p, const PointVector &list) As boolean;
''Private Function Intersects(const LineSegment &a, const LineSegment &b) As boolean;
'
''' Point list utilities
''Private Function FindMinYPoint(const PointVector &points) As Point;
''Private Function RemoveDuplicates(PointVector &points) As void;
''Private Function IdentifyPoints(PointVector &points) As void;
''Private Function RemoveHull(PointVector &points, const PointVector &hull) As PointVector::iterator;
''Private Function MultiplePointInPolygon(PointVector::iterator begin, PointVector::iterator end, const PointVector &hull) As boolean;
'
'Private Function main(argc As Integer, argv() As Byte) As Integer
'
'    std::cout << "Concave hull: A k-nearest neighbours approach.\n";
'
'    ' input filename is the only requirement
'    if (argc == 1)
'        Usage();
'        return EXIT_FAILURE;
'    End If
'
'    std::string filename(argv[1]);
'
'    ' The input field numbers for x and y coordinates
'    int fieldX = 1;
'    int fieldY = 2;
'    if (FindArgument(argc, argv, "-field_for_x") != -1) then         ParseArgument(argc, argv, "-field_for_x", fieldX);
'    if (FindArgument(argc, argv, "-field_for_y") != -1) then         ParseArgument(argc, argv, "-field_for_y", fieldY);
'
'    ' Read input
'    PointVector points = ReadFile(filename, fieldX, fieldY);
'    size_t uncleanCount = points.size();
'
'    ' Remove duplicates and id the points
'    RemoveDuplicates(points);
'    size_t cleanCount = points.size();
'    IdentifyPoints(points);
'
'    ' Starting k-value
'    int k = 0;
'    if (FindArgument(argc, argv, "-k") != -1)
'        ParseArgument(argc, argv, "-k", k);
'    k = std::min(std::max(k, 3), (int)points.size() - 1);
'
'    ' For debug purposes, optionally disable iterating k.
'    bool iterate = true;
'    if (FindArgument(argc, argv, "-no_iterate") != -1) then iterate = false;
'
'    std::cout << "Filename         : " << filename << "\n";
'    std::cout << "Input points     : " << uncleanCount << "\n";
'    std::cout << "Input (cleaned)  : " << cleanCount << "\n";
'    std::cout << "Initial 'k'      : " << k << "\n";
'    std::cout << "Final 'k'        : " << k;
'
'    Private Function startTime = std::chrono::high_resolution_clock::now();
'
'    PointVector hull = ConcaveHull(points, (size_t)k, iterate);
'
'    Private Function endTime = std::chrono::high_resolution_clock::now();
'    Private Function duration = std::chrono::duration_cast(endTime - startTime).count();
'
'    std::cout << "\n";
'    std::cout << "Output points    : " << hull.size() << "\n";
'    std::cout << "Time (excl. i/o) : " << std::fixed << std::setprecision(1) << (double)duration / 1000.0 << "s\n";
'    std::cout << "\n";
'
'    ' Optional no further output
'    if (FindArgument(argc, argv, "-no_out") != -1)
'        if (FindArgument(argc, argv, "-out") != -1)
'            std::cout << "Output to file overridden by switch -no_out.\n";
'        return EXIT_SUCCESS;
'        End If
'
'        ' Output to file or stdout
'        if (FindArgument(argc, argv, "-out") != -1)
'            std::string output;
'            ParseArgument(argc, argv, "-out", output);
'
'            Print(output, hull);
'            std::cout << output << " written.\n";
'        End If
'    Else
'        ' Nothing specified, so output to console
'        Print(stdout, hull);
'    End If
'
'    return EXIT_SUCCESS;
'End Function
'
'Private Function Usage() As void
'' Print program usage info.
'    std::cout << "Usage: concave.exe filename [-out arg] [-k arg] [-field_for_x arg] [-field_for_y arg] [-no_out] [-no_iterate]\n";
'    std::cout << "\n";
'    std::cout << " filename      (required) : file of input coordinates, one row per point.\n";
'    std::cout << " -out          (optional) : output file for the hull polygon coordinates. Default=stdout.\n";
'    std::cout << " -k            (optional) : start iteration K value. Default=3.\n";
'    std::cout << " -field_for_x  (optional) : 1-based column number of input for x-coordinate. Default=1.\n";
'    std::cout << " -field_for_y  (optional) : 1-based column number of input for y-coordinate. Default=2.\n";
'    std::cout << " -no_out       (optional) : disable output of the hull polygon coordinates.\n";
'    std::cout << " -no_iterate   (optional) : stop after only one iteration of K, irrespective of result.\n";
'End Function
'
'Private Function FindArgument(int argc, char **argv, const std::string &name) As int
'' Get command line index of name
'    for (int i = 1; i < argc; ++i) ' { ' if (std::string(argv[i]) == name) ' return i; ' } ' return -1; 'End Function ' 'Private Function ParseArgument(int argc, char **argv, const std::string &name, std::string &val) As int '' Get the command line value (string) for name ' int index = FindArgument(argc, argv, name) + 1; ' if (index > 0 && index < argc) ' val = argv[index]; ' ' return index - 1; 'End Function ' 'Private Function ParseArgument(int argc, char **argv, const std::string &name, int &val) As int '' Get the command line value (int) for name ' int index = FindArgument(argc, argv, name) + 1; ' ' if (index > 0 && index < argc) ' val = atoi(argv[index]); ' ' return (index - 1); 'End Function ' 'Private Function HasExtension(const std::string &filename, const std::string &ext) As boolean '' Check whether a string ends with a specified suffix. ' if (filename.length() >= ext.length())
'        return (0 == filename.compare(filename.length() - ext.length(), ext.length(), ext));
'    return false;
'End Function
'
'Private Function ReadFile(const std::string &filename, int fieldX, int fieldY) As PointVector
'' Read a file of coordinates into a vector. First two fields of comma/tab/space delimited input are used.
'    fieldX--; ' from 1-based index to 0-based
'    fieldY--;
'
'    PointVector list;
'    Point p;
'    std::string line;
'    std::vector tokens;
'
'    std::ifstream fin(filename.c_str());
'    if (fin.is_open())
'        {
'        While (fin.good())
'            {
'            getline(fin, line);
'            if (!line.empty())
'                {
'                tokens = Split(line, " ,\t");
'                if (tokens.size() >= 2)
'                    {
'                    p.x = std::atof(tokens[fieldX].c_str());
'                    p.y = std::atof(tokens[fieldY].c_str());
'                    list.push_back(p);
'                    }
'                }
'            }
'        }
'
'    return list;
'End Function
'
'' Output a point list to a file
'Private Function Print(const std::string &filename, const PointVector &points) As void
'    std::string format;
'    if (HasExtension(filename, ".csv"))
'        format = "%.3f,%.3f\n";
'    Else
'        format = "%.3f  %.3f\n";
'
'    FILE *out = fopen(filename.c_str(), "w+");
'    if (out)
'        {
'        Print(out, points, format.c_str());
'
'        fclose(out);
'        }
'End Function
'
'' Output a point list to a stream with a given format string
'Private Function Print(FILE *out, const PointVector &points, const char *format) As void
'    for (const Private Function &p : points)
'        {
'        fprintf(out, format, p.x, p.y);
'        }
'End Function
'
'' Iteratively call the main algorithm with an increasing k until success
'Private Function ConcaveHull(PointVector &dataset, size_t k, bool iterate) As PointVector
'    While (k < dataset.Size())
'        {
'        PointVector hull;
'        if (ConcaveHull(dataset, k, hull) || !iterate)
'            {
'            return hull;
'            }
'        k++;
'        }
'
'    return{};
'End Function
'
'Private Function ConcaveHull(PointVector &pointList, size_t k, PointVector &hull) As boolean
'' The main algorithm from the Moreira-Santos paper.
'    Erase hull()
'
'    if (pointList.size() < 3) then return true
'    If (pointList.Size() = 3) Then
'        hull = pointList
'        return true
'    End If
'
'    ' construct a randomized kd-tree index using 4 kd-trees
'    ' 2 columns, but stride = 24 bytes in width (x, y, ignoring id)
'    flann::Matrix matrix(&(pointList.front().x), pointList.size(), 2, stride);
'    flann::Index<flann::L2> flannIndex(matrix, flann::KDTreeIndexParams(4));
'    flannIndex.buildIndex();
'
'    std::cout << "\rFinal 'k'        : " << k; ' ' ' Initialise hull with the min-y point ' Point firstPoint = FindMinYPoint(pointList); ' AddPoint(hull, firstPoint); ' ' ' Until the hull is of size > 3 we want to ignore the first point from nearest neighbour searches
'    Point currentPoint = firstPoint;
'    flannIndex.removePoint(firstPoint.id);
'
'    double prevAngle = 0.0;
'    int step = 1;
'
'    ' Iterate until we reach the start, or until there's no points left to process
'    while ((!PointsEqual(currentPoint, firstPoint) || step == 1) && hull.size() != pointList.size())
'        {
'        if (step == 4)
'            {
'            ' Put back the first point into the dataset and into the flann index
'            firstPoint.id = pointList.size();
'            flann::Matrix firstPointMatrix(&firstPoint.x, 1, 2, stride);
'            flannIndex.addPoints(firstPointMatrix);
'            }
'
'        PointValueVector kNearestNeighbours = NearestNeighboursFlann(flannIndex, currentPoint, k);
'        PointVector cPoints = SortByAngle(kNearestNeighbours, currentPoint, prevAngle);
'
'        bool its = true;
'        size_t i = 0;
'
'        while (its && i < cPoints.size())
'            {
'            size_t lastPoint = 0;
'            if (PointsEqual(cPoints[i], firstPoint))
'                lastPoint = 1;
'
'            size_t j = 2;
'            its = false;
'
'            while (!its && j < hull.size() - lastPoint)
'                {
'                Private Function line1 = std::make_pair(hull[step - 1], cPoints[i]);
'                Private Function line2 = std::make_pair(hull[step - j - 1], hull[step - j]);
'                its = Intersects(line1, line2);
'                j++;
'                }
'
'            if (its)
'                i++;
'            }
'
'        if (its)
'            return false;
'
'        currentPoint = cPoints[i];
'
'        AddPoint(hull, currentPoint);
'
'        prevAngle = Angle(hull[step], hull[step - 1]);
'
'        flannIndex.removePoint(currentPoint.id);
'
'        step++;
'        }
'
'    ' The original points less the points belonging to the hull need to be fully enclosed by the hull in order to return true.
'    PointVector dataset = pointList;
'
'    Private Function newEnd = RemoveHull(dataset, hull);
'    bool allEnclosed = MultiplePointInPolygon(begin(dataset), newEnd, hull);
'
'    return allEnclosed;
'End Function
'
'Private Function Equal(a As Double, b As Double) As Boolean
'' Compare a and b for equality
'    Equal = (Abs(a - b) <= EPSILON)
'End Function
'
'Private Function Zero(double a) As boolean
'' Compare value to zero
'    return fabs(a) <= DBL_EPSILON;
'End Function
'
'Private Function LessThan(double a, double b) As boolean
'' Compare for a < b
'    return a < (b - DBL_EPSILON);
'End Function
'
'Private Function LessThanOrEqual(double a, double b) As boolean
'' Compare for a <= b
'    return a <= (b + DBL_EPSILON); 'End Function ' 'Private Function GreaterThan(double a, double b) As boolean '' Compare for a > b
'    return a > (b + DBL_EPSILON);
'End Function
'
'Private Function PointsEqual(const Point &a, const Point &b) As boolean
'' Compare whether two points have the same x and y
'    return Equal(a.x, b.x) && Equal(a.y, b.y);
'End Function
'
'Private Function RemoveDuplicates(PointVector &points) As void
'' Remove duplicates in a list of points
'    sort(begin(points), end(points), [](const Point & a, const Point & b)
'        {
'        if (Equal(a.x, b.x))
'            return LessThan(a.y, b.y);
'        Else
'            return LessThan(a.x, b.x);
'        });
'
'    Private Function newEnd = unique(begin(points), end(points), [](const Point & a, const Point & b)
'        {
'        return PointsEqual(a, b);
'        });
'
'    points.erase(newEnd, end(points));
'End Function
'
'Private Function IdentifyPoints(PointVector &points) As void
'' Uniquely id the points for binary searching
'    uint64_t id = 0;
'
'    for (Private Function itr = begin(points); itr != end(points); ++itr, ++id)
'        {
'        itr->id = id;
'        }
'End Function
'
'' Find the point having the smallest y-value
'Private Function FindMinYPoint(const PointVector &points) As Point
'    assert(!points.empty());
'
'    Private Function itr = min_element(begin(points), end(points), [](const Point & a, const Point & b)
'        {
'        if (Equal(a.y, b.y))
'            return GreaterThan(a.x, b.x);
'        Else
'            return LessThan(a.y, b.y);
'        });
'
'    return *itr;
'End Function
'
'' Lookup by ID and remove a point from a list of points
'Private Function RemovePoint(PointVector &list, const Point &p) As void
'    Private Function itr = std::lower_bound(begin(list), end(list), p, [](const Point & a, const Point & b)
'        {
'        return a.id < b.id; ' }); ' ' assert(itr != end(list) && itr->id == p.id);
'
'    if (itr != end(list))
'        list.erase(itr);
'End Function
'
'' Add a point to a list of points
'Private Function AddPoint(PointVector &points, const Point &p) As void
'    points.push_back(p);
'End Function
'
'' Return the k-nearest points in a list of points from the given point p (uses Flann library).
'Private Function NearestNeighboursFlann(flann::Index<flann::L2> &index, const Point &p, size_t k) As PointValueVector
'    std::vector vIndices(k);
'    std::vector vDists(k);
'    double test[] = { p.x, p.y };
'
'    flann::Matrix query(test, 1, 2);
'    flann::Matrix mIndices(vIndices.data(), 1, static_cast(vIndices.size()));
'    flann::Matrix mDists(vDists.data(), 1, static_cast(vDists.size()));
'
'    int count_ = index.knnSearch(query, mIndices, mDists, k, flann::SearchParams(128));
'    size_t count = static_cast(count_);
'
'    PointValueVector result(count);
'
'    for (size_t i = 0; i < count; ++i)
'        {
'        int id = vIndices[i];
'        const double *point = index.getPoint(id);
'        result[i].point.x = point[0];
'        result[i].point.y = point[1];
'        result[i].point.id = id;
'        result[i].distance = vDists[i];
'        }
'
'    return result;
'End Function
'
'' Returns a list of points sorted in descending order of clockwise angle
'Private Function SortByAngle(PointValueVector &values, const Point &from, double prevAngle) As PointVector
'    for_each(begin(values), end(values), [from, prevAngle](PointValue & to)
'        {
'        to.angle = NormaliseAngle(Angle(from, to.point) - prevAngle);
'        });
'
'    sort(begin(values), end(values), [](const PointValue & a, const PointValue & b)
'        {
'        return GreaterThan(a.angle, b.angle);
'        });
'
'    PointVector angled(values.size());
'
'    transform(begin(values), end(values), begin(angled), [](const PointValue & pv)
'        {
'        return pv.point;
'        });
'
'    return angled;
'End Function
'
'' Get the angle in radians measured clockwise from +'ve x-axis
'Private Function Angle(const Point &a, const Point &b) As double
'    double angle = -atan2(b.y - a.y, b.x - a.x);
'
'    return NormaliseAngle(angle);
'End Function
'
'' Return angle in range: 0 <= angle < 2PI
'Private Function NormaliseAngle(double radians) As double
'    if (radians < 0.0)
'        return radians + M_PI + M_PI;
'    Else
'        return radians;
'End Function
'
'' Return the new logical end after removing points from dataset having ids belonging to hull
'Private Function RemoveHull(PointVector &points, const PointVector &hull) As PointVector::iterator
'    std::vector ids(hull.size());
'
'    transform(begin(hull), end(hull), begin(ids), [](const Point & p)
'        {
'        return p.id;
'        });
'
'    sort(begin(ids), end(ids));
'
'    return remove_if(begin(points), end(points), [&ids](const Point & p)
'        {
'        return binary_search(begin(ids), end(ids), p.id);
'        });
'End Function
'
'' Uses OpenMP to determine whether a condition exists in the specified range of elements. https://msdn.microsoft.com/en-us/library/ff521445.aspx
'template 
'bool omp_parallel_any_of(InIt first, InIt last, const Predicate &pr)
'{
'    typedef typename std::iterator_traits::value_type item_type;
'
'    ' A flag that indicates that the condition exists.
'    bool found = false;
'
'    #pragma omp parallel for
'    for (int i = 0; i < static_cast(last - first); ++i)
'        {
'        if (!found)
'            {
'            item_type &cur = *(first + i);
'
'            ' If the element satisfies the condition, set the flag to cancel the operation.
'            if (pr(cur))
'                {
'                found = true;
'                }
'            }
'        }
'
'    return found;
'End Function
'
'' Check whether all points in a begin/end range are inside hull.
'Private Function MultiplePointInPolygon(PointVector::iterator begin, PointVector::iterator end, const PointVector &hull) As boolean
'    Private Function test = [&hull](const Point & p)
'        {
'        return !PointInPolygon(p, hull);
'        };
'
'    bool anyOutside = true;
'
'#if defined USE_OPENMP
'
'    anyOutside = omp_parallel_any_of(begin, end, test); ' multi-threaded
'
'#Else
'
'    anyOutside = std::any_of(begin, end, test); ' single-threaded
'
'#End If
'
'    return !anyOutside;
'End Function
'
'' Point-in-polygon test
'Private Function PointInPolygon(p As tXYZ, list As PointVector) As Boolean
'    If (list.Size() <= 2) Then PointInPolygon = False ' ' const double &x = p.x; ' const double &y = p.y; ' ' int inout = 0; ' Private Function v0 = list.begin(); ' Private Function v1 = v0 + 1; ' ' while (v1 != list.end()) ' { ' if ((LessThanOrEqual(v0->y, y) && LessThan(y, v1->y)) || (LessThanOrEqual(v1->y, y) && LessThan(y, v0->y)))
'            {
'            if (!Zero(v1->y - v0->y))
'                {
'                double tdbl1 = (y - v0->y) / (v1->y - v0->y);
'                double tdbl2 = v1->x - v0->x;
'
'                if (LessThan(x, v0->x + (tdbl2 * tdbl1)))
'                    inout++;
'                }
'            }
'
'        v0 = v1;
'        v1++;
'        }
'
'    If (inout = 0) Then
'        PointInPolygon = False
'    ElseIf (inout Mod 2 = 0) Then
'        PointInPolygon = False
'    Else
'        PointInPolygon = True
'    End If
'End Function
'
'' Test whether two line segments intersect each other
'Private Function Intersects(a As LineSegment, b As LineSegment) As Boolean
'' https://www.topcoder.com/community/data-science/data-science-tutorials/geometry-concepts-line-intersection-and-its-applications/
'
'    const double &ax1 = a.first.x;
'    const double &ay1 = a.first.y;
'    const double &ax2 = a.second.x;
'    const double &ay2 = a.second.y;
'    const double &bx1 = b.first.x;
'    const double &by1 = b.first.y;
'    const double &bx2 = b.second.x;
'    const double &by2 = b.second.y;
'
'    double a1 = ay2 - ay1;
'    double b1 = ax1 - ax2;
'    double c1 = a1 * ax1 + b1 * ay1;
'    double a2 = by2 - by1;
'    double b2 = bx1 - bx2;
'    double c2 = a2 * bx1 + b2 * by1;
'    double det = a1 * b2 - a2 * b1;
'
'    If (Zero(det)) Then
'        Intersects = False
'    Else
'        double x = (b2 * c1 - b1 * c2) / det;
'        double y = (a1 * c2 - a2 * c1) / det;
'
'        bool on_both = true;
'        on_both = on_both && LessThanOrEqual(std::min(ax1, ax2), x) && LessThanOrEqual(x, std::max(ax1, ax2));
'        on_both = on_both && LessThanOrEqual(std::min(ay1, ay2), y) && LessThanOrEqual(y, std::max(ay1, ay2));
'        on_both = on_both && LessThanOrEqual(std::min(bx1, bx2), x) && LessThanOrEqual(x, std::max(bx1, bx2));
'        on_both = on_both && LessThanOrEqual(std::min(by1, by2), y) && LessThanOrEqual(y, std::max(by1, by2));
'        return on_both;
'    End If
'End Function
'
'Private Function ToDegrees(ByVal radians As Double) As Double
'    ToDegrees = radians * 180 / PI
'End Function

VBA Delaunay and ConvexHull

I’ve tried to get a Delaunay code for VBA. I have to state it, I don’t know why the different approximations I had found of this algorithm perform so badly on VBA. In the web there is a lot of resources to compute a mesh, beeing this post a compilation of a lot of them. I was not to code my implementation from zero, so started cracking a code that was for CAD software; but it behave erratic and with the mentioned bad performance that I had to modify it hard (creating triangles and points as objects type). Either way, the implementation was very complex for the task, running profusively several costy functions (like sqr) and relying on a not well conceived stack system for the Delaunay condition.  My understanding of the pseudocode help was very basic -cause I didn’t want to start from that point-. As it would be better to rework the entire implementation, I left it there to rest. Some time after I hired some freelancer to convert a fantastic JS Voronoi-Fortuny implementation -that on the browser perform ashtonishing well- to VBA. Beeing a 700 line code I thought it would be easy for an experienced coder. It was not. The freelancer did the job (well nearly done, as it breaks with negative coordinates as he/she tried to draw inside Excel and used structures I had specified not to be used). In the end the code was a perfect JS translation, so perfect that I did learn some ways to bypass differences VBA-JS I thought were impossible to atain. But then came the handicaps… to do the bypass it had to rely in Collections and classes, so performance plummeted even below the CAD implementation. And to break the Collection-Class issue and get the code working was again a hard task. Even more, it returns a Voronoi mesh, when I was looking for a Delaunay one. Finally, I’m trying my own ideas. From zero. Not the best option, but in the middle I’m working on some points I’ll need in other codes, so did try. Here is an unfinished code, but you can see it draws the triangles and other related geometries inside an Excel Chart, so I can follow what is doing in every step. There is still some work to do on the stack block for the Delaunay diagonal swap, but things are on the right way:
Option Explicit

Public Type tXYZ
    X As Double
    Y As Double
    Z As Double
End Type

Private Type tTriangle
    V1 As Long 'vertex1 pointer
    V2 As Long 'vertex2 pointer
    V3 As Long 'vertex3 pointer
    T1 As Long 'neighbour1 pointer
    T2 As Long 'neighbour2 pointer
    T3 As Long 'neighbour3 pointer
    
    Xmin As Double
    Ymin As Double
    Xmax As Double
    Ymax As Double
    
    Center As tXYZ
    R² As Double
End Type

Dim oT() As tTriangle
Dim oP() As tXYZ
Dim oTTmp As tTriangle
Dim aStack() As Long
Dim aBlnk() As Long
Dim myFrm As UserForm

Private Const PI_8th As Double = 0.392699081698724
Private Const PI As Double = 3.14159265358979

Private Function fDrawTriangles() As Boolean
    Dim lgT As Long

    For lgT = LBound(oT) To UBound(oT)
    'Draw triangle in userform
        Call fDrawTriangle(lgT)
    Next lgT
End Function

Private Function fDrawTriangle(ByVal lgT As Long) As Boolean
    'Draw triangle in userform
    'Call fDrawLine(oP(oT(lgT).V1), oP(oT(lgT).V2))
    'Call fDrawLine(oP(oT(lgT).V2), oP(oT(lgT).V3))
    'Call fDrawLine(oP(oT(lgT).V3), oP(oT(lgT).V1))
End Function

Private Function fDrawLine(ByVal lgP1 As Long, ByVal lgP2 As Long) As Boolean
    
End Function

Private Function fPointsSort(ByRef oP() As tXYZ, _
                             Optional ByRef bX As Boolean = True, _
                             Optional ByRef bAscendent As Boolean = True) As Boolean
    Dim oPtTmp() As tXYZ
    Dim arrPtr() As Double 'tPointer
    Dim lgP As Long

    ReDim arrPtr(LBound(oP) To UBound(oP), 1 To 2)
    If bX Then
    ' Sort by X
        For lgP = LBound(oP) To UBound(oP)
            arrPtr(lgP, 1) = VBA.CLng(lgP) 'Index
            arrPtr(lgP, 2) = oP(lgP).X     'Value
        Next lgP
    Else
    ' Sort by Y
        For lgP = LBound(oP) To UBound(oP)
            arrPtr(lgP, 1) = VBA.CLng(lgP) 'Index
            arrPtr(lgP, 2) = oP(lgP).Y     'Value
        Next lgP
    End If
    Call fQuickSortArrayDbl(arrPtr(), -1, -1, 2, bAscendent)

    oPtTmp() = oP() ' copy source
    For lgP = LBound(oP) To UBound(oP)
        oP(lgP) = oPtTmp(arrPtr(lgP, 1))
    Next lgP
    Erase arrPtr()
    Erase oPtTmp()

End Function

Private Function fPoints(ByRef oP() As tXYZ) As Long
    If Not (Not oP) Then
        fPoints = UBound(oP) - LBound(oP) + 1
    Else
        fPoints = 0
    End If
End Function

Private Function fPointsFlip(ByRef oP() As tXYZ) As Boolean
    Dim oPTmp() As tXYZ
    Dim lgP As Long
    
    If Not (Not oP) Then
        oPTmp() = oP()
        ReDim Preserve oP(LBound(oP) To UBound(oP) - 1)
        For lgP = LBound(oP) To UBound(oP)
            oPTmp(UBound(oP) - lgP) = oP(lgP)
        Next lgP
        oP() = oPTmp()
        Erase oPTmp()
    End If
End Function

Private Function fPointRemove(ByRef oP() As tXYZ, ByVal lgP As Long) As Boolean
    Dim oPTmp() As tXYZ
    Dim lgRemove As Long
    
    If Not (Not oP) Then
        oPTmp() = oP()
        ReDim Preserve oPTmp(LBound(oP) To UBound(oP) - 1)
        For lgRemove = (UBound(oP) - 1) To lgP Step -1
            oPTmp(lgRemove) = oP(lgRemove + 1)
        Next lgRemove
        oP() = oPTmp()
        Erase oPTmp()
    End If
End Function

Private Function fPointAdd(ByRef oP() As tXYZ, ByRef oPt As tXYZ) As Boolean
    If Not (Not oP) Then
        ReDim Preserve oP(LBound(oP) To UBound(oP) + 1)
    Else
        ReDim Preserve oP(0)
    End If
    oP(UBound(oP)) = oPt
End Function

Private Function fConvexHull() As tXYZ()
' Graham-Scan
' https://www.geeksforgeeks.org/convex-hull-set-2-graham-scan/
' The algorithm can be adapted to a 3D space, considering these:
' - the four points A, B, C, D become eight
' - the quadrilateral becomes a polyhedron with eight vertices
' - the rectangle becomes a parallelepiped
    
    Dim oP´() As tXYZ
    Dim oP´´() As tXYZ
    Dim oPrun() As tXYZ
    Dim oPrun´() As tXYZ
    Dim oHull() As tXYZ
    Dim lgDecalageRGT As Long
    Dim lgP As Long
    Dim lgPts As Long
    Dim lgTop As Long
    Dim lgPrun´ As Long
    Dim lgPrun´´ As Long
    Dim bPrun As Boolean
    Dim bPrint As Boolean: bPrint = False
bPrint = False
    If fPoints(oP) = 0 Then
    ' Get list of points...
        Call sPointsRnd(100000000, 0, 1000, 0, 1000)
Call fPointsPrint(oP(), 1, 2, 1, -1, -1, bPrint)
    End If

Dim dtTimer As Date
dtTimer = VBA.Now()
    
    oPrun() = fPrunePolygon(oP())
Call fPointsPrint(oPrun(), 3, 4, 1, -1, -1, bPrint)
    
    ' Get rectangle R:
    ' X1 = Max(Dx, Ax)
    ' X2 = Min(Bx, Cx)
    ' Y1 = Max(By, Ay)
    ' Y2 = Min(Cy, Dy)
    ' Rectangle R with vertices: (x2, y1), (x2, y2), (x1, y2), (x1, y1)
    
    oPrun´() = oPrun()
    If oPrun(0).X < oPrun(3).X Then oPrun´(0).X = oPrun(3).X Else oPrun´(3).X = oPrun(0).X 'maxX A-D If oPrun(1).X > oPrun(2).X Then oPrun´(1).X = oPrun(2).X Else oPrun´(2).X = oPrun(1).X 'minX B-C
    If oPrun(0).Y < oPrun(1).Y Then oPrun´(0).Y = oPrun(1).Y Else oPrun´(1).Y = oPrun(0).Y 'maxY A-B If oPrun(2).Y > oPrun(3).Y Then oPrun´(2).Y = oPrun(3).Y Else oPrun´(3).Y = oPrun(2).Y 'minY C-D
Call fPointsPrint(oPrun´(), 5, 6, 1, -1, -1, bPrint)
    
    '#1st pass
    Erase oP´()
    oP´() = oP()
    oP´´() = oP()
    lgPrun´ = LBound(oP´´) - 1
    lgPrun´´ = LBound(oP´´) - 1
    For lgP = LBound(oP) To UBound(oP)
        bPrun = False
        If oPrun´(0).X > oP(lgP).X Then
            lgPrun´´ = lgPrun´´ + 1
            oP´´(lgPrun´´) = oP(lgP)
        ElseIf oPrun´(0).Y > oP(lgP).Y Then
            lgPrun´´ = lgPrun´´ + 1
            oP´´(lgPrun´´) = oP(lgP)
        ElseIf oPrun´(2).X < oP(lgP).X Then
            lgPrun´´ = lgPrun´´ + 1
            oP´´(lgPrun´´) = oP(lgP)
        ElseIf oPrun´(2).Y < oP(lgP).Y Then lgPrun´´ = lgPrun´´ + 1 oP´´(lgPrun´´) = oP(lgP) Else lgPrun´ = lgPrun´ + 1 oP´(lgPrun´) = oP(lgP) End If Next lgP ReDim Preserve oP´(0 To lgPrun´) ' outside R ReDim Preserve oP´´(0 To lgPrun´´) ' inside R Call fPointsPrint(oP´(), 7, 8, 1, -1, -1, bPrint) Call fPointsPrint(oP´´(), 9, 10, 1, -1, -1, bPrint) '#2nd pass lgPrun´´ = LBound(oP´´) - 1 For lgP = LBound(oP´´) To UBound(oP´´) If Not fPointInsidePolygon(oP´´(lgP), oPrun()) Then lgPrun´´ = lgPrun´´ + 1 oP´´(lgPrun´´) = oP´´(lgP) End If Next lgP ReDim Preserve oP´´(0 To lgPrun´´) ' outside Q Call fPointsPrint(oP´´(), 11, 12, 1, -1, -1, bPrint) Call fPointsSort(oP´´(), False, True) ReDim Preserve oHull(LBound(oP´´) To UBound(oP´´)) ' Pick the bottom-most (choose the left-most point in case of tie) oHull(LBound(oP)) = oP´´(LBound(oP´´)) lgPts = LBound(oP´´) ' Right side hull For lgP = (LBound(oP´´) + 1) To UBound(oP´´) '!Do While (UBound(oHull) >= 1)
        Do While (lgPts >= 2)
            ' If two or more points make same angle with p0, remove all but the one that is farthest from p0
            ' (in above sorting our criteria was to keep the farthest point at the end)
            '!If CCW(oHull(UBound(oHull) - 1), oHull(UBound(oHull)), oP´´(lgP)) Then Exit Do
            If CCW(oHull(lgPts - 2), oHull(lgPts - 1), oP´´(lgP)) Then Exit Do
            
            'Remove UBound(oHull) point from oHull()
            '!ReDim Preserve oHull(LBound(oHull) To UBound(oHull) - 1)
            lgPts = lgPts - 1
        Loop
        
        'Add Point oP´´(lgP) to oHull()
        '!ReDim Preserve oHull(LBound(oHull) To UBound(oHull) + 1)
        '!oHull(UBound(oHull)) = oP´´(lgP)
        oHull(lgPts) = oP´´(lgP)
        lgPts = lgPts + 1
    Next lgP
    
    ' Left side hull
    lgTop = lgPts
    For lgP = (UBound(oP´´) - 1) To LBound(oP´´) Step -1
        '!Do While (UBound(oHullLFT) >= 1)
        Do While (lgPts > lgTop)
            '!If CCW(oHullLFT(UBound(oHullLFT) - 1), oHullLFT(UBound(oHullLFT)), oP´´(lgP)) Then Exit Do
            If CCW(oHull(lgPts - 2), oHull(lgPts - 1), oP´´(lgP)) Then Exit Do
        
            'Remove UBound(oHull) point from oHull()
            '!ReDim Preserve oHullLFT(LBound(oHullLFT) To UBound(oHullLFT) - 1)
            lgPts = lgPts - 1
        Loop
    
        'Add Point oP´´(lgP) to oHull()
        '!ReDim Preserve oHullLFT(LBound(oHullLFT) To UBound(oHullLFT) + 1)
        '!oHullLFT(UBound(oHullLFT)) = oP´´(lgP)
        oHull(lgPts) = oP´´(lgP)
        lgPts = lgPts + 1
    Next lgP
        
    ReDim Preserve oHull(LBound(oHull) To lgPts - 1)
Call fPointsPrint(oHull(), 13, 14, 1, -1, -1, bPrint)
    
    fConvexHull = oHull()
    'Erase oHull()
Call fPointsPrint(oHull(), 15, 16, 1, -1, -1, bPrint)
Debug.Print dtTimer & " vs " & VBA.Now()
End Function

Private Function fPointsPrint(ByRef oP() As tXYZ, _
                              Optional ByVal lC_X As Long = 1, _
                              Optional ByVal lC_Y As Long = 2, _
                              Optional ByVal lR_Start As Long = 1, _
                              Optional ByVal lgP_Start As Long = -1, _
                              Optional ByVal lgP_End As Long = -1, _
                              Optional ByVal bPrint = False) As Boolean
    Dim lgP As Long
    Dim lgR As Long
    
    If Not bPrint Then Exit Function
    
    If lgP_Start < LBound(oP) Then lgP_Start = LBound(oP)
    If lgP_End < LBound(oP) Then lgP_End = UBound(oP)
    lgR = lR_Start
    If lgP_Start <= lgP_End Then
        For lgP = lgP_Start To lgP_End
            Cells(lgR, lC_X).Value2 = oP(lgP).X
            Cells(lgR, lC_Y).Value2 = oP(lgP).Y
            lgR = lgR + 1
        Next lgP
    Else 'descending
        For lgP = lgP_Start To lgP_End Step -1
            Cells(lgR, lC_X).Value2 = oP(lgP).X
            Cells(lgR, lC_Y).Value2 = oP(lgP).Y
            lgR = lgR + 1
        Next lgP
    End If
End Function

Private Function fPointInsidePolygon(ByRef oPoint As tXYZ, ByRef oPolygon() As tXYZ) As Boolean
    Dim lgP As Long
    Dim iInside As Integer
    
    ' Avoid no segment (coincident points)
    For lgP = LBound(oPolygon) To UBound(oPolygon) - 1
        If oPolygon(lgP).X = oPolygon(lgP + 1).X And oPolygon(lgP).Y = oPolygon(lgP + 1).Y Then
            Call fPointRemove(oPolygon(), lgP)
        End If
    Next lgP
    
    iInside = fLineSide(oPoint, oPolygon(LBound(oPolygon)), oPolygon(LBound(oPolygon) + 1))
    For lgP = LBound(oPolygon) + 1 To UBound(oPolygon) - 1
        If iInside <> fLineSide(oPoint, oPolygon(lgP), oPolygon(lgP + 1)) Then Exit Function
    Next lgP
    If oPolygon(LBound(oPolygon)).X <> oPolygon(UBound(oPolygon)).X Or oPolygon(LBound(oPolygon)).Y <> oPolygon(UBound(oPolygon)).Y Then
        If iInside <> fLineSide(oPoint, oPolygon(UBound(oPolygon)), oPolygon(LBound(oPolygon))) Then Exit Function
    End If
    fPointInsidePolygon = True
End Function

Private Function NewPoint(Optional ByVal X As Double = 0, _
                          Optional ByVal Y As Double = 0, _
                          Optional ByVal Z As Double = 0) As tXYZ
    With NewPoint
        .X = X
        .Y = Y
        .Z = Z
    End With
End Function

Private Function fPrunePolygon(ByRef oP() As tXYZ) As tXYZ()
'   A, B, C, D As Points
'   Q As Quadrilateral
'   R As Rectangle
'   DD As Diamond [(Xmid, Ymin)
'
'   for each Point p in oP
'         Update A, B, C, D --> Q
'   # First pass
'   Create R from Q
'   for each Point p in S
'      if p inside R
'         prune p from S
'   # Second pass
'   for each Point p in S
'      if p inside Q
'         prune p from S

'   ^         D    / +\
'   |           /....  + \
'   |        /  / Q x....   \ C
'   |     /    /---------....| \
'   |  /      /|   *     *   |    \
'   |  \     /x|*    R  *  * | +  /
'   |     \ /..|.....--------|  /
'   |      A \        ..x...|/ B
'   |           \ +  +   /
'   |              \  /
'   --------------------------->
'
'   * points inside R rectangle are prunable
'   x point inside Q are prunable but not until the end
'   + point outside Q are not prunable
'
    If fPoints(oP) = 0 Then
    ' Get list of points...
        Call sPointsRnd(300, 0, 100, 0, 100)
    End If
    
    Dim PtA As tXYZ, PtB As tXYZ, PtC As tXYZ, PtD As tXYZ
    Dim Q(0 To 3) As tXYZ 'Quadrilateral
    Dim R(0 To 3) As tXYZ 'Rectangle
    Dim DD(0 To 3) As tXYZ  'Diamond

    Dim lgP As Long

    Q(0) = oP(LBound(oP)): Q(1) = Q(0): Q(2) = Q(0): Q(3) = Q(0)
    For lgP = LBound(oP) To UBound(oP)
        With Q(0) ' Point A
            If (-.X - .Y) < (-oP(lgP).X - oP(lgP).Y) Then Q(0) = oP(lgP)
        End With
        With Q(1) ' Point B
            If (.X - .Y) < (oP(lgP).X - oP(lgP).Y) Then Q(1) = oP(lgP)
        End With
        With Q(2) ' Point C
            If (.X + .Y) < (oP(lgP).X + oP(lgP).Y) Then Q(2) = oP(lgP)
        End With
        With Q(3) ' Point D
            If (-.X + .Y) < (-oP(lgP).X + oP(lgP).Y) Then Q(3) = oP(lgP)
        End With
    Next lgP

    fPrunePolygon = Q()
End Function

Private Sub sPointsRnd(Optional ByVal lgPts As Long = 0, _
                       Optional ByVal Xmin As Double = 0, _
                       Optional ByVal Xmax As Double = 0, _
                       Optional ByVal Ymin As Double = 0, _
                       Optional ByVal Ymax As Double = 0)
    Dim lgP As Long
    Dim dbTmp As Long

    If Xmin = 0 Then Xmin = (Rnd() * 100) + 0
    If Xmax = 0 Then Xmax = (Rnd() * 100) + 0
    If Ymin = 0 Then Ymin = (Rnd() * 100) + 0
    If Ymax = 0 Then Ymax = (Rnd() * 100) + 0
    If Xmax < Xmin Then
        Xmax = dbTmp
        Xmax = Xmin
        Xmin = dbTmp
    End If
    If Ymax < Ymin Then
        Ymax = dbTmp
        Ymax = Ymin
        Ymin = dbTmp
    End If
    ReDim Preserve oP(0 To lgPts - 1)
    For lgP = LBound(oP) To UBound(oP)
        oP(lgP) = NewPoint((Rnd() * Xmax - Xmin) + Xmin, (Rnd() * Ymax - Ymin) + Ymin)
    Next lgP
End Sub

Private Sub sDelaunay()
    Dim oChrt As Excel.ChartObject
    Dim rgData As Excel.Range
    Dim aData As Variant
    Dim lgP As Long
    Dim lgT As Long
    Dim lgTs As Long ' total number of triangles
    Dim Xmin As Double, Ymin As Double
    Dim Xmax As Double, Ymax As Double
    Dim Xmid As Double, Ymid As Double
    Dim HSide As Double, VSide As Double
    Dim i12 As Integer, i23 As Integer, i31 As Integer
    Dim bDalaunay As Boolean
    
    ' Elements are sorted by X
    With ActiveSheet
        Call sPointsCreate(10)
        Set rgData = .Range("A1", .Range("B1", .Range("B1").End(xlDown)))
    End With
    aData = rgData.Value2
    'ReDim oP(0 To 2 + (UBound(aData, 1) - LBound(aData, 1) + 1))
    ReDim aStack(LBound(oP) To UBound(oP)) As Long
    ReDim aBlnk(LBound(oP) To UBound(oP)) As Long
    
    For lgP = LBound(oP) + 3 To UBound(oP)
        With oP(lgP)
            '.X = aData(lgP - 2, 1)
            '.Y = aData(lgP - 2, 2)
            If .X < Xmin Then Xmin = .X If .X > Xmax Then Xmax = .X
            If .Y < Ymin Then Ymin = .Y If .Y > Ymax Then Ymax = .Y
        End With
    Next lgP
    
    lgT = -1
    
    ' Generate the super-triangle
    Xmid = 0.5 * (Xmax + Xmin)
    Ymid = 0.5 * (Ymax + Ymin)
    HSide = 2 * (Xmid - Xmin)
    VSide = 2 * (Ymid - Ymin)
    With oP(LBound(oP) + 0)
        .X = Xmid - (3 * HSide)
        .Y = Ymid - (3 * VSide)
    End With
    With oP(LBound(oP) + 1)
        .X = Xmid
        .Y = Ymid + (3 * VSide)
    End With
    With oP(LBound(oP) + 2)
        .X = Xmid + (3 * HSide)
        .Y = Ymid - (3 * VSide)
    End With
    
    Set oChrt = ActiveSheet.ChartObjects("ChrtPts")
    Call fChrtSeriesDelete(oChrt)

    ' Add supertriangle points
    Call fChrtTriangleAdd(oP(LBound(oP) + 0), _
                          oP(LBound(oP) + 1), _
                          oP(LBound(oP) + 2), _
                          oChrt)
    
    lgT = lgT + 1
    lgTs = lgT
    ReDim Preserve oT(0 To lgT)
    With oT(lgT)
        .T1 = -1
        .T2 = -2
        .T3 = -3
    
        .V1 = LBound(oP) + 0
        .V2 = LBound(oP) + 1
        .V3 = LBound(oP) + 2
    End With
    
    ' Get new max-min coordinates...
    Call fTriangleParameters(lgT)

    ' Generate new triangles:
    For lgP = LBound(oP) + 3 To UBound(oP)
        Call fChrtPtHighlight(oChrt, 1, lgP - 3 + 1, True)
        'Call fChrtPtAdd(oP(lgP), oChrt)

        For lgT = LBound(oT) To UBound(oT)
            ' Discard point inside boundary
            If oP(lgP).X < oT(lgT).Xmax Then If oP(lgP).X > oT(lgT).Xmin Then
            If oP(lgP).Y < oT(lgT).Ymax Then If oP(lgP).Y > oT(lgT).Ymin Then
                ' Point is inside boundary of triangle, so check more intensively
                i12 = fLineSide(oP(lgP), oP(oT(lgT).V2), oP(oT(lgT).V1))
                i23 = fLineSide(oP(lgP), oP(oT(lgT).V3), oP(oT(lgT).V2))
                i31 = fLineSide(oP(lgP), oP(oT(lgT).V1), oP(oT(lgT).V3))
                
                If (i12 = i23 And i23 = i31) Then
                    ReDim Preserve oT(0 To lgTs + 2)
                    ' Always store points in Counter-clockwise order (last point is new point)
                    With oT(lgTs + 1)
                        .T1 = oT(lgT).T2
                        .T2 = lgTs + 2
                        .T3 = lgT
                    
                        .V1 = oT(lgT).V2
                        .V2 = oT(lgT).V3
                        .V3 = lgP
                    
                        ' Add supertriangle points
                        Call fChrtTriangleAdd(oP(.V1), _
                                              oP(.V2), _
                                              oP(.V3), _
                                              ActiveSheet.ChartObjects("ChrtPts"))
                    End With
                    
                    With oT(lgTs + 2)
                        .T1 = oT(lgT).T3
                        .T2 = lgT
                        .T3 = lgTs + 1
                    
                        .V1 = oT(lgT).V3
                        .V2 = oT(lgT).V1
                        .V3 = lgP
                        
                        ' Add supertriangle points
                        Call fChrtTriangleAdd(oP(.V1), _
                                              oP(.V2), _
                                              oP(.V3), _
                                              ActiveSheet.ChartObjects("ChrtPts"))
                    End With
                    
                    ' Reformat initial triangle
                    With oT(lgT)
                        '.T1 = oT(lgT).T1 ' this neighbour is not rewritten
                        .T2 = lgTs + 1
                        .T3 = lgTs + 2
                    
                        '.V1 = .V1 ' this vertex is not rewritten
                        '.V2 = .V2 ' this vertex is not rewritten
                        .V3 = lgP
                    End With
                    
                    ' Get new max-min coordinates for final triangles...
                    Call fTriangleParameters(lgT)
                    Call fTriangleParameters(lgTs + 1)
                    Call fTriangleParameters(lgTs + 2)
                    
                    lgTs = lgTs + 2
    
                    ' Is the optimum delaunay?
                    ' Each new triangle has three neighbours that have to be checked for Delaunay condition
                    ' For Neighbour triangle 1
                    'call fDelaunay(lgT, oT(lgT).T1)
                    
                    ' For Neighbour triangle 2
                    'call fDelaunay(lgT, oT(lgT).T2)
                    
                    ' For Neighbour triangle 3
                    'Call fDelaunay(lgT, oT(lgT).T3)
                    
                    Exit For ' Goto NextTriangle
                End If
            End If
            End If
            End If
            End If
        Next lgT
        
        Call fChrtPtHighlight(oChrt, 1, lgP - 3, False)
    Next lgP

    ' Delete triangles on the supertriangle structure
    Dim oT_() As tTriangle: oT_() = oT()
    For lgT = LBound(oT) To UBound(oT)
        With oT(lgT)
            If .V1 >= 0 And _
               .V2 >= 0 And _
               .V3 >= 0 Then
               'lgT_ = lgT_ + 1
               'oT_(0 to lgT) = oT(lgT)
            End If
        End With
    Next lgT
    'Redim preserve oT_(0 to lgT_)
    'oT() = oT_()
    'Erase oT_()
Stop
End Sub

Private Function fDelaunay(ByVal lgT1 As Long, _
                           ByVal lgT2 As Long) As Boolean
    Dim bSwap As Boolean
    Dim TPtrTmp As Long
    
    ' Rotate vertices of both triangles so in both triangles vertices 3 are opposed
    If oT(lgT1).V1 = oT(lgT2).V2 And oT(lgT1).V2 = oT(lgT2).V1 Then
        ' Do nothing...
    ElseIf oT(lgT1).V1 = oT(lgT2).V1 And oT(lgT1).V2 = oT(lgT2).V3 Then
        ' rotate 2 clockwise
        Call fTriangleRotate(lgT2, False)
    ElseIf oT(lgT1).V1 = oT(lgT2).V3 And oT(lgT1).V2 = oT(lgT2).V2 Then
        ' rotate 2 counter-clockwise
        Call fTriangleRotate(lgT2, True)
'--
    ElseIf oT(lgT1).V2 = oT(lgT2).V1 And oT(lgT1).V3 = oT(lgT2).V3 Then
        ' rotate 1 counter-clockwise
        Call fTriangleRotate(lgT1, True)
        ' rotate 2 clockwise
        Call fTriangleRotate(lgT2, False)
    ElseIf oT(lgT1).V2 = oT(lgT2).V2 And oT(lgT1).V3 = oT(lgT2).V1 Then
        ' rotate 1 counter-clockwise
        Call fTriangleRotate(lgT1, True)
    ElseIf oT(lgT1).V2 = oT(lgT2).V3 And oT(lgT1).V3 = oT(lgT2).V2 Then
        ' rotate 1 counter-clockwise
        Call fTriangleRotate(lgT1, True)
        ' rotate 2 counter-clockwise
        Call fTriangleRotate(lgT2, True)
'--
    ElseIf oT(lgT1).V3 = oT(lgT2).V1 And oT(lgT1).V1 = oT(lgT2).V3 Then
        ' rotate 1 clockwise
        Call fTriangleRotate(lgT1, False)
        ' rotate 2 clockwise
        Call fTriangleRotate(lgT2, False)
    ElseIf oT(lgT1).V3 = oT(lgT2).V2 And oT(lgT1).V1 = oT(lgT2).V1 Then
        ' rotate 1 clockwise
        Call fTriangleRotate(lgT1, False)
    ElseIf oT(lgT1).V3 = oT(lgT2).V3 And oT(lgT1).V1 = oT(lgT2).V2 Then
        ' rotate 1 clockwise
        Call fTriangleRotate(lgT1, False)
        ' rotate 2 counter-clockwise
        Call fTriangleRotate(lgT2, True)
    End If
    
    If fDistance2DPoints(oP(oT(lgT2).V2), oT(lgT1).Center) < EPSILON Then bSwap = True TPtrTmp = oT(lgT1).T2 'Destroy oT(lgT1).T1 and oT(lgT2).T1 oT(lgT1).T1 = oT(lgT2).T2 oT(lgT1).T2 = lgT2 'oT(lgT1).T3 = does not change oT(lgT2).T1 = TPtrTmp oT(lgT2).T2 = lgT1 'oT(lgT2).T3 = does not change ' Swap vertices oT(lgT1).V2 = oT(lgT2).V3 oT(lgT2).V2 = oT(lgT1).V3 End If If bSwap Then Call fTriangleParameters(lgT1) Call fTriangleParameters(lgT2) ' 'Call fDelaunay(lgT1, oT(lgT1).T1) Then 'Call fDelaunay(lgT1, oT(lgT1).T2) Then 'Call fDelaunay(lgT1, oT(lgT1).T3) Then ' 'Call fDelaunay(lgT2, oT(lgT2).T1) Then 'Call fDelaunay(lgT2, oT(lgT2).T2) Then 'Call fDelaunay(lgT2, oT(lgT2).T3) Then Else fDelaunay = True End If End Function Private Function fTriangleRotate(ByRef lgT As Long, _ Optional ByVal bCCW As Boolean = True) As Boolean ' Given a triangle, rotate vertices oTTmp = oT(lgT) With oT(lgT) If bCCW Then ' counter-clockwise .V1 = oTTmp.V2 .V2 = oTTmp.V3 .V3 = oTTmp.V1 .T1 = oTTmp.T2 .T2 = oTTmp.T3 .T3 = oTTmp.T1 Else .V1 = oTTmp.V3 .V2 = oTTmp.V1 .V3 = oTTmp.V2 .T1 = oTTmp.T3 .T2 = oTTmp.T1 .T3 = oTTmp.T2 End If End With End Function Private Function fDelaunayDiagonal(ByRef lgT1 As Long, _ ByRef lgT2 As Long) As Boolean ' Given two triangles, find the opposed vertices ' Rotate triangles so the 3 vertices are opposed... Dim dX1 As Double, dY1 As Double Dim dX2 As Double, dY2 As Double dX1 = oP(oT(lgT1).V3).X - oP(oT(lgT2).V3).X dY1 = oP(oT(lgT1).V3).Y - oP(oT(lgT2).V3).Y dX2 = oP(oT(lgT1).V1).X - oP(oT(lgT2).V2).X dY2 = oP(oT(lgT1).V1).Y - oP(oT(lgT2).V2).Y If ((dX1 * dX1) + (dY1 * dY1)) > ((dX2 * dX2) + (dY2 * dY2)) Then
        Call fSwapDiagonal(lgT1, lgT2)
    End If
End Function

Private Function fSwapDiagonal(ByRef lgT1 As Long, _
                               ByRef lgT2 As Long) As Boolean
' For given diagonal D1 on triangle T1 = diagonal D2 on triangle T2, will swap diagonals with opposed vertices
' Rotate triangles so the 3 vertices are opposed...
    Dim TPtrTmp As Long

    With oT(lgT1)
        TPtrTmp = .T2
        
        'Destroy oT(lgT1).T1 and oT(lgT2).T1
        .T1 = oT(lgT2).T2
        .T2 = lgT2
        '.T3 = does not change
    End With
    
    With oT(lgT2)
        .T1 = TPtrTmp
        .T2 = lgT1
        '.T3 = does not change
    End With
    
    ' Swap vertices
    oT(lgT1).V2 = oT(lgT2).V3
    oT(lgT2).V2 = oT(lgT1).V3

End Function

Private Function fNeigbourSide(ByRef iSide As Integer, _
                               ByRef lgT1 As Long, _
                               ByRef lgT2 As Long) As Integer
' For given iSide on triangle1, return neighbour side on triangle2.
' Both triangles turn the same: 1->2->3
    
    If iSide = 1 Then
        If oT(lgT1).V1 = oT(lgT2).V1 Then
'            fNeigbourSide = 3
        ElseIf oT(lgT1).V1 = oT(lgT2).V2 Then
'            fNeigbourSide = 2
        ElseIf oT(lgT1).V1 = oT(lgT2).V3 Then
'            fNeigbourSide = 1
        End If
    ElseIf iSide = 2 Then
        If oT(lgT1).V2 = oT(lgT2).V1 Then
'            fNeigbourSide = 3
        ElseIf oT(lgT1).V2 = oT(lgT2).V2 Then
'            fNeigbourSide = 2
        ElseIf oT(lgT1).V2 = oT(lgT2).V3 Then
'            fNeigbourSide = 1
        End If
    ElseIf iSide = 3 Then
        If oT(lgT1).V3 = oT(lgT2).V1 Then
'            fNeigbourSide = 3
        ElseIf oT(lgT1).V3 = oT(lgT2).V2 Then
'            fNeigbourSide = 2
        ElseIf oT(lgT1).V3 = oT(lgT2).V3 Then
'            fNeigbourSide = 1
        End If
    End If
End Function

Private Function fTriangleFromPoints(ByRef oP1 As tXYZ, _
                                     ByRef oP2 As tXYZ, _
                                     ByRef oP3 As tXYZ) As tTriangle
    With fTriangleFromPoints
        .V1 = 1
        .V2 = 2
        .V3 = 3
        
        .T1 = -1
        .T2 = -2
        .T3 = -3
        
        .Xmin = oP1.X
        .Xmax = oP1.X
        .Ymin = oP1.Y
        .Ymax = oP1.Y
    
        If .Xmin > oP2.X Then .Xmin = oP2.X
        If .Xmin > oP3.X Then .Xmin = oP3.X
        If .Xmax < oP2.X Then .Xmax = oP2.X
        If .Xmax < oP3.X Then .Xmax = oP3.X If .Ymin > oP2.Y Then .Ymin = oP2.Y
        If .Ymin > oP3.Y Then .Ymin = oP3.Y
        If .Ymax < oP2.Y Then .Ymax = oP2.Y
        If .Ymax < oP3.Y Then .Ymax = oP3.Y Dim B As tXYZ Dim C As tXYZ Dim D As Double Dim Bx² As Double Dim By² As Double Dim Cx² As Double Dim Cy² As Double B.X = oP2.X - oP1.X B.Y = oP2.Y - oP1.Y C.X = oP3.X - oP1.X C.Y = oP3.Y - oP1.Y Bx² = B.X * B.X: By² = B.Y * B.Y Cx² = C.X * C.X: Cy² = C.Y * C.Y D = 1 / (2 * (B.X * C.Y - B.Y * C.X)) .Center.X = D * (C.Y * (Bx² + By²) - B.Y * (Cx² + Cy²)) .Center.Y = D * (B.X * (Cx² + Cy²) - C.X * (Bx² + By²)) .R² = (.Center.X * .Center.X) + (.Center.Y * .Center.Y) .Center.X = .Center.X + oP1.X .Center.Y = .Center.Y + oP1.Y End With End Function Private Function fTriangleParameters(ByRef lgT As Long) As Boolean With oT(lgT) .Xmin = oP(.V1).X .Xmax = oP(.V1).X .Ymin = oP(.V1).Y .Ymax = oP(.V1).Y If .Xmin > oP(.V2).X Then .Xmin = oP(.V2).X
        If .Xmin > oP(.V3).X Then .Xmin = oP(.V3).X
        If .Xmax < oP(.V2).X Then .Xmax = oP(.V2).X
        If .Xmax < oP(.V3).X Then .Xmax = oP(.V3).X If .Ymin > oP(.V2).Y Then .Ymin = oP(.V2).Y
        If .Ymin > oP(.V3).Y Then .Ymin = oP(.V3).Y
        If .Ymax < oP(.V2).Y Then .Ymax = oP(.V2).Y
        If .Ymax < oP(.V3).Y Then .Ymax = oP(.V3).Y
        
        .Center = Circumcenter(oP(.V1).X, oP(.V1).Y, oP(.V2).X, oP(.V2).Y, oP(.V3).X, oP(.V3).Y)
        .R² = (.Center.X - oP(.V1).X) ^ 2 + (.Center.Y - oP(.V1).Y) ^ 2
        
        'Dim B As tXYZ
        'Dim C As tXYZ
        'Dim D As Double
        'Dim Bx² As Double
        'Dim By² As Double
        'Dim Cx² As Double
        'Dim Cy² As Double
        '
        'B.X = oP(.V2).X - oP(.V1).X
        'B.Y = oP(.V2).Y - oP(.V1).Y
        'C.X = oP(.V3).X - oP(.V1).X
        'C.Y = oP(.V3).Y - oP(.V1).Y
        'Bx² = B.X * B.X: By² = B.Y * B.Y
        'Cx² = C.X * C.X: Cy² = C.Y * C.Y
        'D = 1 / (2 * (B.X * C.Y - B.Y * C.X))
        '.Center.X = D * (C.Y * (Bx² + By²) - B.Y * (Cx² + Cy²))
        '.Center.Y = D * (B.X * (Cx² + Cy²) - C.X * (Bx² + By²))
        '.R² = (.Center.X * .Center.X) + (.Center.Y * .Center.Y)
        '.Center.X = .Center.X + oP(.V1).X
        '.Center.Y = .Center.Y + oP(.V1).Y
    End With
End Function

Private Function Circumcenter(ByVal x1 As Double, ByVal y1 As Double, _
                              ByVal x2 As Double, ByVal y2 As Double, _
                              ByVal x3 As Double, ByVal y3 As Double) As tXYZ
    Dim A As Double
    Dim B As Double
    Dim C As Double
    Dim D As Double

    A = x1 * x1 + y1 * y1
    B = x2 * x2 + y2 * y2
    C = x3 * x3 + y3 * y3
    D = 2 * (x1 * (y2 - y3) + x2 * (y3 - y1) + x3 * (y1 - y2))
    
    If D <> 0 Then
        With Circumcenter
            .X = (A * (y2 - y3) + B * (y3 - y1) + C * (y1 - y2)) / D
            .Y = (A * (x3 - x2) + B * (x1 - x3) + C * (x2 - x1)) / D
        End With
    End If
End Function

Private Sub sLineSide()
    Dim oPoint As tXYZ, oPt1 As tXYZ, oPt2 As tXYZ

    With oPoint
        .X = 1
        .Y = -1
    End With
    With oPt1
        .X = 0
        .Y = 0
    End With
    With oPt2
        .X = 10
        .Y = 0
    End With
    Debug.Print fLineSide(oPoint, oPt1, oPt2)
End Sub

Private Function CCW(ByRef oPt1 As tXYZ, _
                     ByRef oPt2 As tXYZ, _
                     ByRef oPt3 As tXYZ) As Boolean
' If counter clock-wise, then CCW is true
    CCW = ((oPt2.X - oPt1.X) * (oPt3.Y - oPt1.Y)) > ((oPt2.Y - oPt1.Y) * (oPt3.X - oPt1.X))
End Function

Private Function fLineSide(ByRef oPoint As tXYZ, _
                           ByRef oPt1 As tXYZ, _
                           ByRef oPt2 As tXYZ) As Integer
' Use the sign of the determinant of vectors (AB,AM), where M(X,Y) is the query point:
' Position = Sign((Bx - Ax) * (Y - Ay) - (By - Ay) * (X - Ax))
' It is 0 on the line, and -1 on right side, +1 on the left side.
    
    fLineSide = VBA.Sgn((oPt2.X - oPt1.X) * (oPoint.Y - oPt1.Y) - (oPt2.Y - oPt1.Y) * (oPoint.X - oPt1.X))

End Function

Private Function fChrtSeriesDelete(ByVal oChrt As Excel.ChartObject)
    Dim lgSeries As Long
    
    With oChrt
        With .Chart.SeriesCollection
            For lgSeries = .Count To 2 Step -1
                oChrt.Chart.SeriesCollection(lgSeries).Delete
            Next lgSeries
        End With
    End With
End Function

Private Function fChrtCircleAdd(ByRef oCenter As tXYZ, _
                                ByRef Radius As Double, _
                                Optional ByVal oChrt As Excel.ChartObject) As Boolean
    Dim oSeries As Excel.Series
    Dim lgAngle As Long
    Dim dbAngleRAD As Double
    Dim strX As String
    Dim strY As String
    
    With oChrt
        With .Chart
            Set oSeries = .SeriesCollection.NewSeries
            With oSeries
                For lgAngle = 0 To 17
                    dbAngleRAD = lgAngle * PI_8th
                    strX = strX & Replace(oCenter.X + Radius * Cos(dbAngleRAD), ",", ".") & ","
                    strY = strY & Replace(oCenter.Y + Radius * Sin(dbAngleRAD), ",", ".") & ","
                Next lgAngle
                strX = VBA.Left$(strX, Len(strX) - 1)
                strY = VBA.Left$(strY, Len(strY) - 1)
                .XValues = "={" & strX & "}"
                .Values = "={" & strY & "}"
                With .Format.Line
                    .Visible = msoTrue
                    '.ForeColor.ObjectThemeColor = msoThemeColorAccent1
                    '.ForeColor.TintAndShade = 0
                    '.ForeColor.Brightness = 0
                    .Weight = 0.25
                    .Visible = msoTrue
                    .DashStyle = msoLineSysDash
                End With
            End With
        End With
    End With
End Function

Private Function fChrtTriangleAdd(ByRef oPt1 As tXYZ, _
                                  ByRef oPt2 As tXYZ, _
                                  ByRef oPt3 As tXYZ, _
                                  Optional ByVal oChrt As Excel.ChartObject) As Boolean
    Dim oSeries As Excel.Series
    
    With oChrt
        With .Chart
            Set oSeries = .SeriesCollection.NewSeries
            With oSeries
                .XValues = "={" & Replace(oPt1.X, ",", ".") & "," & Replace(oPt2.X, ",", ".") & "," & Replace(oPt3.X, ",", ".") & "," & Replace(oPt1.X, ",", ".") & "}"
                .Values = "={" & Replace(oPt1.Y, ",", ".") & "," & Replace(oPt2.Y, ",", ".") & "," & Replace(oPt3.Y, ",", ".") & "," & Replace(oPt1.Y, ",", ".") & "}"
                With .Format.Line
                    .Visible = msoTrue
                    .Weight = 0.25
                    .DashStyle = msoLineSysDash
                    '.ForeColor.ObjectThemeColor = msoThemeColorAccent1
                    '.ForeColor.TintAndShade = 0
                    '.ForeColor.Brightness = 0
                End With
            End With
        End With
    End With
End Function

Private Function fChrtPtAdd(ByRef oPt As tXYZ, _
                            Optional ByVal oChrt As Excel.ChartObject)
    Dim oSeries As Excel.Series
    
    With oChrt
        With .Chart
            Set oSeries = .SeriesCollection.NewSeries
            With oSeries
                .XValues = "={" & Replace(oPt.X, ",", ".") & "}"
                .Values = "={" & Replace(oPt.Y, ",", ".") & "}"
                With .Format.Fill
                    .Visible = msoTrue
                    .ForeColor.RGB = RGB(255, 0, 0)
                    '.ForeColor.ObjectThemeColor = msoThemeColorAccent1
                    '.ForeColor.TintAndShade = 0
                    '.ForeColor.Brightness = 0
                End With
            End With
        End With
    End With
End Function

Private Function fChrtPtHighlight(ByVal oChrt As Excel.ChartObject, _
                                  ByVal lgSeries As Long, _
                                  ByVal lgData As Long, _
                                  Optional ByVal bActive As Boolean = False)
    With oChrt
        With .Chart.FullSeriesCollection(lgSeries).Points(lgData)
            With .Format
                With .Fill
                    .Visible = msoTrue
                    If bActive Then
                        .ForeColor.RGB = RGB(255, 0, 0)
                    Else
                        .ForeColor.ObjectThemeColor = msoThemeColorAccent1
                        '.ForeColor.TintAndShade = 0
                        '.ForeColor.Brightness = 0
                    End If
                    .Transparency = 0
                    .Solid
                End With
            End With
            
            '.ApplyDataLabels
        End With
    End With
End Function

Private Sub sPointsCreate(ByVal lgPoints As Long)
    Dim Xmin As Double, Ymin As Double
    Dim Xmax As Double, Ymax As Double
    Dim lgPoint As Long
    Dim dX As Double, dY As Double
    Dim lgR As Long
    Dim rgData As Excel.Range
    Dim XValue As Excel.Range
    Dim YValue As Excel.Range
    Dim oChrt As Excel.ChartObject

    ' Create points and print out to range
    With ActiveSheet
        Xmin = 0
        Xmax = 1000
        Ymin = 0
        Ymax = 1000
        dX = (Xmax - Xmin)
        dY = (Ymax - Ymin)
        ReDim oP(0 To 2 + lgPoints)
        
        For lgPoint = 3 To (lgPoints - 1) + 3
            oP(lgPoint).X = Xmin + (Rnd() * dX)
            oP(lgPoint).Y = Ymin + (Rnd() * dY)
            lgR = lgPoint - 1 + 3
            .Cells(lgR, 1).Value2 = oP(lgPoint).X
            .Cells(lgR, 2).Value2 = oP(lgPoint).Y
        Next lgPoint
        
        Set XValue = .Range("A1", .Range("A1", .Range("A1").End(xlDown)))
        'XValue.Select
        Set YValue = .Range("B1", .Range("B1", .Range("B1").End(xlDown)))
        'YValue.Select
        Set rgData = Union(XValue, YValue)
    
        ' Sort points by X
        Call fPointsSort(oP(), True, True)
        With .Sort
        '    .SortFields.Clear
        '    .SortFields.Add _
                Key:=rgData, _
                SortOn:=xlSortOnValues, _
                Order:=xlAscending, _
                DataOption:=xlSortNormal
            
        '    .SetRange rgData
        '    .Header = xlGuess
        '    .MatchCase = False
        '    .Orientation = xlTopToBottom
        '    .SortMethod = xlPinYin
        '    '.Apply
        End With
        
        ' Create chart
        'Set oChrt = .Shapes.AddChart2(240, xlXYScatter).ChartObject
        With .Shapes.AddChart2(240, xlXYScatter)
            .Name = "ChrtPts"
            .Left = ActiveSheet.Range("C1").Left
            .Top = ActiveSheet.Range("C1").Top
            
            .Height = 800
            .Width = 800
            With .Chart
                With .PlotArea
                    '.Height = 700
                    '.Width = 700
                End With

                .SetSourceData Source:=rgData
                .ChartTitle.Delete
                With .Axes(xlValue)
                    '.MinimumScaleIsAuto = True
                    '.MaximumScaleIsAuto = True
                    .MinimumScale = 0
                    .MaximumScale = 1000
                    .MajorUnit = 250
                    .MinorUnit = 50
                End With
                With .Axes(xlCategory)
                    '.MinimumScaleIsAuto = True
                    '.MaximumScaleIsAuto = True
                    .MinimumScale = 0
                    .MaximumScale = 1000
                    .MajorUnit = 250
                    .MinorUnit = 50
                End With
            End With
        End With
    End With
End Sub

'-----------------------------------------
'   T E S T    F U N C T I O N S
'-----------------------------------------

Private Sub sTestPoint()
    Dim oTriangle1 As tTriangle
    Dim oTriangle2 As tTriangle
    Dim oP() As tXYZ
    Dim lgP As Long

    'Set oChrt = ActiveSheet.ChartObjects("ChrtPts")
    
    'Call sPointsCreate(4)
    
    ReDim oP(1 To 4)
    oP(1) = NewPoint(50, 1000)
    oP(2) = NewPoint(500, 3200)
    oP(3) = NewPoint(-2000, 3500)
    oP(4) = NewPoint(-2000, -3500)

For lgP = LBound(oP) To UBound(oP)
    Cells(lgP, 1).Value2 = oP(lgP).X
    Cells(lgP, 2).Value2 = oP(lgP).Y
Next lgP

    oTriangle1 = fTriangleFromPoints(oP(1), oP(2), oP(3))
    With oTriangle1
        .V1 = 1
        .V2 = 2
        .V3 = 3
    End With
    Call fChrtTriangleAdd(oP(1), _
                          oP(2), _
                          oP(3), _
                          ActiveSheet.ChartObjects("ChrtPts"))
    
    oTriangle2 = fTriangleFromPoints(oP(3), oP(2), oP(1))
    With oTriangle2
        .V1 = 3
        .V2 = 2
        .V3 = 4
    End With
    Call fChrtTriangleAdd(oP(3), _
                          oP(2), _
                          oP(4), _
                          ActiveSheet.ChartObjects("ChrtPts"))
    
    'Call fChrtCircleAdd(oTriangle.Center, _
                        Sqr(oTriangle.R²), _
                        ActiveSheet.ChartObjects("ChrtPts"))
Stop
End Sub

'----------------------------------------------
'    T E S T
'----------------------------------------------

Private Function xTriangle(ByRef oP1 As tXYZ, ByRef oP2 As tXYZ, ByRef oP3 As tXYZ) As tXYZ
    With xTriangle
        Dim B As tXYZ
        Dim C As tXYZ
        Dim D As Double
        Dim Bx² As Double
        Dim By² As Double
        Dim Cx² As Double
        Dim Cy² As Double
        
        B.X = oP2.X - oP1.X
        B.Y = oP2.Y - oP1.Y
        C.X = oP3.X - oP1.X
        C.Y = oP3.Y - oP1.Y
        Bx² = B.X * B.X: By² = B.Y * B.Y
        Cx² = C.X * C.X: Cy² = C.Y * C.Y
        D = (2 * (B.X * C.Y - B.Y * C.X))
        If D <> 0 Then
            D = 1 / D
            .X = D * (C.Y * (Bx² + By²) - B.Y * (Cx² + Cy²))
            .Y = D * (B.X * (Cx² + Cy²) - C.X * (Bx² + By²))
            '.R² = (.Center.X * .Center.X) + (.Center.Y * .Center.Y)
            .X = .X + oP1.X
            .Y = .Y + oP1.Y
        End If
    End With
End Function

Sub sTestingPerformance()
    Dim lgT As Long
    Dim dtDate As Date
    Dim oP1 As tXYZ, oP2 As tXYZ, oP3 As tXYZ

    oP1 = NewPoint(50, 1000)
    oP2 = NewPoint(500, 3200)
    oP3 = NewPoint(-2000, 3500)
    
dtDate = VBA.Now()
    For lgT = 1 To 100000000
        Call xTriangle(oP1, oP2, oP3)
    Next lgT
Debug.Print dtDate & "  --- " & VBA.Now()

End Sub
In this code there is a convex-hull algorithm implementation, based on the Graham-Scan Rosetta-Stone VB.Net version, which was not working as expected -not at all I would say-, and finally achieved with the help of this post. The Graham-Scam algorithm is a method of computing the convex hull of a finite set of points in the plane -with time complexity O(n log n)-. The algorithm finds all vertices of the convex hull ordered along its boundary.
  • The first step in this algorithm is to find the point with the lowest y-coordinate.
  • Next, the set of points should be sorted in increasing order of the angle and the point P made with the x-axis. As this is computationally prone to errors and with bad performance, is a better option to sort points by Y value, and divide the hull construction in left and right halves.
  • The algorithm proceeds by considering each of the points in the sorted array in sequence. For each point, it is determined whether moving from the two previously considered points to this point is a “left turn” or a “right turn”. If it is a “right turn”, this means that the second-to-last point is not part of the convex hull and should be removed from consideration. This process is continued for as long as the set of the last three points is a “right turn”. As soon as a “left turn” is encountered, the algorithm moves on to the next point in the sorted array.
To improve the global performance, it also relies on a Prune algorithm to get rid of some elements before running the Graham-Scan (based on this post  -although it leds to a confusing point when explaining how to get the coordinates of the rectangle Q-). The final version is expremely fast, after I got rid of ReDim sentences.

xlCAD (II)

In the previous post we had detailed how to get a basic CAD support inside Excel. Shapes can get drawn in the worksheet, or there is even the possibility to draw them inside a UserForm using calls to API functions -it would gain “a lot” in perfomance if done this way-. In this post I will show how to convert a worksheet shape (even a FreeForm) to a macro procedure, so it can be replicated elsewhere. I experienced some problems replicating the exact location, as Excel refuses “negative” coordinates, but finally got it to work. Another thing that was left was to get the Type of shape, AutoShapeType (if a primitive one -not freeform-, one of those in msoShapeType enumeration).
Option Explicit

Private Sub sShpToMacro()
' Procedure that replicates a shape as macro code
    Dim oShp As Excel.Shape
    Dim oShpSrc As Excel.FreeformBuilder
    Dim oNode As Excel.ShapeNode
    Dim lgNode As Long
    Dim lgRefresh As Long
    Dim PtArray() As Single
    Dim PtArrayF() As Single
    Dim PtArrayB() As Single
    Dim strNode As String
    Dim strSegment As String
    Dim strEditing As String
    Dim bMove As Boolean
    Dim IncrementTop As Single
    Dim IncrementLeft As Single

    Set oShp = ActiveSheet.Shapes(Selection.ShapeRange.Name)
    'Set oShpSrc = ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, PtArray(1,1), PtArray(1,2))
    'With oShpSrc
    '    .AddNodes msoSegmentLine, msoEditingAuto, PtArray(1,1), PtArray(1,2)
    '    Set oShp = oShpSrc.ConvertToShape
    'End With
    
    'With oShp.Fill
    '    .Visible = msoTrue
    '    .PresetTextured msoTexturePapyrus
    '    .TextureTile = msoTrue
    '    .TextureOffsetX = 0
    '    .TextureOffsetY = 0
    '    .TextureHorizontalScale = 1
    '    .TextureVerticalScale = 1
    '    .TextureAlignment = msoTextureTopLeft
    '
    '    '.UserPicture "...\file.jpg"
    '    '.TextureTile = msoFalse
    'End With

    With oShp
        'Application.ScreenUpdating = False
        'For lgRefresh = 1 To 1
            'If .AutoShapeType <> msoShapeNotPrimitive Then
            '    ' If shape is a primitive Shape Type, first convert to a NotPrimitive (add a node and remove it)
            '    .Nodes.Insert .Nodes.Count, msoSegmentLine, msoEditingCorner, 100, 100
            '    .Nodes.Delete .Nodes.Count + 1
            'End If
                
            'Set oNode = .Nodes(2)
            '.Nodes.SetPosition 2, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
            'Set oNode = .Nodes(4)
            '.Nodes.SetPosition 4, oNode.Points(1, 1) + Int(Rnd() * 10), oNode.Points(1, 2) + Int(Rnd() * 10)
        'Next lgRefresh
        'Application.ScreenUpdating = True
        
        ' For first node
        With .Nodes(1)
            Debug.Print "Private Sub sShp_" & oShp.Name & "_ToMacro()"
            Debug.Print vbTab & "Dim oShp as Excel.shape"
            PtArray() = oShp.Nodes(1).Points
            Debug.Print vbTab & "With ActiveSheet.Shapes.BuildFreeform(msoEditingAuto, " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") & ")"
        End With
        
        For lgNode = 2 To .Nodes.Count - 1
        ' via SegmentType property:
        ' • If it is msoSegmentLine(0), actual nodes = x;
        ' • if it is msoSegmentCurve, actual nodes = 2 + 2 + (x-2)*3
        ' X is the nodes we can see directly.
            
            Set oNode = .Nodes(lgNode)
            With .Nodes(lgNode)
                On Local Error Resume Next
                Select Case .EditingType
                    Case 0: strEditing = "msoEditingAuto"
                    Case 1: strEditing = "msoEditingCorner"
                    Case 2: strEditing = "msoEditingSmooth"
                    Case 3: strEditing = "msoEditingSymmetric"
                End Select
                On Local Error GoTo 0
                
                Select Case .SegmentType
                    Case 1: strSegment = "msoSegmentCurve"
                        PtArrayB() = oShp.Nodes(lgNode + 0).Points
                        PtArray() = oShp.Nodes(lgNode + 1).Points
                        PtArrayF() = oShp.Nodes(lgNode + 2).Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                              & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                        lgNode = lgNode + 2
                    Case 0: strSegment = "msoSegmentLine"
                        PtArray() = .Points
                        Debug.Print VBA.String(2, vbTab) & _
                                    ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
                End Select
            End With
        Next lgNode
        
        ' For last node
        Select Case oShp.Nodes(oShp.Nodes.Count).SegmentType
            Case 1: strSegment = "msoSegmentCurve"
                If fDistance2DNode(oShp.Nodes(oShp.Nodes.Count - 1), oShp.Nodes(1)) = 0 Then
                    PtArrayB() = oShp.Nodes(oShp.Nodes.Count - 2).Points
                    PtArray() = oShp.Nodes(oShp.Nodes.Count - 1).Points
                    PtArrayF() = oShp.Nodes(1).Points
                    Debug.Print VBA.String(2, vbTab) & _
                                ".AddNodes " & strSegment & ", " & strEditing _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayB(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") _
                                                          & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArrayF(1, 2), 1), ",", ".") '& vbCrLf
                End If
            Case 0: strSegment = "msoSegmentLine"
                PtArray() = oShp.Nodes(oShp.Nodes.Count).Points
                Debug.Print VBA.String(2, vbTab) & _
                            ".AddNodes " & strSegment & ", " & strEditing & ", " & VBA.Replace(VBA.Round(PtArray(1, 1), 1), ",", ".") & ", " & VBA.Replace(VBA.Round(PtArray(1, 2), 1), ",", ".") '& vbCrLf
        End Select
        Debug.Print VBA.String(2, vbTab) & "Set oShp = .ConvertToShape"
    
        For Each oNode In .Nodes
            If oNode.Points(1, 1) < 0 Then bMove = True If IncrementLeft > oNode.Points(1, 1) Then IncrementLeft = oNode.Points(1, 1)
            End If
            If oNode.Points(1, 2) < 0 Then bMove = True If IncrementTop > oNode.Points(1, 2) Then IncrementTop = oNode.Points(1, 2)
            End If
        Next oNode
        If bMove Then
            Debug.Print VBA.String(1, vbTab) & "With oShp"
            Debug.Print VBA.String(2, vbTab) & ".IncrementLeft " & VBA.Replace(VBA.Round(IncrementLeft, 1), ",", ".")
            Debug.Print VBA.String(2, vbTab) & ".IncrementTop " & VBA.Replace(VBA.Round(IncrementTop, 1), ",", ".")
            Debug.Print VBA.String(1, vbTab) & "End With"
        End If
        Debug.Print VBA.String(1, vbTab) & "End With"
        Debug.Print "End Sub"
    End With
End Sub

Private Function fDistance2DNode(ByVal oNode1 As Excel.ShapeNode, ByVal oNode2 As Excel.ShapeNode) As Double
    fDistance2DNode = VBA.Sqr((oNode1.Points(1, 1) - oNode2.Points(1, 1)) ^ 2 + (oNode1.Points(1, 2) - oNode2.Points(1, 2)) ^ 2)
End Function
With this basic structure done, we can modify code to get the fill and contour of the shape, and any other property as Comments,…

Excel VBA print screen

Following code is a screen capturer, not relaying on the PrintScreen button. It can handle both the full screen (did not try with several monitors connected -only the principal-), or a portion of the screen selected by a range or a shape. This last point is really interesting, could not found nothing similar on the net, and kept me struggling for a whole day how to achieve it, but finally got it working. The performance of the code is not that great compared to commercial software for this task, but at least, you have not to install anything.
Option Explicit

Private g_ShpID As Long

Private Const VK_SNAPSHOT = &H2C

Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (ByRef PicDesc As PicBmp, ByRef RefIID As GUID, ByVal fPictureOwnsHandle As Long, ByRef IPic As IPicture) As Long
Private Declare Function CreateCompatibleDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "GDI32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "GDI32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "GDI32.dll" (ByVal hDC As Long, ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "GDI32.dll" (ByVal hDC As Long, ByVal wStartIndex As Long, ByVal wNumEntries As Long, ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "GDI32.dll" (ByRef lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "GDI32.dll" (ByVal hDC As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function BitBlt Lib "GDI32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function DeleteDC Lib "GDI32.dll" (ByVal hDC As Long) As Long
Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRECT As RECT) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long ' pixels
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Private Type DEVMODE
    DeviceName As String * 32
    SpecVersion As Integer
    DriverVersion As Integer
    Size As Integer
    DriverExtra As Integer
    Fields As Long
    Orientation As Integer
    PaperSize As Integer
    PaperLength As Integer
    PaperWidth As Integer
    Scale As Integer
    Copies As Integer
    DefaultSource As Integer
    PrintQuality As Integer
    Color As Integer
    Duplex As Integer
    YResolution As Integer
    TTOption As Integer
    Collate As Integer
    FormName As String * 32
    UnusedPadding As Integer
    BitsPerPixel As Integer
    PixsWidth As Long
    PixsHeight As Long
    DisplayFlags As Long
    DisplayFrequency As Long
    ' The following only appear in Windows 95, 98, 2000
    ICMMethod As Long
    ICMIntent As Long
    MediaType As Long
    DitherType As Long
    Reserved1 As Long
    Reserved2 As Long
    ' The following only appear in Windows 2000
    PanningWidth As Long
    PanningHeight As Long
End Type

Private Declare Function EnumDisplaySettings Lib "user32.dll" Alias "EnumDisplaySettingsA" (ByVal lpszDeviceName As String, ByVal iModeNum As Long, lpDevMode As DEVMODE) As Long
Private Const ENUM_CURRENT_SETTINGS = -1
Private Const ENUM_REGISTRY_SETTINGS = -2

'Private Const SM_CXSCREEN = 0&
'Private Const SM_CYSCREEN = 1&
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38

Private Const SM_CXFULLSCREEN As Long = 16
Private Const SM_CYFULLSCREEN As Long = 17
Private Const HORZRES As Long = 8&
Private Const VERTRES As Long = 10&

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type

Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type

Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(7) As Byte
End Type

Private Type PicBmp
    Size As Long
    Type As Long
    hBmp As Long
    hPal As Long
    Reserved As Long
End Type

Private Const TIFF_LZW As String = "LZW"
Private Const TIFF_RLE As String = "RLE"       'Pixel Depth must be 1.
Private Const TIFF_CCITT3 As String = "CCITT3" 'Pixel Depth must be 1.
Private Const TIFF_CCITT4 As String = "CCITT4" 'Pixel Depth must be 1.
Private Const TIFF_Uncompressed As String = "Uncompressed"

' --------------------------------
'        Screen capture
' --------------------------------
Private Sub sPrntWnd()
    Dim oShp As Excel.Shape
    Dim oXlRng As Excel.Range
    Dim oRect As RECT
    Dim strFullPathFile As String
    Dim Seconds As Double
    Dim lgShp As Long
    Dim hDC As Long
    'Dim hWnd As Long
    Dim lgPixelsPeriInch As Long

    lgShp = 0
    hDC = GetDC(0&)
    
    With ThisWorkbook.Application
        'hWnd = FindWindowEx(.Windows(1).hWnd, 0&, vbNullString, vbNullString)
        'GetWindowRect .Windows(1).hWnd, oRect '--> Have to convert oRect to pixels...?
        
        Set oXlRng = ActiveWindow.VisibleRange
        oRect.Left = GetRectForExcel(oXlRng, 1) * 4 / 3
        oRect.Top = GetRectForExcel(oXlRng, 2) * 4 / 3
        oRect.Bottom = oRect.Top + (oXlRng.Height * 4 / 3)
        oRect.Right = oRect.Left + (oXlRng.Width * 4 / 3)
        
        lgShp = lgShp + 1
        strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
        Call fPrntSrc(oRect, strFullPathFile, 1)
    End With
    
    hDC = ReleaseDC(0, hDC)
End Sub

Public Sub sPrntSrc()
    Dim oShp As Excel.Shape
    Dim oXlCell As Excel.Range
    Dim oRect As RECT
    Dim strFullPathFile As String
    Dim Seconds As Double
    Dim lgShp As Long
    Dim hDC As Long
    Dim lgPixelsPeriInch As Long

    lgShp = 0
    hDC = GetDC(0&)
    For Each oShp In ActiveSheet.Shapes
        'If oShp.Name <> "•" Then
        If oShp.Name = "x" Then
Stop
            Set oXlCell = oShp.TopLeftCell
            oRect.Left = GetRectForShp(oShp, 1) * 4 / 3 + (1) ' 1 pixel to avoid border
            oRect.Top = GetRectForShp(oShp, 2) * 4 / 3 + (2 + 1) 'excel shape has not a good precision, 2 pixels are wrong + 1 for the border
            'oRect.Left = GetRectForExcel(oXlCell, 1) * 4 / 3
            'oRect.Top = GetRectForExcel(oXlCell, 3) * 4 / 3
            oRect.Bottom = oRect.Top + (oShp.Height * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
            oRect.Right = oRect.Left + (oShp.Width * 4 / 3) - (1 + 1) ' 1 pixel to avoid each border
            lgShp = lgShp + 1
            strFullPathFile = ThisWorkbook.Path & "\@" & lgShp & ".bmp"
            Call fPrntSrc(oRect, strFullPathFile, 1)
Exit Sub
        End If
    Next oShp
    hDC = ReleaseDC(0, hDC)
End Sub

Private Function fPrntSrc(ByRef oRect As RECT, _
                          Optional ByVal strFullPathFile As String = vbNullString, _
                          Optional ByVal Seconds As Double = 1) As Boolean
' Screenshots of an active window / rectangle can be captured, with/without delay
    Dim oDevMode As DEVMODE   ' info about the display device
    Dim lgRetVal As Long  ' return value
    
    'If Seconds > 0 Then Sleep (VBA.Fix(Seconds * 1000))
    With oRect
        If .Bottom = .Top _
        Or .Left = .Right Then
            ' Full screen
            ' Initialize the structure.
            oDevMode.Size = Len(oDevMode)
            
            ' Get the display settings for the current monitor and mode.
            lgRetVal = EnumDisplaySettings(vbNullString, ENUM_CURRENT_SETTINGS, oDevMode)
            
            stdole.SavePicture hDCToPicture(GetDC(0&), 0&, 0&, oDevMode.PixsWidth, oDevMode.PixsHeight), _
                               strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
        Else
            'AppActivate ThisWorkbook.Application   ' bring to front Excel
            'GetWindowRect GetForegroundWindow, oRect
            GetWindowRect GetDC(0&), oRect
            With oRect
                stdole.SavePicture hDCToPicture(GetDC(0&), .Left, .Top, .Right - .Left, .Bottom - .Top), _
                                   strFullPathFile ' ThisWorkbook.Path & "\Screenshot.bmp"
            End With
        End If
    End With
End Function

Private Function CreateBitmapPicture(ByVal hBmp As Long, ByVal hPal As Long) As Object
    Dim Pic As PicBmp
    Dim IPic As IPicture
    Dim IID_IDispatch As GUID

    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With Pic
        .Size = Len(Pic)
        .Type = 1
        .hBmp = hBmp
        .hPal = hPal
    End With
    Call OleCreatePictureIndirect(Pic, IID_IDispatch, 1, IPic)
    Set CreateBitmapPicture = IPic
End Function

Private Function hDCToPicture(ByVal hDCSrc As Long, _
                              ByVal LeftSrc As Long, _
                              ByVal TopSrc As Long, _
                              ByVal WidthSrc As Long, _
                              ByVal HeightSrc As Long) As Object
    Dim hDCMemory As Long
    Dim hBmp As Long, hBmpPrev As Long
    Dim hPal As Long, hPalPrev As Long
    Dim RasterCapsScrn As Long
    Dim HasPaletteScrn As Long
    Dim PaletteSizeScrn As Long
    Dim LogPal As LOGPALETTE

    hDCMemory = CreateCompatibleDC(hDCSrc)
    hBmp = CreateCompatibleBitmap(hDCSrc, WidthSrc, HeightSrc)
    hBmpPrev = SelectObject(hDCMemory, hBmp)
    RasterCapsScrn = GetDeviceCaps(hDCSrc, RASTERCAPS)
    HasPaletteScrn = RasterCapsScrn And RC_PALETTE
    PaletteSizeScrn = GetDeviceCaps(hDCSrc, SIZEPALETTE)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        With LogPal
            .palVersion = &H300
            .palNumEntries = 256
        End With
        Call GetSystemPaletteEntries(hDCSrc, 0, 256, LogPal.palPalEntry(0))
        hPal = CreatePalette(LogPal)
        hPalPrev = SelectPalette(hDCMemory, hPal, 0)
        Call RealizePalette(hDCMemory)
    End If

    Call BitBlt(hDCMemory, 0, 0, WidthSrc, HeightSrc, hDCSrc, LeftSrc, TopSrc, 13369376)
    hBmp = SelectObject(hDCMemory, hBmpPrev)
    If HasPaletteScrn And (PaletteSizeScrn = 256) Then
        hPal = SelectPalette(hDCMemory, hPalPrev, 0)
    End If
    Call DeleteDC(hDCMemory)
    Set hDCToPicture = CreateBitmapPicture(hBmp, hPal)
End Function

'-------------------------

Private Sub fPrntSrc_2()
' if using multiple monitors, it will only capture the active monitor...
    Dim oShp As Excel.Shape
    Dim lgShps As Long

    'AppActivate Application.caption        ' select application to be captured...
    
    AppActivate ThisWorkbook.Application   ' to activate Excel
    keybd_event VK_SNAPSHOT, 1, 0, 0
    'Application.Wait
Application.WindowState = xlMaximized
    With wsSheet1
        Application.Wait (Now + TimeValue("0:00:5"))
        lgShps = .Shapes.Count + 1
        DoEvents
        .Paste
        Do Until .Shapes.Count = lgShps
            DoEvents
        Loop
        Set oShp = .Shapes(lgShps)
        With oShp
            '.TopLeftCell = ActiveCell
            
            'To Resize: once you have a handle on the shape, just assign its Height and Width properties as needed:
            .Height = 600
            .Width = 800
    
            'To Position It: use the shape's TopLeftCell property.
            
            'To Crop It: use the ".PictureFormat.Crop"
            '(and/or CropLeft, CropTop, CropBottom, CropRight if you need to fine-tune what part of the screenshot is needed.
            'For instance, this crops the pasted screenshot to 800x600:
            .LockAspectRatio = False
            .PictureFormat.CropRight = -(800 - .Width)
            .PictureFormat.CropBottom = -(600 - .Height)
        End With
    End With
End Sub
These are other needing procedures to get the position of the range or the Excel shape.
Option Explicit

Public Type POINTAPI
    x As Long
    y As Long
End Type

Private Type RECT
    Left As Double
    Top As Double
    Right As Double
    Bottom As Double
End Type

Private Enum eRectBorder
    eBorderLeft = 1
    eBorderTop = 2
    eBorderRight = 3
    eBorderBottom = 4
End Enum

Public Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Public Declare Function ScreenToClient Lib "user32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Public Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Public Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long

#If Win64 Then
    Public Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Public Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Public Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As LongPtr, ByVal nIndex As Long) As Long
#Else
    Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
    Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
    Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
#End If

Public Const LOGPIXELSX = 88&
Public Const LOGPIXELSY = 90&

'Private Sub SetUpProc()
'    With Application
'        .OnKey "z", "TestMoveShapeToMouse"
'        '.Cursor = xlNorthwestArrow
'    End With
'End Sub
'
'Private Sub ResetUpProc()
'    With Application
'        .OnKey "z"
'        '.Cursor = xlDefault
'    End With
'End Sub
'
'Private Sub TestMoveShapeToMouse()
''Change shape to suit
'    Dim oShpRng As Excel.ShapeRange
'    'Dim oShp As Excel.Shape
'
'    Set oShpRng = Selection.ShapeRange
'    'Set oShp = ActiveSheet.Shapes(oShpRng.ID - 1)
'    MoveShapeToMouse ActiveSheet.Shapes(oShpRng.ID - 1)
'End Sub
'
'Private Sub MoveShapeToMouse(ByRef oShp As Excel.Shape)
'    Dim oPoint As POINTAPI
'    Dim xpos_0 As Double, ypos_0 As Double
'    Dim z As Double
'
'    On Error Resume Next
'    GetCursorPos oPoint
'    With ActiveWindow
'        z = CorrectZoomFactor(.Zoom / 100)
'        xpos_0 = .PointsToScreenPixelsX(0)
'        ypos_0 = .PointsToScreenPixelsY(0)
'    End With
'    Application.Cursor = xlNorthwestArrow
'    oShp.Left = (oPoint.x - xpos_0) / z * PointsPerPixel(LOGPIXELSX)
'    oShp.Top = (oPoint.y - ypos_0) / z * PointsPerPixel(LOGPIXELSY)
'    'Application.Cursor = xlDefault
'    On Error GoTo 0
'End Sub
'
'Private Function CorrectZoomFactor(ByVal z As Single) As Single
'    Select Case z
'        Case 2:     z = 2
'        Case 1.75:  z = 1.765
'        Case 1.5:   z = 1.529
'        Case 1.25:  z = 1.235
'        Case 1:     z = 1
'        Case 0.9:   z = 0.882
'        Case 0.85:  z = 0.825
'        Case 0.8:   z = 0.82
'        Case 0.75:  z = 0.74
'        Case 0.7:   z = 0.705
'        Case 0.65:  z = 0.645
'        Case 0.6:   z = 0.588
'        Case 0.55:  z = 0.53
'        Case 0.5:   z = 0.5296
'        Case Else
'            z = 1.0069 * z + 0.0055
'    End Select
'    CorrectZoomFactor = z
'End Function

Public Sub Add_Shape_At_Cursor_Position()
' adds an AutoShape to the active sheet centered over the mouse position, accounting for the Excel window position and zoom.
' Currently it adds a circle (actually an oval with width 100 and height 100) but should work with any MsoAutoShapeType.

    Dim PointsPerPixelX As Double, PointsPerPixelY As Double
    Dim CursorPos As POINTAPI
    Dim ExcelPos As POINTAPI
    Dim ShapePos As POINTAPI

    'Size of shape's bounding box in points
    Const SHAPE_WIDTH = 100
    Const SHAPE_HEIGHT = 100
    
    'Get number of points per screen pixel, depending on screen device size
    PointsPerPixelX = PointsPerScreenPixel(LOGPIXELSX)
    PointsPerPixelY = PointsPerScreenPixel(LOGPIXELSY)
    
    'Scale points per pixel according to current window zoom. The smaller the zoom, the higher the number of points per pixel
    With ActiveWindow
        PointsPerPixelX = PointsPerPixelX * 100 / .Zoom
        PointsPerPixelY = PointsPerPixelY * 100 / .Zoom
        
        'Get position of Excel window in screen pixels
        ExcelPos.x = .PointsToScreenPixelsX(0)
        ExcelPos.y = .PointsToScreenPixelsY(0)
    End With

    'Get mouse cursor position in screen pixels
    GetCursorPos CursorPos
    
    'Set shape position according to mouse position relative to Excel window position, scaled to the
    'number of points per pixel.  Since the AutoShape's position is defined by the top left corner
    'of its bounding box, subtract half the shape's size to centre it over the mouse
    ShapePos.x = (CursorPos.x - ExcelPos.x) * PointsPerPixelX - (SHAPE_WIDTH / 2)
    ShapePos.y = (CursorPos.y - ExcelPos.y) * PointsPerPixelY - (SHAPE_HEIGHT / 2)
       
    ActiveSheet.Shapes.AddShape msoShapeOval, ShapePos.x, ShapePos.y, SHAPE_WIDTH, SHAPE_HEIGHT

End Sub

Public Function GetRectForExcel(ByVal Target As Excel.Range, _
                                Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
    Dim Index As Integer
    Dim RECT As RECT
    
    With ActiveWindow
        Set Target = Target.MergeArea
    
        For Index = 1 To .Panes.Count
            If Not Intersect(Target, .Panes(Index).VisibleRange) Is Nothing Then
                With .Panes(Index)
                    RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(Target.Left))
                    RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(Target.Top))
                End With
                
                RECT.Right = (Target.Width * .Zoom / 100) + RECT.Left
                RECT.Bottom = (Target.Height * .Zoom / 100) + RECT.Top
                
                If RectBorder = eRectBorder.eBorderLeft Then
                    GetRectForExcel = RECT.Left
                ElseIf RectBorder = eRectBorder.eBorderTop Then
                    GetRectForExcel = RECT.Top
                ElseIf RectBorder = eRectBorder.eBorderRight Then
                    GetRectForExcel = RECT.Right
                ElseIf RectBorder = eRectBorder.eBorderBottom Then
                    GetRectForExcel = RECT.Bottom
                End If
                Exit Function
            End If
        Next
    End With
End Function

Public Function ShpRngToShp(ByVal oShpRng As Excel.ShapeRange) As Excel.Shape
    Set ShpRngToShp = oShpRng.Parent.Shapes(oShpRng.Name)
End Function

Public Function GetRectForShp(ByVal oShp As Excel.Shape, _
                              Optional ByVal RectBorder As Long = eRectBorder.eBorderLeft) As Double
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
    Dim oXlCell As Excel.Range
    Dim Index As Integer
    Dim RECT As RECT
    
    With ActiveWindow
        Set oXlCell = oShp.TopLeftCell.MergeArea
    
        For Index = 1 To .Panes.Count
            If Not Intersect(oXlCell, .Panes(Index).VisibleRange) Is Nothing Then
                With .Panes(Index)
                    RECT.Left = PixelsToPoints(.PointsToScreenPixelsX(oShp.Left))
                    RECT.Top = PixelsToPoints(.PointsToScreenPixelsY(oShp.Top))
                End With
                
                RECT.Right = (oShp.Width * .Zoom / 100) + RECT.Left
                RECT.Bottom = (oShp.Height * .Zoom / 100) + RECT.Top
                
                If RectBorder = eRectBorder.eBorderLeft Then
                    GetRectForShp = RECT.Left
                ElseIf RectBorder = eRectBorder.eBorderTop Then
                    GetRectForShp = RECT.Top
                ElseIf RectBorder = eRectBorder.eBorderRight Then
                    GetRectForShp = RECT.Right
                ElseIf RectBorder = eRectBorder.eBorderBottom Then
                    GetRectForShp = RECT.Bottom
                End If
                Exit Function
            End If
        Next
    End With
End Function

Public Function PointsPerScreenPixel(ByVal LOGPIXELS As Long) As Double
'Get number of points per screen pixel, depending on screen device size
    Dim hDC As Long
    
    hDC = GetDC(0)
    PointsPerScreenPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
    ReleaseDC 0, hDC
End Function

Public Function TwipsToPixels(ByVal lngTwips As Long, _
                              ByVal blnHorizontal As Boolean) As Long
' Twip is a distance measurement - 1/1440th of an inch.
' twips = Device.TwipsPerPixelX (or Y) * pixels
' pixels = twips / Device.TwipsPerPixelX (or Y)
    Const TWIPSPERINCH As Long = 1440

    If blnHorizontal Then
        TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(True))
    Else
        TwipsToPixels = CLng(lngTwips / TWIPSPERINCH * DotsPerInch(False))
    End If
End Function

Public Function DotsPerInch(Optional ByVal blnHorizontal As Boolean = True) As Long
    Dim hDC As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        DotsPerInch = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    ReleaseDC 0, hDC
End Function

Public Function PixelsToPoints(ByVal Pixels As Double, _
                               Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts pixels to points
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
' Measurement units and rulers in Excel
' Unlike Microsoft Word, Excel does not provide a horizontal or vertical ruler, and there is no quick way to measure the width or height of a worksheet in inches.
' Excel uses characters, points, and pixels as units of measurement.
' The width of cells is displayed in characters and pixels rather than in inches.
'  • When you drag the boundary of a column heading to adjust the width of a column on the worksheet, a ScreenTip displays the width in characters and shows pixels in parentheses.
' The height of cells is displayed in points and pixels rather than in inches.
'  • When you drag the boundary of a row heading to adjust the height of a row on the worksheet, a ScreenTip displays the height in points and shows pixels in parentheses.
'
' An approximate conversion of points and pixels to inches is shown in the following table.
'  Points  Pixels  Inches
'   18      24      .25
'   36      48      .5
'   72      96      1
'   108     144     1.5
'   144     192     2
 
'
' @param {Double} Pixels
' @return {Double} Points
' ----------------------------------------
    Dim hDC As Long
    Dim iDPI As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    PixelsToPoints = Pixels / iDPI * 72
    ReleaseDC 0, hDC
End Function

Public Function PointsToPixels(ByVal Points As Double, _
                               Optional ByVal blnHorizontal As Boolean = True) As Double
' ----------------------------------------
' Converts points to pixels
' More info http://office.microsoft.com/en-us/excel-help/measurement-units-and-rulers-in-excel-HP001151724.aspx
'
' @param {Double} Points
' @return {Double} Pixels
' ----------------------------------------
    Dim hDC As Long
    Dim iDPI As Long

    hDC = GetDC(0)
    If blnHorizontal Then
        iDPI = GetDeviceCaps(hDC, LOGPIXELSX)
    Else
        iDPI = GetDeviceCaps(hDC, LOGPIXELSY)
    End If
    PointsToPixels = (Points / 72) * iDPI
    ReleaseDC 0, hDC
End Function

Public Function PointsPerPixel(ByVal LOGPIXELS As Long) As Double
'LOGPIXELSX: The WIDTH of a pixel in Excel's userform coordinates
'LOGPIXELSY: The HEIGHT of a pixel in Excel's userform coordinates
    Dim hDC As Long
    
    hDC = GetDC(0)
    'A point is defined as 1/72 of an inch and LOGPIXELS returns
    'the number of pixels per logical inch, so divide them to give
    'the width of a pixel in Excel's userform coordinates
    PointsPerPixel = 72 / GetDeviceCaps(hDC, LOGPIXELS)
    ReleaseDC 0, hDC
End Function
Following is also the code for a BMP/JPG/TIF/GIF/PNG conversion, that comes very handy with this, as the BMP format is a disk eating beast.

' --------------------------------
'        Image conversion
' --------------------------------

' Option 1
Private Sub ImgConv(ByVal InFileName As String, _
                    ByVal OutFileName As String, _
                    ByVal OutFormat As String, _
                    Optional ByVal Quality As Integer = 100, _
                    Optional ByVal Compression As String = TIFF_LZW)
' Reference to: Microsoft Windows Image Acquisition Library v2.0
' XP SP1 and later
' For XP you'll need to deploy it: Windows® Image Acquisition Automation Library v2.0 Tool (http://www.microsoft.com/downloads/en/details.aspx?FamilyID=a332a77a-01b8-4de6-91c2-b7ea32537e29)
    
    Dim Img As WIA.ImageFile
    Dim ImgProc As WIA.ImageProcess

    Set Img = New WIA.ImageFile
    Img.LoadFile InFileName
    Set ImgProc = New WIA.ImageProcess
    With ImgProc.Filters
        .Add ImgProc.FilterInfos("Convert").FilterID
        .Item(1).Properties("FormatID").Value = OutFormat
        If OutFormat = wiaFormatJPEG Then
            .Item(1).Properties("Quality").Value = Quality
        ElseIf OutFormat = wiaFormatTIFF Then
            .Item(1).Properties("Compression").Value = Compression
        End If
    End With
    Set Img = ImgProc.Apply(Img)

    On Local Error Resume Next
    'If fFileExists(OutFileName) Then
    'End If
    'Kill OutFileName
    On Local Error GoTo 0
    Img.SaveFile OutFileName
End Sub

Private Sub sImageConv_Main()
    Dim strPath As String
    
    strPath = "C:\Users\CASA\Documents\"
    ImgConv strPath & "a.bmp", strPath & "a.jpg", wiaFormatJPEG, 70
    ImgConv strPath & "a.bmp", strPath & "a.gif", wiaFormatGIF
    ImgConv strPath & "a.bmp", strPath & "a.png", wiaFormatPNG
    ImgConv strPath & "a.bmp", strPath & "a.tif", wiaFormatTIFF, , TIFF_Uncompressed
'    MsgBox "Complete"
End Sub

' Option 2
Private Sub PrintToPDFCreator_Early()
'' Print to Output file using PDFCreator: http://sourceforge.net/projects/pdfcreator/
'' Designed for early bind, set reference to PDFCreator
'' http://www.vbaexpress.com/forum/archive/index.php/t-8488.html
'    Dim OutputJob As PDFCreator.clsPDFCreator
'    Dim sOutputName As String
'    Dim sOutputPath As String
'    Dim lOutputType As Long
'    Dim i As Integer
'    Dim lgRetVal As Long
'
'    '/// Change the output file name and type here! ///
'    sOutputName = "test"
'
'    '0=PDF, 1=Png, 2=jpg, 3=bmp, 4=pcx, 5=tif, 6=ps, 7=eps, 8=txt
'    lOutputType = 2
'
'    sOutputPath = ActiveDocument.Path & Application.PathSeparator
'    Set OutputJob = New PDFCreator.clsPDFCreator
'
'    'Set correct filename extension
'    Select Case lOutputType
'        Case Is = 0: sOutputName = sOutputName & ".pdf"
'        Case Is = 1: sOutputName = sOutputName & ".png"
'        Case Is = 2: sOutputName = sOutputName & ".jpg"
'        Case Is = 3: sOutputName = sOutputName & ".bmp"
'        Case Is = 4: sOutputName = sOutputName & ".pcx"
'        Case Is = 5: sOutputName = sOutputName & ".tif"
'        Case Is = 6: sOutputName = sOutputName & ".ps"
'        Case Is = 7: sOutputName = sOutputName & ".eps"
'        Case Is = 8: sOutputName = sOutputName & ".txt"
'    End Select
'
'    'Set job defaults
'    With OutputJob
'        If .cStart("/NoProcessingAtStartup") = False Then
'            lgRetVal = MsgBox("Can't initialize PDFCreator.", _
'                              vbCritical + vbOKOnly, "PrtPDFCreator")
'            Exit Sub
'        End If
'        .cOption("UseAutosave") = 1
'        .cOption("UseAutosaveDirectory") = 1
'        .cOption("AutosaveDirectory") = sOutputPath
'        .cOption("AutosaveFilename") = sOutputName
'        .cOption("AutosaveFormat") = lOutputType
'        .cClearCache
'    End With
'
'    'Print the document to PDF
'    With ThisDocument
'        .ActivePrinter = "PDFCreator"
'        .PrintOut
'    End With
'
'    'Wait until the print job has entered the print queue
'    Do Until OutputJob.cCountOfPrintjobs = 1
'        DoEvents
'    Loop
'    OutputJob.cPrinterStop = False
'
'    'Wait until the PDF file shows up then release the objects
'    Do Until Dir(sOutputPath & sOutputName) <> ""
'        DoEvents
'    Loop
'    OutputJob.cClose
'    Set OutputJob = Nothing
End Sub

' Option 3
Private Sub ImgFFMpedConv(ByVal InFileName As String)
' Convert to any format (with/without compression) via FFMpeg http://ffmpeg.zeranoe.com/builds.

    Shell ("ffmpeg.exe -i YourFile.bmp -q <qualityNumber*> ConverTo.Any")  ' *write ffmpeg /? in cmd to know usage
End Sub

' Option 4
' A pure VB6 JPG class development
'http://www.planet-source-code.com/vb/scripts/ShowCode.asp?txtCodeId=50065&lngWId=1

Block Excel shape selection

In Excel, every shape is selectable via click button. This is sometimes a pain when you do not want an specific shape to be ever selected. Assinning an empty macro to the onAction method will help (although it will fail when trying multiselection):
Public Sub sShp_UnselectMe()
End Sub
There is the option to unselect a shape beeing clicked, but I not yet sure how I can implement it…
Public Sub sShp_UnselectMe()
    Dim oShp As Excel.Shape
    Dim oShpRng As Excel.ShapeRange
    Dim oShpGrp As Excel.Shape
    Dim vShpSelection() As Variant
    Dim lgShp As Long
    Dim lgItem As Long
    
    If TypeName(Application.Selection) = "Range" Then
    ' Shape will not be selected until the oShp.OnAction had run,
    ' so if not prior shape was selected, the selection only comprises range elements
        Exit Sub
    ElseIf TypeName(Application.Selection) = "DrawingObjects" Then
    'composed of: --> "Line" "Arc" "Drawing" "Rectangle" "Oval" "Picture" "TextBox"
        lgItem = -1
        For lgShp = 1 To Application.Selection.ShapeRange.Count
            Set oShp = Application.Selection.ShapeRange.Item(lgShp)
            'If oShp.ID <> g_ShpID Then 'oXlWsh.Shapes(Application.Caller).ID
                lgItem = lgItem + 1
                ReDim Preserve vShpSelection(0 To lgItem)
                vShpSelection(lgItem) = oShp.Name
            'End If
        Next lgShp
        Set oShpRng = ActiveSheet.Shapes.Range(vShpSelection)
        With oShpRng
            .Select
            '.Group
            '.Name = ...
        End With
    
    ElseIf TypeName(Application.Selection) = "GroupObject" Then
        Set oShpGrp = Application.Selection
        'Give name: oShpGrp.Name
    Else
        Exit Sub
    End If
End Sub
But there is a little problem you should solve first. Shape names should be unique so the Application.Caller event does not point to a different shape to the one you’re looking for. This code from StackOverflow will help prevent the issue:
Private Sub TestShpProblem()
    Dim ws As Worksheet
    Dim shp As Shape

    ' reset shapes
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    For Each shp In ws.Shapes
        shp.Delete
    Next shp

    ' add shape
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 10, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 10, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 10, 160, 100, 100)
        .Name = "Foo2"
        .OnAction = "ShapeAction"
    End With

    ' add another shape with duplicate name
    With ws.Shapes.AddShape(msoShapeRectangle, 160, 160, 100, 100)
        .Name = "Foo1"
        .OnAction = "ShapeAction"
    End With

    ' add another shape
    With ws.Shapes.AddShape(msoShapeRectangle, 310, 160, 100, 100)
        .Name = "Foo3"
        .OnAction = "ShapeAction"
    End With

    ' uniqueify shape names - comment out to replicate OP problem
    MakeShapeNamesUnique ws

End Sub

Sub ShapeAction()
    Dim shp As Excel.Shape

    Set shp = Sheet1.Shapes(Application.Caller)
    MsgBox " My name is: " & shp.Name & " and my ID is: " & shp.ID

End Sub

Private Sub MakeShapeNamesUnique(Optional oXlWsh As Excel.Worksheet = Nothing)
    Dim oShp As Excel.Shape
    Dim oDictionay As Object

    Set oDictionay = CreateObject("Scripting.Dictionary")

    'iterate shapes
    If oXlWsh Is Nothing Then Set oXlWsh = ActiveSheet
    For Each oShp In oXlWsh.Shapes
        With oShp
            ' does shape name exist ?
            If Not oDictionay.Exists(.Name) Then
                ' add name to dictionary if not exists with counter of 0
                oDictionay.Add .Name, 0
            Else
                ' found a duplicate --> increment counter
                oDictionay(.Name) = oDictionay(.Name) + 1
                
                ' rename shape with suffix indicating dupe index
                .Name = .Name & "_" & oDictionay(.Name)
            End If
        End With
    Next oShp

    ' Clean up the dictionary
    Set oDictionay = Nothing
End Sub

VBA range variables declaration

When using the VBA Formula method, I like to get all the info at first glance. Is really annoying for me to find .cells(lR, #) where the # does not give any hint about the column meaning. I better prefer the .cells(lR, lC_worksheetName_infoColumn) notation. For this, you need the lC_worksheetName_infoColumn to be declared before use, and having so much of this variables is a burden I would prefer to not do manually. Here it comes handy a little macro that can generate the declaration block, via “Const” or via “Dim”. There is also some code for indention purposes.
Private Function fVariableNamer()
    Dim bIndent As Boolean: bIndent = False
    Dim bConst As Boolean: bConst = False
    
    Dim oXlCell As Excel.Range
    Dim strWshName As String
    Dim strVar As String
    Dim strText As String
    Dim strOut As String
    Dim strChr As String
    Dim strPrev As String
    Dim iChr As Integer
    Dim lgChr As Long
    
    strWshName = Selection.Parent.Name
    For Each oXlCell In Selection.Cells
        strText = oXlCell.Value2
        strOut = vbNullString
        
        ' Avoid spaces
        strText = VBA.Trim$(strText)
        Do While VBA.InStr(1, strText, "  ")
            strText = VBA.Replace(strText, "  ", " ")
        Loop
        
        ' For ending character
        lgChr = VBA.Len(strText)
        strChr = VBA.Mid$(strText, lgChr, 1)    'iChr = VBA.Asc()
        strPrev = VBA.Mid$(strText, lgChr - 1, 1)
        If strPrev = "." Or strPrev = "-" Then
            strOut = VBA.UCase$(strChr)
        Else
            strOut = strChr
        End If
        
        ' For other characters
        For lgChr = VBA.Len(strText) - 1 To 2 Step -1 ' from back to front
            strChr = VBA.Mid$(strText, lgChr, 1) 'iChr = VBA.Asc()
            strPrev = VBA.Mid$(strText, lgChr - 1, 1)
            If strChr = "." Or strChr = "-" Or strChr = " " Then
            Else
                If strPrev = "." Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                ElseIf strPrev = "-" Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                ElseIf strPrev = " " Then
                    strOut = VBA.UCase$(strChr) & strOut
                    lgChr = lgChr - 1
                Else
                    strOut = strChr & strOut
                End If
            End If
        Next lgChr
        
        ' For starting character
        strChr = VBA.Mid$(strText, 1, 1)  'iChr = VBA.Asc()
        If strChr = "." Or strChr = "-" Then
        Else
            strOut = VBA.UCase$(strChr) & strOut
        End If
        
        strVar = "lC_" & strWshName & "_" & strOut
        If bIndent Then
            strIndent = VBA.Space(25 - VBA.Len(strVar))
        End If
        
        If bConst Then
            Debug.Print "Private Const lC_" & strWshName & "_" & strOut & strIndent & " As Long = " & oXlCell.Column
        Else
            Debug.Print "Dim " & strVar & " As Long:" & strIndent & strVar & " = " & oXlCell.Column
        End If
    Next oXlCell
End Function
Enjoy it!

Book library

I have plenty of books, both digital and physical. The problem is with the the digital ones. They come from several sources, but as a lot they are, I can hardly know where all are stored, or if I’m in the need of some specific topic, even get to them (I use to name by ISBN, not very helpful in this point). A library will be an excelent solution. But I have to code that library, and even get the descriptions, the cover images,… want it on Excel format, and in HTML. Following is the main procedure to create HTML files with release info, and a description for them, with link to some web store (Amazon I suppose, to get more information and even get them on physical form). If possible I would also link to the source where they came from (with a basic cyphering code, just to not expose sensible content).
Option Explicit

Private Type tLibraryItem
    Title As String
    Date As Date
    Image As String
    Info As String
    ISBN As String
    Pages As Long
    Size As Long
    Format_ As String
    Link() As String
End Type

Private Sub sIndexGenerator()
' Given an index, generate HTML
    Dim strURL As String
    Dim strPath As String
    Dim iFile As Integer
    Dim strFile As String
    Dim strDoc As String
    
    Dim bRaw As Boolean
    Dim s As String
    Dim strHTML As String
    Dim hDoc As MSHTML.HTMLDocument
    Dim hHead As MSHTML.HTMLHeadElement
    Dim hBody As MSHTML.HTMLBody
    Dim hCollection As MSHTML.IHTMLElementCollection
    Dim hElementItem As MSHTML.IHTMLElement
    Dim hElement As MSHTML.IHTMLElement
    Dim hChildrenElement As MSHTML.IHTMLElement
    Dim hChildrenCollection As MSHTML.IHTMLElementCollection 'Object
    Dim hNode As MSHTML.IHTMLDOMNode

    Dim lgItem As Long
    Dim iFileOut As Integer
    Dim lgItemStart As Long:    lgItemStart = 1
    Dim lgItemEnd As Long:      lgItemEnd = 1
    Dim lgItemsPerPage As Long: lgItemsPerPage = 20
    Dim lgLink As Long

    Dim lC_X As Long:       lC_X = 1
    Dim lC_Title As Long:   lC_Title = lC_X + 1
    Dim lC_Link As Long:    lC_Link = lC_Title + 1
    Dim lC_PC As Long:      lC_PC = lC_Link + 1
    Dim lC_Amazon As Long:  lC_Amazon = lC_PC + 1
    Dim lC_Cat As Long:     lC_Cat = lC_Amazon + 1
    Dim lC_Image As Long:   lC_Image = lC_Cat + 1
    Dim lC_Info As Long:    lC_Info = lC_Image + 1
    Dim lC_ISBN As Long:    lC_ISBN = lC_Info + 1
    Dim lC_Size As Long:    lC_Size = lC_ISBN + 1
    Dim lC_Description As Long: lC_Description = lC_Size + 1
    Dim lC_Hosted As Long:  lC_Hosted = lC_Description + 1
    Dim lr As Long
    Dim lR_Start As Long
    Dim lR_End As Long
    
    Dim oItem() As tLibraryItem
    
    strPath = VBA.Environ$("UserProfile") & "\Documents\"
    For lgItem = 1 To 1 Step lgItemsPerPage
        iFileOut = VBA.FreeFile()
        'strFile = "test" & ".html"
        'Open strPath & "Page_" & VBA.Format(lgItem, "000") & ".html" For Output Shared As #iFileOut
        
        If bRaw Then

' Here was code to generate raw HTML, but the beautifier in wp, kills it!!
        
        Else
            ' Set hDOMDoc = oIE.Document.DOMDocument
            Set hDoc = New MSHTML.HTMLDocument
            Set hHead = hDoc.head 'or: hDoc.createElement("head")
            Set hBody = hDoc.body 'or: hDoc.createElement("body")
            
            ' Create title
            hDoc.Title = "Test"
        
            ' Create meta tags
            Set hElement = hDoc.createElement("xxx.com"">")
            hHead.appendChild hElement
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to icon
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to CSS styles definition
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            ' Link to script code
            Set hElement = hDoc.createElement("")
            hHead.appendChild hElement
            
            '----------------------------
            ' Beautify...
            Set hElement = hDoc.createElement("div")
            hElement.setAttribute "id", "ActiveItem"
            hElement.setAttribute "class", "item"
            hBody.appendChild hElementItem

            ' Title
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "title"
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            Set hElement = hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("h2")
                hElement.appendChild hChildrenElement
                Set hElement = hChildrenElement
                
                    Set hChildrenElement = hDoc.createElement("b")
                    hChildrenElement.innerText = 1 ' oItem(lgItem).Title
                    hElement.appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' DateUpload
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "date_upload"
            hChildrenElement.innerText = 1 ' oItem(lgItem).Date
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' Image
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "image"
            hChildrenElement.innerText = 1 ' oItem(lgItem).Image
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            
            Set hChildrenElement = hDoc.createElement("br"): hElementItem.appendChild hChildrenElement
            
            ' Release-info
            Set hChildrenElement = hDoc.createElement("div")
            hChildrenElement.setAttribute "class", "release_info"
            hDoc.getElementById("ActiveItem").appendChild hChildrenElement
            Set hElement = hChildrenElement
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "year"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "isbn"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "pages"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "size"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "format"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
                Set hChildrenElement = hDoc.createElement("div")
                hChildrenElement.setAttribute "class", "other"
                hChildrenElement.innerText = 1 ' oItem(lgItem).Image
                hElement.appendChild hChildrenElement
            
            ' More block...
            'Set hChildrenElement = hDoc.createElement("more")
            'hChildrenElement.setAttribute "class", "???"
            'hElementItem.appendChild hChildrenElement
            'Set hElement = hChildrenElement
            
            ' Description
            'Set hElement = hDoc.createElement("div")
            hElement.setAttribute "class", "text_description"
            hElement.innerText = oItem(lgItem).Description
            hBody.appendChild hElement
            
            ' Links

' Password any?

            Set hElement = hDoc.createElement("div"): hElement.setAttribute "id", "ActiveUL"
            hElement.setAttribute "class", "download_links"
            hDoc.getElementById("ActiveItem").appendChild hElement
            
            Set hElement = hDoc.createElement("ul"): hElement.setAttribute "id", "ActiveUL"
            hDoc.getElementById("ActiveItem").appendChild hElement
            'For lgLink = 1 to 1
                Set hChildrenElement = hDoc.createElement("li")                 ' Create a node
                Set hElement = hChildrenElement
                Set hChildrenElement = hDoc.createElement("a")
                hChildrenElement.setAttribute "class", "download-btn"
                hChildrenElement.setAttribute "target", "_blank"
                hChildrenElement.setAttribute "href", oItem(lgItem).Link(lgLink)
                hChildrenElement.innerText = "Download"
                hElement.appendChild hChildrenElement
                'Set hNode = hDoc.createTextNode("TEXT")    ' Create a text node
                '.AppendChildNode

                hDoc.getElementById("ActiveUL").appendChild hElement
                hDoc.getElementById("ActiveUL").appendChild hDoc.createElement("br")
            'Next lgLink
            'Set hElement = hDoc.getElementById("ActiveUL")
            hDoc.getElementById("ActiveUL").removeAttribute ("id")

            hDoc.getElementById("ActiveItem").removeAttribute ("id")
        End If

        ' If we want to deploy the index local/web, maybe try worth considering the following code:
        'Set hCollection = hDoc.getElementsByTagName("img")
        'If hCollection.Length = 0 Then Stop
        'For Each hElement In hCollection
        '    strSrc = hElement.getAttribute("src")
        '    'hElement.removeAttribute ("src")
        '
        '    strSrc = VBA.Replace(strSrc, "\", "/") 'from local to Web
        '    strSrc = VBA.Replace(strSrc, "/", "\") 'from Web to local
        '
        '    If strSrc <> vbNullString Then
        '        hElement.setAttribute "src", strSrc
        '    End If
        '
        '    On Error Resume Next
        '    strSrc = ""
        'Next hElement
        '
        'Set hCollection = hDoc.getElementsByTagName("a")
        'If hCollection.Length = 0 Then Stop
        'For Each hElement In hCollection
        '    strSrc = hElement.getAttribute("href")
        '    strSrc = VBA.Mid$(strSrc, 1, VBA.InStr(1, strSrc, "&name", vbTextCompare) - 1)
        '
        '    If VBA.InStr(1, strSrc, "#") > 0 Then
        '        strBookmark = VBA.Mid$(strSrc, VBA.InStr(1, strSrc, "#"))
        '        strSrc = VBA.Mid$(strSrc, 1, VBA.Len(strSrc) - VBA.Len(strBookmark))
        '    End If
        '
        '    strSrc = VBA.Replace(strSrc, "\", "/") 'from local to Web
        '    strSrc = VBA.Replace(strSrc, "/", "\") 'from Web to local
        '    On Error GoTo 0
        'Next hElement

        'Print #iFileOut, hDoc.DocumentElement.innerHTML
        'Close #iFileOut

    Next lgItem

Stop

ExitProc:
    Set hElement = Nothing
    Set hElementItem = Nothing
    Set hChildrenElement = Nothing
    Set hDoc = Nothing
    'Call fIE_Terminate
    Exit Sub

ErrControl:
    'Handle Error
    Resume ExitProc
End Sub
And there should come here some downloader code, but I suspect wp will kill also, as it’s full with < and > symbols

Engineering blogs

Following is a list of spanish civil engineering blogs:
    • http://ingenieriaenlared.wordpress.com/
    • http://estructurando.net/
    • http://www.fierasdelaingenieria.com/
    • http://geojuanjo.blogspot.com.es/
    • http://enriquemontalar.com/
    • http://www.carreteros.org/
    • http://infocivil.es/
    • http://treneando.com/
    • http://manologallegos.blogspot.com.es/
    • https://unblogdeingenieria.wordpress.com/otras-web-sobre-ingenieria/