2018 products Offline Installers Links
From AutoDesk help we get the 2018 product links:
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 SubIn 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.
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 FunctionWith this basic structure done, we can modify code to get the fill and contour of the shape, and any other property as Comments,…
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 SubThese 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 FunctionFollowing 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
Public Sub sShp_UnselectMe() End SubThere 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 SubBut 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
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 FunctionEnjoy it!