VBA Web Scrapping

There’s so much information out there to do this that I hardly beleive that I will add any interesting thing. But having all integrated in a post is as usefull as knowing how to do it. Let’s get on the matter.

The information for this post came from several sites:

First of all, you will need these references (add manually if they are not already loaded in the reference panel):
  • ietag 1.0 Type Library
  • iextag 1.0 Type Library
  • Microsoft HTML Object Library
  • Microsoft Internet Controls

Then, you could try several options:
InternetExplorer instance, declared as:
Dim objIE As Object: Set objIE = CreateObject("InternetExplorer.Application") 'for late binding (no references needed)
Dim objIE As HDocVw.InternetExplorer: Set objIE = New HDocVw.InternetExplorer ' for early binding (need references)
Here we have a first divergence, if browsing local pages or net pages. For local, we should use Internet Explorer Medium instead of the normal instance. If should be declared as: 'Set objIE = New InternetExplorerMedium Set objIE = CreateObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium Set objIE = GetObject("new:{D5E8041D-920F-45e9-B8FB-B1DEB82C6E5E}") 'Internet Explorer Medium

VBA Draw on userform

I have a life of suffering whenever I tried to draw “accurately” on an Excel Userform. The thing is that the management of units and sizes/position of the userform it’s a real pain “in that part”.
When you call GetCursorPos API function, the mouse position is retrieved in pixels, but if you want to set the size on the userform the units are Twips. Worse is that you need a reference point, and even with everything properly tunned, you find that the dimensions are close but they do not match 100%.
In every userform there is a caption/tittle bar and surrounding the userform there is a “border” (even if the userform is set to fmBorderStyleNone = 0), you can see a fading shadow that is included in the GetWindowRect API… 
For a long time my best guess was that the mouse position was not on the tip but on some intermediate position… until I decided to take a photo of the screen with the mobile and count the pixels. WTF!
Following code will output sizes and cursor positions to several labels (Label1, Label2, Label3). Label3 should match the Userform.InteriorWidth and UserForm.InteriorHeight value. Label1 reflects the UserForm_MouseDown X,Y values (in Twips), and should match the computed values from GetCursorPos in Label2:
Option Explicit

'API Declares
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As tPointAPI) As Long
Private Declare Function ExtTextOut Lib "gdi32" Alias "ExtTextOutA" (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long, ByVal wOptions As Long, ByVal lpRect As Any, ByVal lpString As String, ByVal nCount As Long, lpDX As Long) As Long
Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, ByRef lpRect As RectAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RectAPI) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" (ByVal lpAppName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long

#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
    Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hDC As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
    'Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    'Private Declare PtrSafe Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Integer, ByVal nWidth As Integer, ByVal nEscapement As Integer, ByVal nOrientation As Integer, ByVal fnWeight As Integer, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
    Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As tPointAPI) As Long
    Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare PtrSafe Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long

    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
    
    Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef Token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByVal lpOutputBuf As LongPtr = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal Token As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, ByRef graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
    Private Declare PtrSafe Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mSmoothingMode As Long) As Long
    
    Private Declare PtrSafe Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As GpUnit, ByRef mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As LongPtr) As Long
    Private Declare PtrSafe Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As LongPtr) As Long
    
    Private Declare PtrSafe Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mBrush As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    
    Private Declare PtrSafe Function GdipDrawLineI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare PtrSafe Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare PtrSafe Function GdipDrawBezierI Lib "gdiplus" (ByVal mGraphics As LongPtr, ByVal mPen As LongPtr, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
    Private Declare PtrSafe Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As tPointAPI, ByVal nCount As Long) As Long
    
    Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    Private Type GDIPlusStartupInput
      GdiPlusVersion                      As Long
      DebugEventCallback                  As LongPtr
      SuppressBackgroundThread            As Boolean
      SuppressExternalCodecs              As Boolean
    End Type

#Else
    Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData 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 CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
    'Private Declare Function CreateFont Lib "gdi32.dll" Alias "CreateFontA" (ByVal nHeight As Integer, ByVal nWidth As Integer, ByVal nEscapement As Integer, ByVal nOrientation As Integer, ByVal fnWeight As Integer, ByVal fdwItalic As Long, ByVal fdwUnderline As Long, ByVal fdwStrikeOut As Long, ByVal fdwCharSet As Long, ByVal fdwOutputPrecision As Long, ByVal fdwClipPrecision As Long, ByVal fdwQuality As Long, ByVal fdwPitchAndFamily As Long, ByVal lpszFace As String) As Long
    Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
    Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
    Private Declare Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32A" (ByVal hDC As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As tPointAPI) As Long
    Private Declare Function MulDiv Lib "kernel32.dll" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
    Private Declare Function GetDC Lib "user32.dll" (ByVal hwnd As Long) As Long
    Private Declare Function GetDeviceCaps Lib "gdi32.dll" (ByVal hDC As Long, ByVal nIndex As Long) As Long
    Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hDC As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWndForm As LongPtr, ByVal hDCForm As LongPtr) As Long

    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long

    Private Declare Function GdiplusStartup Lib "gdiplus" (ByRef Token As LongPtr, ByRef lpInput As GDIPlusStartupInput, Optional ByVal lpOutputBuf As LongPtr = 0) As Long
    Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal Token As LongPtr) As Long
    
    Private Declare Function GdipCreateFromHDC Lib "gdiplus" (ByVal hDC As LongPtr, ByRef graphics As LongPtr) As Long
    Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
    Private Declare Function GdipSetSmoothingMode Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mSmoothingMode As Long) As Long
    
    Private Declare Function GdipCreatePen1 Lib "GdiPlus.dll" (ByVal mColor As Long, ByVal mWidth As Single, ByVal mUnit As GpUnit, ByRef mPen As Long) As Long
    Private Declare Function GdipDeletePen Lib "GdiPlus.dll" (ByVal mPen As Long) As Long
    Private Declare Function GdipCreateSolidFill Lib "GdiPlus.dll" (ByVal mColor As Long, ByRef mBrush As Long) As Long
    Private Declare Function GdipDeleteBrush Lib "GdiPlus.dll" (ByVal mBrush As Long) As Long
    
    Private Declare Function GdipFillRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare Function GdipFillEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mBrush As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    
    Private Declare Function GdipDrawLineI Lib "gdiplus" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
    Private Declare Function GdipDrawRectangleI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare Function GdipDrawEllipseI Lib "GdiPlus.dll" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal mX As Long, ByVal mY As Long, ByVal mWidth As Long, ByVal mHeight As Long) As Long
    Private Declare Function GdipDrawBezierI Lib "gdiplus" (ByVal mGraphics As Long, ByVal mPen As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long, ByVal X4 As Long, ByVal Y4 As Long) As Long
    Private Declare Function Polyline Lib "gdi32" (ByVal hDC As Long, lpPoint As tPointAPI, ByVal nCount As Long) As Long
    
    Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

    Private Type GDIPlusStartupInput
      GdiPlusVersion                      As Long
      DebugEventCallback                  As Long
      SuppressBackgroundThread            As Boolean
      SuppressExternalCodecs              As Boolean
    End Type
#End If

Private Enum GpUnit
  UnitWorld = 0&
  UnitDisplay = 1&
  UnitPixel = 2&
  UnitPoint = 3&
  UnitInch = 4&
  UnitDocument = 5&
  UnitMillimeter = 6&
End Enum


' CONSTANTS
Private Const TWIPSPERINCH As Long = 1440
' Used to ask System for the Logical pixels/inch in X & Y axis
Private Const LOGPIXELSY As Long = 90
Private Const LOGPIXELSX As Long = 88

'.....................
Private Type tPointAPI
    X As Long
    Y As Long
End Type

Private Type RectAPI
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'.....................

Private oPoint As tPointAPI
Private oFormRect As RectAPI
Private oClientRect As RectAPI
Private lgParentBorderTop As Long
Private lgParentBorder As Long

Private ppiH As Integer
Private ppiV As Integer
Private dpiH As Integer
Private dpiV As Integer
Private FactorX_pixelToDot As Double
Private FactorY_pixelToDot As Double

Private hDC_Display As Long
Private hWndForm As Long
Private hDCForm As Long

Private Declare Function GetSystemMetrics32 Lib "user32" Alias "GetSystemMetrics" (ByVal nIndex As Long) As Long

Private Const SM_CXSCREEN As Long = 0
Private Const SM_CYSCREEN As Long = 1
Private Const SM_CXFULLSCREEN = 16
Private Const SM_CYFULLSCREEN = 17

Private Function ConvertPixelsToPoints(ByRef X As Single, ByRef Y As Single)
    X = X * FactorX_pixelToDot
    Y = Y * FactorY_pixelToDot
End Function

Private Sub UserForm_Initialize()
' Total size of monitor in pixels:
    Dim X As Long
    Dim Y As Long

    X = GetSystemMetrics32(SM_CXFULLSCREEN) ' SM_CXSCREEN)
    Y = GetSystemMetrics32(SM_CYFULLSCREEN) ' SM_CYSCREEN)
    
    Dim lgRetVal As Long
    
    'Start Userform Centered inside Excel Screen (for dual monitors)
    Me.StartUpPosition = 0
    Me.Left = Application.Left + (0.5 * Application.Width) - (0.5 * Me.Width)
    Me.Top = Application.Top + (0.5 * Application.Height) - (0.5 * Me.Height)
    
    ' Get hWnd and DC for userform
    hWndForm = FindWindow(vbNullString, Me.Caption)
    hDCForm = GetDC(hWndForm)
    
    ' The window rect includes the non-client area, i.e. the title bar, borders, scroll bars, status bar... The client rect does not (only the size of the area that you can render to), but is a rectangle that is relative to itself.
    Call GetWindowRect(hWndForm, oFormRect)
    Call GetClientRect(hWndForm, oClientRect)
    lgParentBorder = ((oFormRect.Right - oFormRect.Left) - oClientRect.Right) \ 2
    lgParentBorderTop = ((oFormRect.Bottom - oFormRect.Top) - oClientRect.Bottom) - lgParentBorder
    
    hDC_Display = CreateDC("DISPLAY", "", "", 0)
    ppiH = GetDeviceCaps(hDC_Display, LOGPIXELSX) ' pixels per inch
    ppiV = GetDeviceCaps(hDC_Display, LOGPIXELSY) ' pixels per inch
    dpiH = 72                                     ' dots per inch
    dpiV = 72                                     ' dots per inch
    FactorX_pixelToDot = dpiH / ppiH
    FactorY_pixelToDot = dpiH / ppiH
    DeleteDC hDC_Display   ' free memory
    
    Label1.Caption = Me.InsideWidth & " " & Me.InsideHeight ' the inside is the client area // Me.Width & " " & Me.Height
    'Label2.Caption = MulDiv(oRect.Left, dpiH, ppiH) & " " & MulDiv(oRect.Top, dpiV, ppiV)
End Sub

Private Sub UserForm_Click()
    Call GetCursorPos(oPoint)
    Dim oPointDot As tPointAPI
    
    With oPoint
        Call GetWindowRect(hWndForm, oFormRect)
        Label3.Caption = ((oFormRect.Right - oFormRect.Left) - 2 * lgParentBorder) * FactorX_pixelToDot & " " & ((oFormRect.Bottom - oFormRect.Top) - lgParentBorderTop - lgParentBorder) * FactorY_pixelToDot
        
        oPointDot.X = (.X - oFormRect.Left - lgParentBorder) * FactorX_pixelToDot
        oPointDot.Y = (.Y - oFormRect.Top - lgParentBorderTop) * FactorY_pixelToDot
        Label2.Caption = oPointDot.X & " " & oPointDot.Y
    End With
End Sub

Private Sub UserForm_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    Label1.Caption = X & " " & Y
End Sub

Private Sub UserForm_Terminate()
  'Call TerminateGDI
  ReleaseDC hWndForm, hDCForm
End Sub
And that’s all, I can now draw with high acurate in the userform.

VBA C++ type equivalences

Some template and type conversions equivalences from C++
'    [Public | Private] Declare Function publicname Lib "libname" _
    [Alias "alias"] [([[ByVal | ByRef] argument [As Type] _
    [, [Byval | ByRef] argument [As Type]] ...])] [As Type]

'Overview of the Declare Statement
'    [Public | Private] Declare [Ansi | Unicode | Auto] Sub | _
    Function <name> Lib "<library"> [Alias "<alias>"] [([argument list])]

'Data Types (As Type)
'
'The functions that make up the Windows API are written in C. Here are some of the most common data types you will encounter when using the API.
'
'    Integer: Used for 16-bit numeric arguments.
'    Equivalent to the short, unsigned short and WORD data types in C
'    Long: Used for 32-bit arguments.
'    Corresponds to the C data types: int, unsigned int, unsigned long, DWORD, and LONG.
'    String: Equivalent C Data type is LPSTR
'    Structure: A Structure is the C++ equivalent to a Visual Basic UDT (User Defined Type)
'    Any: Some functions accept more than one data type for the same argument
'
'A short table that helps you translate the C++ variable type declaration to its equivalent in Visual Basic:
' C++ Variable    Visual Basic Equivalent
' ATOM          ByVal variable as Integer
' BOOL          ByVal variable as Long
' BYTE          ByVal variable as Byte
' CHAR          ByVal variable as Byte
' COLORREF      ByVal variable as Long
' DWORD         ByVal variable as Long
' HWND          ByVal variable as Long
' HDC           ByVal variable as Long
' HMENU         ByVal variable as Long
' INT           ByVal variable as Long
' UINT          ByVal variable as Long
' LONG          ByVal variable as Long
' LPARAM        ByVal variable as Long
' LPDWORD       variable as Long
' LPINT         variable as Long
' LPUINT        variable as Long
' LPRECT        variable as Type any variable of that User Type
' LPSTR         ByVal variable as String
' LPCSTR        ByVal variable as String
' LPVOID        variable As Any use ByVal when passing a string
' LPWORD        variable as Integer
' LPRESULT      ByVal variable as Long
' NULL          ByVal Nothing or ByVal 0& or vbNullString
' SHORT         ByVal variable as Integer
' VOID          Sub Procecure not applicable
' WORD          ByVal variable as Integer
' WPARAM        ByVal variable as Long


'DataType Differences
'
'The following table lists data types used in the Win32 API and C-style functions. Many unmanaged libraries contain functions that pass these data types as parameters and return values. The third column lists the corresponding .NET Framework built-in value type or class that you use in managed code. In some cases, you can substitute a type of the same size for the type listed in the table.
'Unmanaged type in Wtypes.h
'               Unmanaged C language type
'                                  Managed class name
' handle        void*              System.IntPtr
' BYTE          unsigned char      System.Byte
' SHORT         short              System.Int16
' WORD          unsigned short     System.UInt16
' INT           int                System.Int32
' UINT          unsigned int       System.UInt32
' LONG          long               System.Int32
' BOOL          long               System.Int32
' DWORD         unsigned long      System.UInt32
' ULONG         unsigned long      System.UInt32
' CHAR          char               System.Char
' lpStr         Char*              System.String Or System.StringBuilder
' LPCSTR        Const char*        System.String or System.StringBuilder
' LPWSTR        wchar_t *          System.String Or System.StringBuilder
' LPCWSTR       Const wchar_t*     System.String or System.StringBuilder
' FLOAT         Float              System.Single
' DOUBLE        Double             System.Double

VBA measure With and Height for fonts

This week I’ve been dealing with Fonts. I need it for my new “creature” related to road signaling.

There are a lot of API functions out there that can be put to some use, and not that little are quite difficult to get documented properly from web queries.

These are part of my efforts…
Continue reading “VBA measure With and Height for fonts”

VBA detect DXF structure

The following code will generate the structure for a DXF file, from a template. Function fFile_load are not supplied, but it loads a text file as a bunch of lines (search the web for procedures to achieve this task) .

Option Explicit

Private Type tSeed
    Id As String
    Type As String
    Line As Long
End Type

Private Type tDependency
    Id As String
    Element As String
    Parent As String
    Line As Long
End Type

Sub sMacro1()
'Call stx_Profile_Fast
    Dim aLine() As String
    Dim aSeed() As tSeed
    Dim aDependency() As tDependency
    Dim lgLine As Long
    Dim lgZero As Long
    Dim lgSeed As Long
    Dim lgDependency As Long
    Dim Code As Integer
    Dim strText As String
    Dim aStopper() As String
    Dim lgStopper As Long
    
    lgSeed = g_Base - 1
    lgDependency = g_Base - 1
    ReDim Preserve aStopper(g_Base To g_Base)
    aStopper(g_Base) = "EOF"
    'Stoppers: "EOF|ENDSEC|ENDTAB|ENDBLK|SEQEND"

    aLine() = fFile_Load(vba.environ("UserProfile") & "\Documents\#test.dxf")
Stop

    For lgLine = LBound(aLine) To UBound(aLine) Step 2
        Code = VBA.CLng(aLine(lgLine))
        If Code = 0 Then
            strText = aLine(lgLine + 1)
            'If Not (Not aStopper) Then
            For lgStopper = LBound(aStopper) To UBound(aStopper)
                If aStopper(lgStopper) = strText Then Exit For
            Next lgStopper
            'End If
            
            If lgStopper > UBound(aStopper) Then
            If strText Like "*END*" Then
                ReDim Preserve aStopper(g_Base To lgStopper)
                aStopper(lgStopper) = strText
            End If
            End If
        End If
    Next lgLine
    
    For lgLine = LBound(aLine) To UBound(aLine) Step 2
        Code = VBA.CLng(aLine(lgLine))
        If Code = 5 Then
            lgSeed = lgSeed + 1
            ReDim Preserve aSeed(g_Base To lgSeed)
            With aSeed(lgSeed)
                .Id = aLine(lgLine + 1)
                
                ' Find the 0 backwards (will set the Entity declaration)
                For lgZero = lgLine To LBound(aLine) Step -2
                    If VBA.CLng(aLine(lgZero)) = 0 Then
                        .Type = aLine(lgZero + 1)
                        
                        ' Store ending with "§" if more than one of this item
                        Dim lgItem As Long
                        Dim aItem() As String
                        For lgItem = LBound(aItem) To lgSeed - 1
                            If aItem(lgItem) = aSeed(lgSeed).Type Then
                                aItem(lgItem) = aSeed(lgSeed).Type & "§" ' more than one of these
                                Exit For
                            ElseIf aItem(lgItem) Like aSeed(lgSeed).Type & "§" Then
                                aItem(lgItem) = aSeed(lgSeed).Type ' more than one of these
                                Exit For
                            End If
                        Next lgItem
                        Exit For
                    End If
                Next lgZero
                .Line = lgLine + 1
            End With
        End If
    Next lgLine


    ' Once we have located the seeds, find dependencies
    For lgLine = LBound(aLine) To UBound(aLine) Step 2
        Code = VBA.CLng(aLine(lgLine + 0))
        strText = aLine(lgLine + 1)
        If 320 <= Code And Code <= 369 Then
        'Search for this code in all aSeed
            lgDependency = lgDependency + 1
            ReDim Preserve aDependency(g_Base To lgDependency)
            With aDependency(lgDependency)
                .Id = aLine(lgLine + 1)
                .Line = lgLine + 1
                
                ' Find the 0 backwards (will set the Entity declaration)
                For lgZero = lgLine To LBound(aLine) Step -2
                    If VBA.CLng(aLine(lgZero)) = 0 Then
                        .Element = aLine(lgZero + 1)
                        Exit For
                    End If
                Next lgZero
            
                ' Search for seed parent item/entity
                For lgSeed = LBound(aSeed) To UBound(aSeed)
                    If aSeed(lgSeed).Id = strText Then
                        .Parent = aSeed(lgSeed).Type
                        .Line = aSeed(lgSeed).Line
                        Exit For
                    End If
                Next lgSeed
            End With
        End If
        strText = aLine(lgLine + 1)
    Next lgLine
    
    
Stop
End Sub
Now you have more than a guess to find what seed is linked to what entity.

Custom menu for Add-In

Here is a handy resume if you want to make a user interface for your add-ins, like those customized for the Office Fluent Ribbon, via XML. For a full description of the format, please, take a look at MS-CUSTOMUI format spectification (a monstruosity of 553 pages in the 8.0 version). This resume is a mashup of info from these two sites: 1 and 2.

Note: before we get hands on, it should be noted that we need to set a reference in the VBA project (in the VBA editor, Tools menu –> References) to the Microsoft Office 1x.0 Object Library (12.0 for office 2007, 14.0 for 2010 or 15.0 for 2013 or 16.0 for 2016).

Although all this menu building proccess can be done with the NotePad, is highly recomendable to use an editor like RibbonX, with you can easily build custom ribbons automatically, and you won’t have to worry about choosing relationships, changing spreadsheets to ZIP files, and manipulating controls.

XML Structure

The basic structure representation of the XML schema is like the one shown on the following image, taken from MontaRibbons:

The XML code fot this representation would be like this, structured in Tabs, Groups, and Controls:

   ...

    ... 
    ...  'Office 2007

   
     
       
     
   


    ...  'Office 2010, Office 2013 and Office 2016

Where the xx in the numerations of the first line (this is the XML NameSpace line) stands for the office version we are dealing with. In the xml file should be:

or

Use the first one if you’re using Office 2010 or earlier, and use the second one if you’re using 2013 or later. Although the first method works fine for newer versions of Excel, it just doesn’t have as many customizable features. The XML file is stored inside the XLSX/XLSM. Just rename to a ZIP file, which you can open and explore. Inside, you should see folders like _rels, docProps, and xl. For the customized Excel ribbon, you will need to add a new folder inside this ZIP file, and make some changes inside the existing _rels folder. You’re not allowed to create a new folder inside the .zip, so in order to add the folder, create a new folder outside the ZIP file (and name it, a suitable one is customUI). Inside the folder you just created, add a text file and replace .txt with .xml extension. Before the XML nameSpace line you can set the descriptor for XML
, but this isn’t required. One interesting point it to set an onLoad argument in the
  1. tag, like this:
    
    
    Specifying an onLoad argument isn’t typically necessary for basic custom ribbons, but it allows the user to run a macro (in this case, the macro sControlRibbon) each time the ribbon is loaded. This is important if you must control things like whether certain buttons or controls on your user interface are invalidated. You would do this via an IRibbonUI object macro in your Excel spreadsheet, like this.
    Public MyRibbon As IRibbonUI
    
    Public Sub sControlRibbon(byref ribbon As IRibbonUI)
        Set MyRibbon = ribbon
    End Sub
    

    Relations

    Also, you must add relationship(s) that connects to your customUI folder. Go ahead and add this line in anywhere between the Relationship tags; preferably, just before the closing tag: Using the built-in Windows tools, you won’t be able to add or manipulate individual files inside a zipped file. Instead, you should enter the zipped Excel Ribbon.zip folder, copy the _rels folder, and paste it outside the zipped file. Now, you can edit the .rels XML file inside. Open up the .rels file inside the _rels folder using Notepad. You should see something like this:
       . . . 
    
    
    for the 2006/01 version or
    
    
    if you’re using the 2009/07 version. Finally, the Target argument should match your folder name and custom XML file. Again, the Id is just a placekeeper and can be anything legal. Once you’ve added the line, save the .rels file. Next, you need to copy the _rels folder and the customUI folder (if you haven’t already done so) to the zipped file by dragging the folder to the zipped file. Before you can do that, you will need to open the ZIP file and first delete the original _rels folder. Windows won’t overwrite folders inside zipped files. Once you’ve dragged the new folders over, you can convert the .zip file back to a .xlsm by changing the file extension. When you open the file, you should have a new tab with two groups and four buttons. These buttons will have text labels, but they won’t actually do anything yet. Keep reading to see how to customize the appearance and behavior of these buttons.

    Controls

    The most used controls are splitButton and Button controls, and they are enough for most of the projects. Other useful elements that you could face with would be how to associate images to the controls, and some other special controls like Dropdowns/ComboBox. Each control has its own attributes to be configured (there are a bunch of parameters to deal with: size, subtitle, image, visibility, status, and others). One of the obligatory attributes, in some controls, is the id, which is an exclusive identification to identify the command. Let's take a look at the XML below where these attributes are set for some buttons:
      
      
        
         
         
        
       
    
    As images, one valid option would be to use icons from the office library (I recommend this free add-in to visualize them Dynamic Icon browser from S1), assign that is done via the attribute idMso, and the images by the attribute imageMso. If you want to add your own images, you can use image="imageID" instead of imageMso="msoID". However, you will need to add extra relationships and include the image in the Excel file.

    Adding Your Own Images or Icons

    To add your own images or icons to your custom ribbon, you’ll need to create two folders inside the customUI folder, which is the folder where we previously added the my_customUI.xml file. One of the folders is meant to hold your images, so we’ll name the folder images. In this folder, you just need to add the picture file you want to use and give each file a unique name. I typically use .png files with dimensions of 48x48, but there’s nothing magical about this. You just don’t want them too small or they’ll be blurry. The second folder should be called _rels folder. Your customUI folder should now look like this: In the _rels folder you just made, you’ll want to add one file. Pay attention now. This file should take the name of your XML file (my_customUI.xml for us) and have .rels added to the end. Thus our final filename for the sole file in this new _rels folder should be my_customUI.xml.rels. This .rels file will tell Excel how to identify the images you want to put on your ribbon. It will contain a relationships tag with the filename of each of our images and an ID we’ll use to reference these pictures. You’re file should look something like this:
        
    You can have as many Relationship tags as you want. Each tag represents a new picture in your images folder. It’s okay to use the 2006 version of the schema type for images, even if you are using the 2009 version for the main XML file you created earlier. In this example, we placed a picture called my_pic_filename.png in our images folder. If we want to add that image to a button on our Excel Ribbon, you would call this picture by the ID we specified: my_icon_1. The line to add this image to our button in the my_customUI.xml file would look like this:
      
    
    
    Notice how we changed imageMso to just image. As long as your relationships are set up correctly and you match the ID you supplied in the new _rels folder, you will see your image in the customized Excel ribbon. All you have to do is add this customUI folder back to your zipped spreadsheet by dragging it into the ZIP file. Don’t forget to delete the old folder in the .zip file before adding the new one. The Ribbon can be loaded with this function
    Public Function fncLoadRibbonXml()
    	Dim f As Integer
    	Dim strText As String
    	Dim strOut As String
    	Dim rsXml As DAO.Recordset
    	On Error GoTo fError
    
    	'------------------------------------------------------------------------------
    	'This function loads the ribbons stored in the XML file
    	'
    	'Create a table named tblRibbonsXml with the fields:
    	'RibbonName - In this field you stores the name you want to give to the ribbon
    	'RibbonXml - In this field you reports the Xml file name 
    	'
    	'This example assumes that you are with the XML files in
    	'the same place of your Database
    	'------------------------------------------------------------------------------
    	f = vba.FreeFile()
    	Set rsXml = CurrentDb.OpenRecordset("tblRibbonsXml", , dbOpenDynaset)
    	Do While Not rsXml.EOF
    	   Open CurrentProject.Path & "\" & rsXml!RibbonXml For Input As f
    
    	   Do While Not EOF(f)
    		  Line Input #f, strText
    		  strOut = strOut & strText & vbCrLf
    	   Loop
    
    	   Application.LoadCustomUI rsXml!RibbonName, strOut
    	   strOut = ""
    	   strText = ""
    	   f = FreeFile
    	   rsXml.MoveNext
    	Loop
    fExit:
       Exit Function
    fError:
       Select Case Err.Number
          Case 3078
             MsgBox "Table not found...", vbInformation, "Warning"
          Case Else
             MsgBox "Error: " & Err.Number & vbCrLf & Err.Description, _
    
             vbCritical, "Warning", Err.HelpFile, Err.HelpContext
       End Select
    Resume fExit:
    End Function
    
    What attribute must we use to give features to the Ribbon buttons? The attribute used is onAction. We can use it to give it a function or a macro to execute a specific action. Here you will see the functionality of the id, which we talked about in the first class. An example of Button control with onAction attributes:
    
    
    The action when clicked is the one stated on the onAction attribute. This attribute can be dynamic, and respond to several parameters, or can be set for the whole ribbon controls, like in the following example:
    Public Sub fncOnAction(control As IRibbonControl)
    Select Case control.Id
       Case "btCustomers"
          Load frmCustomers 'Opens the customers form
       Case Else
           MsgBox "You clicked the button " & control.Id, vbInformation, "Warning"
    End Select
    End Sub
    
    The control.id has the value Id of the button that had been clicked, and with the SELECT we configure the right command to be applied to the added button. For a button control, we have the following list of gets attributes: getDescription getEnabled getImage getKeytip getLabel getScreentip getShowImage getShowLabel getSize getSupertip getVisible Also, these attributes can be set through user defined functions, if used like:
    
    
    Public Sub fncGetVisible(byref control As IRibbonControl, ByRef visible)
    Select Case control.id 
       Case "btCustomers"
          if user = "john" then
             visible = false
          elseif user ="carlos" then
             visible = true
          end if
    End Select
    End Sub
    
    Public Sub fncGetLabel(byref control As IRibbonControl, ByRef label)
    Select Case control.id 
       Case "btCustomers"
          if language = "portuguese" then
             label = "Clientes"
          elseif language = "english" then
             label = "Customers"
          end if
    End Select
    End Sub
    
    You can also customize the controls with our own images. When the ribbon is loaded for the first time, are evaluated each of the gets used and their values are loaded, as the functions of each attribute. Once loaded for this first time, the ribbon has two methods called Invalidate and InvalidateControl to reload the ribbon. The Invalidate revalidates all the controls of a ribbon, while the method InvalidateControl revalidates the control that you specify To revalidate the state of a buttons of a loaded ribbon, you just need to enter the id attribute of the control to be revalidated inside quotation marks: objRibbon.invalidateControl ("btName") To access the methods Invalidate and InvalidateControl we must do some configurations. The first one is to refer to the class "Microsoft Office 1x.0 Object Library", the second is to put the Ribbon in the cache, by a variable. In the code below, the fncRibbon, which must be in a global module, changes dynamically the ribbon:
    Option Compare Database
    Public objRibbon As IRibbonUI
    
    Public Sub fncRibbon(ribbon As IRibbonUI)
    On Error Resume Next
    'objRibbon will be used by us to realize changes in the ribbon at runtime
    Set objRibbon = ribbon
    End Sub
    
    To complete it you need to put the ribbon in the variable objRibbon, called by the function fncRibbon. This is done by the onLoad attribute of the tag customUI. See a part of the xml:
    
    ...
    ...
    
    
    We can insert external images in all ribbon’s controls that allow the use of the attributes image and getImage. We use the getImage only when we need to select images at runtime; if not, we use the attribute image. Montaribbons has a folder named imagens and there you can find as example 2 files: avel.gif and feed.png, that are used at the example ribbon rblimages. When you are creating your ribbon, copy your images to the folder imagens of Montaribbons. You should then, copy them to the folder images of your project. Create the folder images, at the same place of the application – that makes programming easier and allow us to use the relative path with the property CurrentProject.Path. For the atribute image work, its necessary the use of the atribute loadimage os the tag CustomUI, that has the function of loading images fncLoadImage. Check below, the atribute loadimage in the tag customUI:
    
    ...
    
    ...
    
    
    Everytime the atribute image is used, it will use the function fncLoadImage See the function fncLoadImage:
    Public Sub fncLoadImage(imageId As String, ByRef Image)
    On Error GoTo fError
    Dim strPath As String
    strPath = CurrentProject.Path & "\images\"
        If InStr(imageId, ".png") > 0 Or InStr(imageId, ".ico") > 0 Then
            Set Image = LoadImage(strPath & imageId)
        Else
            Set Image = LoadPicture(strPath & imageId)
        End If
    fError_Exit:
        Exit Sub
    fError:
        Select Case Err.Number
            Case 2220
                MsgBox "Image " & imageId & _
    
                " not found on the path ...", vbInformation, "Warn"
            Case Else
                MsgBox "Erro: " & Err.Number & _
    
                vbCrLf & Err.Description, vbCritical, "Warn", _
                Err.HelpFile, Err.HelpContext
        End Select
        Resume fError_Exit:
    End Sub
    
    The argument imageld of the function has the name of the image of the attribute image of a control. This name must be the same as the image stored at the folder images. The argument image of the function, then, loads the image of the folder, on the control of the ribbon. Images GIF, JPEG and BMP are accepted directly on the controls (button, gallery...) of the ribbon, using the method LoadPicture of the Access. Images PNG and ICO must be turned into BMP to be loaded. This can be done by the function LoadImage, which uses APIs of the Windows to do it. MontaRibbons exports for your project these APIs in a module named mod_picture. Check the complete XML code of a Ribbon, using two buttons that load the images from the folder imagens of MontaRibbons:
    
    
    
    
    
            
    As I said, we can load our images using the atribute getImage. This option is used when we need to change an image at runtime. We will use as example the same XML above, just changing the image attribute for the getimage attribute. The attribute getimage do not depends on the attribute loadimage of the tag customUI.
    
    
    
    
    
           
    This way the image is defined in the function fncGetiImage. See the function below:
    Public Sub fncGetImage(control As IRibbonControl, ByRef Image)
    On Error GoTo fError
    Dim strPath As String
    Dim strImageName As String
    strPath = CurrentProject.Path & "\images\"
    Select Case control.Id
      Case "bt1"
    
         strImageName = "feed.png"
      Case "bt2"
    
         strImageName = "avel.gif"
    End Select
    
    If InStr(strImageName, ".png") > 0 Or InStr(strImageName, ".ico") > 0 Then
      Set Image = LoadImage(strPath & strImageName)
    Else
      Set Image = LoadPicture(strPath & strImageName)
    End If
    
    fError_Exit:
      Exit Sub
    fError:
      Select Case Err.Number
        Case 2220
          MsgBox "Button Image  " & control.Id & _
    
          " not found on the path...", vbInformation, "Warn"
        Case Else
          MsgBox "Erro: " & Err.Number & vbCrLf & Err.Description, _
    
          vbCritical, "Warn", Err.HelpFile, Err.HelpContext
      End Select
      Resume fError_Exit:
    End Sub
    
    To use external images in the ribbons, using the attributes image and getimage, we need a local folder to store those images. Nothing changes related to the XML code. What changes is the way of extracting images by the VBA code, that are now at a table. Remember that, to use the attribute image of the controls, you must use the attribute loadImage of the tag CustomUI, which calls the function fncLoadImage.
    
    ...
    
    ...
    
    
    To load the images stored at a folder, we use the LoadPicture method of the Access or the function LoadImage, to use PNG and ICO images. Check the function fncLoadImage used to load the images from a folder:
    Public Sub fncLoadImage(imageId As String, ByRef Image)
    Dim strPath As String
    strPath = CurrentProject.Path & "\images\"
        If InStr(imageId, ".png") > 0 Or InStr(imageId, ".ico") > 0 Then
            Set Image = LoadImage(strPath & imageId)
        Else
            Set Image = LoadPicture(strPath & imageId)
        End If
    End Sub
    
    The point is: how can we extract the Attachment type Field images from a local table? We can do it in two different ways: The first way is to extract the images directly from the attachment type field of a Form that is linked with the table, using the method PictureDisp The second way is to extract the image of the attachment type field , directly from the table, to a temporary folder, using the method SaveToFile We will use both ways See the code used to load, at the ribbon, the images extracted from an Attachment type Field, of a hidden form. This form is linked to the table that contains the images. Read carefully the comments in green!
    Option Compare Database
    Dim attAnexo As Attachment
     
    Public Sub fncLoadImage(imageId As String, ByRef Image)
    ‘Check if the form fmImgRibbons is open.
    If Not CurrentProject.AllForms("frmImgRibbons").IsLoaded Then
        'Open form to just read and hidden.
        DoCmd.OpenForm "frmImgRibbons", acNormal, , , acFormReadOnly, acHidden
        'Change the attached type field image of the form to the variable attAnexo
        Set attAnexo = Forms("frmImgRibbons").Controls("Images")
    End If
    
    'Load images JPG, BMP, or Gif
    'PictureDisp extracts Attachment type Field images of the form.
    Set Image = attAnexo.PictureDisp(imageId)
    
    End Sub
    
    Remember we can’t load images PNG or ICO directly in the ribbon? We still using the function LoadImage, that transforms these images in BMP. To use this function, the image must be in a local folder. The alternative is to copy the Attachment type Field image from the table to a local folder. This image, saved at a temporary folder, goes to the LoadImage function, that will use and give it to the ribbon. After this treatment, the image is deleted from the temporary folder. Check the code used to copy the Attachment type Field image from a table, to a temporary folder:
    Public Function fncExtractImage(strImageName As String) As String
    Dim strPath As String
    Dim rsParent As DAO.Recordset
    Dim rsChild As DAO.Recordset2
    Dim flData As Field2
    Dim flName As Field2
    
    strPath = CurrentProject.Path & "\temp"
    
    Set rsParent = CurrentDb.OpenRecordset("tblImagesRibbons")
    Set rsChild = rsParent.Fields("imageRibbon").Value
    Set flData = rsChild.Fields("filedata")
    Set flName = rsChild.Fields("Filename")
    
    'Check if the temporary folder temp exists. If not, creates it and put 
    'in hidden mode.
    If Len(Dir(strPath, vbDirectory + vbHidden) & "") = 0 Then
        FileSystem.MkDir (strPath)
        FileSystem.SetAttr strPath, vbHidden
    End If
     'Does a loop searching for the image.
    Do While Not rsChild.EOF
        If flName.Value = strImageName Then
            'Saves Attachment type Field image in the temporary folder.
            flData.SaveToFile (strPath)
            Exit Do
        End If
        rsChild.MoveNext
    Loop
    Set flName = Nothing
    Set flData = Nothing
    Set rsChild = Nothing
    Set rsParent = Nothing
    
    'The function gives the name and the pacho f the saved file, that will
    'be given the function LoadImage 
    fncExtractImage = strPath & "\" & strImageName
    
    End Function
    
    When the image is saved at the temporary folder, the function LoadImage will treat it. Observe the complete function fncLoadImage. Read carefully the comments in green.
    Option Compare Database
    Dim attAnexo As Attachment
     
    Sub fncLoadImage(imageId As String, ByRef Image)
    Dim strPath As String
     
    ‘Verify if the form fmImgRibbons is open. 
    If Not CurrentProject.AllForms("frmImgRibbons").IsLoaded Then
        'Open form to just read and hidden.
        DoCmd.OpenForm "frmImgRibbons", acNormal, , , acFormReadOnly, acHidden
        'Change the attached field form variable to attAnexo  
        Set attAnexo = Forms("frmImgRibbons").Controls("Images")
    End If
    
    'Verify if the image has the extension PNG or ICO to apply the
    'transformation function LoadImage
    If InStr(imageId, ".png") > 0 Or InStr(imageId, ".ico") > 0 Then
        'Give to the variable the local and the name of the PNG or ICO image,
        'saved in the temporary folder.
        strPath = fncExtractImage(imageId)
        'Transforms the PNG or ICO image into BMP, and puts in the ribbon.
        Set Image = LoadImage(strPath)
        'Deletes the image from the temporary folder Temp 
       FileSystem.Kill strPath
    Else
        'Load images JPG, BMP ou GIF
        Set Image = attAnexo.PictureDisp(imageId)
    End If
    End Sub
    
    Combobox and Dropdown With these controls, whe can have list to select items. They have their own gets attributes, in order to fill the list dynamically. - Assembling a list of reports; - Assembling a list of customers, that will serve as a filter to a form. The main difference between a ComboBox control and a Dropdown control is that in the ComboBox control, you can enter a value that is present or not in the list, what is not allowed in the Dropdown. And at the programming is a small advantage in the use of the ComboBox, because it allows the direct use of the list’s value. In the Dropdown the value returned is the list’s index. But this is no obstruction to using the Dropdown. Compare the two controls in the XML code:
    
    
    
    
    
    
    
    
    
    
    
    
    
    
    Note that the difference lies in the attributes that perform an action event. The OnAction attribute to the Dropdown and the attribute OnChange to the control Combobox. Let's try to dynamically fill a list, using the Dropdown control. The mechanics of filling: the attribute GetItemCount tells the Dropdown control the amount of items that will be on the list. The Dropdown control uses this information to trigger the attribute geItemLabel, the number of times needed, to get the names (labels) that will be on the list. Both the amount of items and the names that will fill the list will be captured in a table. The Description field is used to fill the list. And the order of this list will be controlled by the field idx. The first get to be triggered by the Dropdown is GetItemCount, which will capture the maximum number of items in the list that corresponds to the number of table records. Observe the fncGetItemCountDrop function.
    Sub fncGetItemCountDrop(control As IRibbonControl, ByRef count)
    ' Tell the Dropdown, by the variable count, the number of records from the 
    ' tblListaRelatorios table, which is the maximum amount of lines from the Dropdown.
    count = DCount("*", "tblReportList")
    End Sub
    
    And what is the use of the argument Control at the above function? It is used in the case of having more than one Dropdown control in the ribbons. See how the function is to control more than one Dropdown:
    Sub fncGetItemCountDrop(control As IRibbonControl, ByRef count)
      Select case control.id
        case "dd1" 'Name of a Dropdown control
          count = DCount("*", "NameTable")
        case "dd2" 'Name of Another Dropdown Control
          ' Tell the dropdown, through the count variable, the amount of
          ' tblListaRelatorios table records, which is the maximum amount of
          'lines on the dropdown.
          count = DCount("*", "tblReportList")
      end select
    End Sub
    
    Now that the Dropdown control knows the total amount of items that will have on the list, it will capture each of the items (label), through the attribute getItemLabel. Note the fncGetItemLabelDrop() function that the get will trigger to check the labels:
    Sub fncGetItemlabelDrop(control As IRibbonControl, index As Integer, ByRef label)
    ' Tell the Dropdown, by the label argument, the name of the stored report at the
    ' tblListReport table.
    ' idx is a unique number for each report, that has to match with the
    ' position (index) in the Dropdown.
    label = DLookup("description", "tblComboDynamic", "idx =" & index)
    End Sub
    
    Our example table has four records, which was the number reported for the Dropdown control. This will pass through fncGetItemLabelDrop() function 4 times. That's right! The function is called the amount of times the length of the list! And every time the control goes over the function, the argument index is increased by 1 (iIndex + 1). Always starting from zero (0). So it's easy to load the corresponding label, just synchronize the index argument with the idx table field. To complete, let's see the onAction attribute, which will provide functionality to the Dropdown control. The function triggered by this attribute is fncOnActiondrop ().
    Sub fncOnActionDrop(control As IRibbonControl,selectedId As String, selectedIndex As Integer)
    Dim strNameReport as string
    
    'The argument selectIndex brings the number of the item that was selected by the user 
    strNameReport = DLookup("report", "tblReportList", "idx =" & selectedIndex)
    
    DoCmd.OpenReport strNameReport, acViewPreview
    
    'Redo the list, cleaning the dropdown box
    objRibbon.InvalidateControl ("dd1")
    End Sub
    
    The name of the report is captured by the DLookup () function. See that we capture the report name that corresponds to the selectedIndex number, which should coincide with the field idx. And what about the COMBOX control? Just the same, except the call attribute onChange, and that will trigger the function fncOnChangeCbx:
    Sub fncOnChangeCbx(control As IRibbonControl, strText As String)
    dim strNameReport as string
    ' StrText argument has the value entered or selected from the combobox.
    ' We use this value to filter the DLookup() function, to capture from the table
    ' the exact name of the report to be open.
    strNameReport = dlookup("report","tblReportList","description='" & strText & "'") 
    DoCmd.OpenReport strNameReport, acViewPreview
    objRibbon.InvalidateControl ("cbx1")
    End Sub
    
    This was a very simple case, where the table had a greatly reduced number of records and it was possible to manually renumber the field idx, which determines the order in which information from the Description field will be loaded in the list control. As for a table, with a large amount of records and dynamic, using the idx field obviously becomes impossible. The issue is solved in a relatively simple way, which is to capture the table records, sort them into the desired way and store them temporarily in the computer memory, using a variable of the Array kind. This passage of information to memory is done in the function fncGetItemCountCbx, because it is triggered before the function fncGetItemLabelCbx, which gives the names to the list. Before proceeding, understand a little about Arrays variables. Arrays are variables that consist of a collection of values, called elements of the Array. Example:
    Dim strNomeCliente(20) as string
    
    This instruction creates an Array of 21 elements, each one being a conventional string variable. You create 21 elements because the first element of an array is zero (0). We will store specific information on each of the elements. Example:
    
    strNameClient(0) = "Avelino Sampaio"
    strNameClient(1) = "Pontocom Informática"
    ...
    strNameClient(20) = "Maestro Tecnologia"
    
    We have here the name Avelino Sampaio stored in element 0 and the name Pontocom stored in element 1. If we want to capture the name Avelino Sampaio from the variable, simply enter its element. Example:
    label = strNameClient(0)
    
    We can change the amount of elements of the variable dynamically, through the ReDim instruction. This allows us to determine the exact number of elements used, which will be equal to the number of records used:
    reDim strNameClient(Record number of the table) as string
    
    Pay attention to the code used, which will capture the customers' names to the variable strNomeCliente
    Sub fncGetItemCountCbx(control As IRibbonControl, ByRef count)
    Dim rs As DAO.Recordset
    Dim strSql As String
    Dim j As Long
    
    ' For the combobox frmClients form, we will make two tasks:
    ' 1st - Inform the quantity of items in the list for the combobox.
    ' 2nd - store in the computer memory, the names of clients who will fill the
    '       list of the ComboBox control.
    '       This memory contents will be used in the fncGetItemLabelCbx function 
    '       that will be triggered soon.
    ' Build a query of the table tblClients to obtain the records sorted
    ' by the client name.
    strSql = "SELECT cli_name FROM tblClients ORDER BY cli_name;"
    
    ' Opens query 
    Set rs = CurrentDb.OpenRecordset(strSql)
    rs.MoveLast: rs.MoveFirst
     
    ' Tell the Combobox, by the argument Count, the number of items that will be used.
     count = rs.RecordCount
    
    ' Determines the number of elements that will be stored at the variable
     ReDim strNameClient(rs.RecordCount) As String
    
    ' Here its passed to the strNameClient() variable the name of customers, record by record.
     j = 0
     Do While Not rs.EOF
        strNameClient(j) = rs!cli_Name
        j = j + 1
        rs.MoveNext
     Loop
     rs.Close
     Set rs = Nothing
    End Select
    End Sub
    
    Now the combobox knows how many names will have to load on the list, and go through the function fncGetItemlabelCbx the number of times required to load the names on the list. See how the function is very simple:
    Sub fncGetItemlabelCbx(control As IRibbonControl,index As Integer, ByRef label)
    ' The combobox will pass through this function the number of times equal to the number of
    ' records reported in the above function. And every time it come by, it will
    ' increasing the argument Index (index + 1)
     label = strNameClient(index)
    End Sub
    
    Note that we are capturing the values stored in the variable strNomeCliente() and the Index argument determines the value to be captured. The capture is being performed in sequence. StrNomeCliente (0), strNomeCliente (1), strNomeCliente (2), ..., StrNomeCliente (n). The names will be sorted in alphabetical order, as determined in the query sort. How we use the value selected from the list to perform the filtering on the form ? The function fncOnChangeCbx brings, in the strText argument, the value selected on the list. With this we can use the name of the client to perform the filtering. Follow the code:
    Sub fncOnChangeCbx(control As IRibbonControl, strText As String)
    ' We use the filter method to filter the form.
    ' strText brings the name of the client, selected by the user.
    
    Forms!frmClients.Filter = "cli_name='" & strText & "'"
    Forms!frmClients.FilterOn = True
    
    ' Rewrites and updates the list of the combobox to a new search.
    objRibbon.InvalidateControl ("cbx1")
    End Sub
    

    Steps

  2. Create a folder named customUI and add an xml file inside named my_customUI.xml.
  3. Convert your .xlsm spreadsheet to a ZIP file by adding a .zip to the end of the file name. It’ll give a warning, but that’s okay.
  4. Copy the _rels folder inside the ZIP file and paste it outside the ZIP file Copy the below code into the .rels file and save.
  5. Copy the below code into the my_customUI.xml file and save. Delete the _rels folder in the ZIP file.
  6. Copy both the new customUI folder and the modified _rels folder to the ZIP file by dragging the folders into the ZIP file.
  7. Convert the ZIP file back to a .xlsm file. Ensure you macros are callable from the buttons. Basically, just make sure they exist in a module in your spreadsheet and have the (Control As IRibbonControl) argument we talked about earlier.
  8. Place this code in the .rels file
          
    Place this code in the my_customUI.xml file
    
    
    
    
    
    	
    		
    		
    	
    	
    	
    		
    		
    	
    
    
    
    
    
    

Autodesk 2018 Direct Download Links

Autodesk 2018 Direct Download Links (Until Available on Virtual Agent)

Issue:  You are having a download failure error, similar to previous releases, that are causing installation errors of your 2018 product.  However, the Autodesk Virtual Agent does not yet list the products available for 2018. Work-Around:  Until the Virtual Agent is updated, we collective peers will try to provide Official direct download links from Autodesk.  This list may be updated as needed and links may or may not work as products are released.  You can also try the Browser Download method from your Autodesk Accounts Management page. If you have an official direct download link, that is tested and working, or have a URL of a direct download link that should work once the products are released, then please feel free to update the links in the comments below.  Please only use official Autodesk links.  Piracy is not tolerated here. AUTODESK 2018 DIRECT DOWNLOAD LINKS AutoCAD 2018 English 32 bit English 64 bit – Part 1 English 64 bit – Part 2 AutoCAD LT 2018English 32 bit English 64 bit Inventor Professional 2018 x64Part 1 Part 2 Part 3 Revit Live 2018 Download Navisworks Manage 2018Part 1 Part 2 Navisworks Simulate 2018Part 1 Part 2 Here are more working links for other 2018 products: DWG TrueView 2018 32 bit 64 bit Inventor View 2018Download Recap 360 ProDownload AutoCAD Raster Design 2018 32-bit 64-bit AutoCAD MAP 3D 2018 (x64) Part 1 Part 2 AutoCAD Electrical 2018 32-bit Part 1 32-bit Part 2 64-bit Part 1 64-bit Part 2 AutoCAD Mechanical 2018 32-bit 64-bit Part 1 64-bit Part 2 AutoCAD Architecture 2018 32-bit Part 1 32-bit Part 2 64-bit Part 1 64-bit Part 2 AutoCAD MEP 2018 32-bit Part 1 32-bit Part 2 32-bit Part 3 64-bit Part 1 64-bit Part 2 64-bit Part 3 Autodesk Sketchbook Pro Enterprise 2018 (x64) Download Inventor LT 2018 (x64) Part 1 Part 2 Vault 2018 Pro Vault Pro 2018 Server Vault Pro 2018 Client Vault 2018 File Server Vault 2018 File Server Vault Basic 2018 Vault Basic 2018 Server Vault Basic 2018 Client Here are additional links for Vault: Autodesk Vault 2018 Basic – Client (x64) Download Autodesk Vault 2018 Basic – Server (x64)Download I wonder if the e-fulfillment links expire after a certain amount of time?  Thanks for the updated links Darren. Advance Steel 2018 (64 bit) Part 1 Part 2 AutoDesk Advance Steel 2018 (x64) Part 1 Part 2 AutoDesk Alias Design 2018 (x64)Part 1 Part 2 AutoDesk Alias Surface 2018 (x64)Download AutoDesk Alias Speedform 2018 (x64)Download Autodesk Moldflow Insight Ultimate (x64) Download Autodesk Moldflow Adviser Ultimate (x64)Part 1 Part 2 AutoCAD Plant 3D English 2018 (x64)Part 1 Part 2 Revit 2018 Part 1 Part 2 Part 3 Civil 3D 2018 Part 1 Part 2 Part 3 Vehicle Tracking 2018 Vehicle Tracking 2018 Revit LT 2018 Part 1 Part 2 Revit Server 2018 (x64)Download I also wanted to provide an additional link for the Autodesk Network License Manager for 2018 Autodesk Network License Manager 2017/2018 Info Here Infraworks 2018 Infraworks 2018 Autodesk Building Design Suite Premium 2018 (x64)*Part 1 Part 2 Part 3 Part 4 Part 5 * This Suite is still available if you have maintained your maintenance Subscription for the Building Design Suite AEC Collection 2018 AutoCAD 2018English 32 bit English 64 bit – Part 1 English 64 bit – Part 2 Navisworks Manage 2018Part 1 Part 2 AutoCAD MAP 3D 2018 (x64) Part 1 Part 2 AutoCAD Architecture 2018 32-bit Part 1 32-bit Part 2 64-bit Part 1 64-bit Part 2 AutoCAD MEP 2018 32-bit Part 1 32-bit Part 2 32-bit Part 3 64-bit Part 1 64-bit Part 2 64-bit Part 3 AutoCAD Plant 3D English 2018 (x64)Part 1 Part 2 3ds Max 2018 Part 1 Part 2 Revit 2018 Part 1 Part 2 Part 3 Civil 3D 2018 Part 1 Part 2 Part 3 Vehicle Tracking 2018 Vehicle Tracking 2018 Revit Server 2018 (x64)Download Recap 360 ProDownload Infraworks 2018 Infraworks 2018 AutoCAD Raster Design 2018 32-bit 64-bit AutoCAD Electrical 2018* 32-bit Part 1 32-bit Part 2 64-bit Part 1 64-bit Part 2 *Autodesks website says Autocad Electrical comes with the AEC Collection i don’t think thats correct but adding anyway Product Design Ultimate 2018 Part 1 Part 2 Part 3 Part 4 Part 5 Here are some new links as well as some corrected links.  Thanks for your patience. 3DS Max 2018 (x64)Part 1 Part 2 AutoCAD Civil 3D English 2018 (x64)Part 1 Part 2 Part 3 Revit 2018 (x64)Part 1 Part 2 Part 3 Revit LT 2018 (x64)Part 1 Part 2 Vehicle tracking 2018Download Autodesk Building Design Suite Ultimate 2018 (x64)Part 1 Part 2 Part 3 Part 4 Part 5 Part 6 Autodesk Product Design Suite Ultimate 2018 (x64)Part 1 Part 2 Part 3 Part 4 Part 5 Autodesk Infrastructure Design Suite Premium 2018 (x64)Part 1 Part 2 Part 3 Part 4 Part 5 Autodesk InfraWorks 360 Pro 2018 (x64)Download Autodesk Robot Structural Analysis Professional 2018 (x64)Download Autodesk Factory Design Suite Ultimate 2018 (x64)Part 1 Part 2 Part 3 Part 4 Part 5 Part 6 Autodesk Infrastructure Design Suite Ultimate 2018 (x64)Part 1 Part 2 Part 3 Part 4 Part 5 AEC Collection 2018 (x64)AutoCAD 2018Part 1 Part 2 Revit 2018Part 1 Part 2 Part 3 Revit Server Download Civil 3D 2018Part 1 Part 2 Part 3 Infraworks 2018Download Navisworks Manage 2018Part 1 Part 2 AutoCAD Raster Design 2018Download 3DS Max 2018Part 1 Part 2 Vehicle Tracking 2018Download AutoCAD MAP 3D 2018Part 1 Part 2 AutoCAD Architecture 2018Part 1 Part 2 AutoCAD Electrical 2018Part 1 Part 2 AutoCAD MEP 2018Part 1 Part 2 Part 3 AutoCAD Plant 3D 2018Part 1 Part 2 Recap 360 ProDownload
AutoCAD Mobile AppDownload FormIt Pro AppDownload Insight Plug-in for Revit 2018Download Structural Analysis for Revit 2018Subscriber Login Autodesk Nastran In-CAD 2018 (x64)Download Autodesk Nastran 2018 (x64)Download Autodesk HSM Ultimate 2018 for Inventor and Solidworks (x64)Part 1 Part 2 Autodesk Simulation CFD 2018 (x64)Part 1 Part 2 A couple of Revit 2018 add-ins were made available last night Revit 2018 Steel Connections Revit 2018 Site Designer Autodesk InfraWorks 360 Pro 2018 (x64) Link Vault Workgroup 2018: Vault Workgroup 2018 (Server) Vault Workgroup 2018 (Client)

Polyline simplification

I think I have posted something about Douglas-Peucker algorithm, to reduce the number of vertices of a polyline. Polyline simplification is the process of reducing the resolution of a polyline, achieved by removing vertices and edges, while maintaining a good approximation of the original curve. In the end is a compromise between waste of resources and level of detail-the resolution of the polyline-.  There are some algorithms you can recall to: Simplification algorithms
  • Nth point – A naive algorithm that keeps only each nth point
  • Distance between points – Removes successive points that are clustered together
  • Perpendicular distance – Removes points based on their distance to the line segment defined by their left and right neighbors
  • Reumann-Witkam – Shifts a strip along the polyline and removes points that fall outside
  • Opheim – Similar to Reumann-Witkam, but constrains the search area using a minimum and maximum tolerance
  • Lang – Similar to the Perpendicular distance routine, but instead of looking only at direct neighbors, an entire search region is processed
  • Douglas-Peucker – A classic simplification algorithm that provides an excellent approximation of the original line
Error algorithms
  • Positional errors – Distance of each point from an original polyline to its simplification
In this articles there is a bit more information:  

Genetic algorithm with VBA

For more than a couple of years I’ve been dealing with a nightmare-like problem that I could not get solved with Excel. The solution I was working with implies choosing between nearly infinite combinatorial possibilities. The problem in question has a lot of dependencies in a variable number of variables you can set, is an open problem in its definition, and I was looking for the optimal one. You bet I will never achieve it. I was also stuck wandering if I could face situations where several options were possible; and I couldn’t discard that as not pausible. I considered GA as an alternative, but never put the enough time on studying the possibilities, considering I have not -or do not know, that is the same- a tool for GA in VBA. Times I spend  a bit more learning GA in YouTube or in blogs did not scratch the surface, and the only XLS file I played with was very basic, and came from this old post from Paras Chopra blog, and another one from Dermont Balson’s InsaneExcel death blog (under Artificial Intelligence). Continue reading “Genetic algorithm with VBA”

Function fitter VBA – Conjugate Gradient

I found a nice post about applying conjugate gradient for a function fitter. They show how to use the conjugate gradient with POLAK and RIBIÈRE factor to fit a circle to a set of points. The PDF is very explicative, so I learnt a lot about the mathematics behaind this. Now it will be a lot easier to apply this to a clothoid. The original code is a Java one, so here is translated to VBA. Will come very handy for an “alignment from points” procedure, although you will need to separate the different alignments before applying this.
Option Explicit

' Class fitting a circle to a set of points.
' This class implements the fitting algorithms described in the paper 
' Finding the circle that best fits a set of points
' @author Luc Maisonobe

' Copyright (c) 2005-2007, Luc Maisonobe
' All rights reserved.
'
' Redistribution and use in source and binary forms, with
' or without modification, are permitted provided that
' the following conditions are met:
'
'    Redistributions of source code must retain the
'    above copyright notice, this list of conditions and
'    the following disclaimer.
'    Redistributions in binary form must reproduce the
'    above copyright notice, this list of conditions and
'    the following disclaimer in the documentation
'    and/or other materials provided with the
'    distribution.
'    Neither the names of spaceroots.org, spaceroots.com
'    nor the names of their contributors may be used to
'    endorse or promote products derived from this
'    software without specific prior written permission.
'
' THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
' CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
' WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
' WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
' PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
' THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY
' DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
' CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
' PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
' USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
' HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
' IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
' NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
' USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
' POSSIBILITY OF SUCH DAMAGE.

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

Private Type tCircleFitter
    Pt() As tXYZ
    Center As tXYZ
    Radius As Double
End Type

Private fitter As tCircleFitter
Private r´ As Double       ' optimum circle radius
Private Jacb As Double
Private dJx As Double
Private dJy As Double

Private Const PI As Double = 3.14159265358979
Private Const EPSILON As Double = 0.00000001

Private Sub sCircleFitter_Main()
    On Local Error GoTo CtrlErr

    Dim iter As Long

    ' fit a circle to the test points
    Call fPointsInitialize(fitter.Pt(), 15, 100, 100, 35)

    'fitter = New CircleFitter
    Call fitterInitialize(fitter.Pt())
'Debug.Print "initial circle: " & fitter.Center.X & " " & fitter.Center.Y & " " & fitter.Radius

    ' minimize the residuals
    iter = minimize(100, 0.1, EPSILON)
'Debug.Print "converged after " & iter & " iterations"
'Debug.Print "final circle: " & fitter.Center.X & " " & fitter.Center.Y & " " & fitter.Radius

ExitProc:
    Exit Sub

CtrlErr:
    Stop
End Sub

Public 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 fPointsInitialize(ByRef oPt() As tXYZ, _
                                   ByVal lgPts As Long, _
                                   ByVal Xcenter As Double, _
                                   ByVal Ycenter As Double, _
                                   ByVal Radius As Double) As Boolean
' Initialize an approximate circle based on all triplets.
' @param lgPts number of sample points
    Dim lgPt As Long
    Dim dbAngleRAD As Double

    ReDim oPt(0 To lgPts - 1)
    VBA.Randomize
    For lgPt = 1 To lgPts
        dbAngleRAD = (Rnd() * 2 * PI)
        With oPt(lgPt - 1)
            .X = (Xcenter + Radius * Cos(dbAngleRAD)) + (CLng(IIf(Rnd() > 0.5, 1, -1)) * Rnd() * 0.01)
            .Y = (Ycenter + Radius * Sin(dbAngleRAD)) + (CLng(IIf(Rnd() > 0.5, 1, -1)) * Rnd() * 0.01)
        End With
    Next lgPt
End Function

Public Sub fitterInitialize(ByRef oPt() As tXYZ)
' Initialize an approximate circle based on all triplets.
' @param oPt() circular ring sample points
' @exception Error if all points are aligned
 
    Dim n As Long 'number of filtered points
    Dim lgPt1 As Long
    Dim lgPt2 As Long
    Dim lgPt3 As Long
    Dim cc As tXYZ
    Dim lgRetVal As Long

    With fitter
        With .Center
            .X = 0
            .Y = 0
        End With
        .Radius = 0
    End With

    ' analyze all possible points triplets
    n = 0
    For lgPt1 = LBound(oPt) To UBound(oPt) - 2
        For lgPt2 = lgPt1 + 1 To UBound(oPt) - 1
            For lgPt3 = lgPt2 + 1 To UBound(oPt)
                ' compute the triangle circumcenter
                ' Check points are not aligned
                If Not fAligned(oPt(lgPt1), oPt(lgPt2), oPt(lgPt3)) Then
                    cc = circumcenter(oPt(lgPt1), oPt(lgPt2), oPt(lgPt3))
                    ' the points are not aligned, we have a circumcenter
                    n = (n + 1)
                    fitter.Center.X = (fitter.Center.X + cc.X)
                    fitter.Center.Y = (fitter.Center.Y + cc.Y)
                End If
            Next lgPt3
        Next lgPt2
    Next lgPt1
    
    If (n = 0) Then
        lgRetVal = VBA.MsgBox("all points are aligned")
    Else
        ' initialize using the circumcenters average
        With fitter
            With .Center
                .X = .X / n
                .Y = .Y / n
            End With
            Call updateRadius(.Pt())
        End With
    End If
End Sub

Public Function fAligned(ByRef oPt1 As tXYZ, _
                         ByRef oPt2 As tXYZ, _
                         ByRef oPt3 As tXYZ) As Boolean
    fAligned = (((oPt2.X - oPt1.X) * (oPt3.Y - oPt1.Y)) - ((oPt2.Y - oPt1.Y) * (oPt3.X - oPt1.X)) < EPSILON)
End Function

Private Function updateRadius(ByRef oPt() As tXYZ) As Boolean
' Update the circle radius

    Dim lgPt As Long
    Dim dx As Double
    Dim dy As Double
    
    r´ = 0
    If Not (Not oPt) Then
        For lgPt = LBound(oPt) To UBound(oPt)
            dx = (oPt(lgPt).X - fitter.Center.X)
            dy = (oPt(lgPt).Y - fitter.Center.Y)
            r´ = (r´ + VBA.Sqr(((dx * dx) + (dy * dy))))
        Next lgPt
        
        r´ = r´ / (UBound(oPt) - LBound(oPt) + 1)
        fitter.Radius = r´
    End If
End Function

Private Function circumcenter(ByRef PI As tXYZ, ByRef pJ As tXYZ, ByRef pK As tXYZ) As tXYZ
' Compute the circumcenter of three points.
' @param pI first point
' @param pJ second point
' @param pK third point
' @return circumcenter of pI, pJ and pK or null if the points are aligned

    Dim dIJ As tXYZ
    Dim dJK As tXYZ
    Dim dKI As tXYZ
    Dim sqI As Double
    Dim sqJ As Double
    Dim sqK As Double
    Dim det As Double

    dIJ = NewPoint((pJ.X - PI.X), (pJ.Y - PI.Y))
    dJK = NewPoint((pK.X - pJ.X), (pK.Y - pJ.Y))
    dKI = NewPoint((PI.X - pK.X), (PI.Y - pK.Y))
    sqI = ((PI.X * PI.X) + (PI.Y * PI.Y))
    sqJ = ((pJ.X * pJ.X) + (pJ.Y * pJ.Y))
    sqK = ((pK.X * pK.X) + (pK.Y * pK.Y))

    ' determinant of the linear system: 0 for aligned points
    det = ((dJK.X * dIJ.Y) - (dIJ.X * dJK.Y))

    If (VBA.Abs(det) < EPSILON) Then Exit Function ' points are almost aligned, we cannot compute the circumcenter
    
    ' beware, there is a minus sign on Y coordinate!
    circumcenter = NewPoint(((sqI * dJK.Y) + ((sqJ * dKI.Y) + (sqK * dIJ.Y))) / (2 * det), _
                           -((sqI * dJK.X) + ((sqJ * dKI.X) + (sqK * dIJ.X))) / (2 * det))
End Function

Public Function minimize(ByVal iterMax As Integer, ByVal innerThreshold As Double, ByVal outerThreshold As Double) As Long
' Minimize the distance residuals between the points and the circle.
' We use a non-linear conjugate gradient method with the Polak and
' Ribiere coefficient for the computation of the search direction. The
' inner minimization along the search direction is performed using a
' few Newton steps. It is worthless to spend too much time on this inner
' minimization, so the convergence threshold can be rather large.
'
' @param maxIter maximal iterations number on the inner loop (cumulated across outer loop iterations)
' @param innerThreshold inner loop threshold, as a relative difference on the cost function value between the two last iterations
' @param outerThreshold outer loop threshold, as a relative difference on the cost function value between the two last iterations
' @return number of inner loop iterations performed (cumulated across outer loop iterations)
' @exception LocalException if we come accross a singularity or if we exceed the maximal number of iterations
    
    Dim lgRetVal As Long
    Dim u As Double
    Dim v As Double
    Dim beta As Double
    Dim lambda As Double
    Dim innerJ As Double
    Dim previousJ As Double: previousJ = Jacb
    Dim previousV As Double: previousV = 0
    Dim previousU As Double: previousU = 0
    Dim previousdJy As Double: previousdJy = 0
    Dim previousdJx As Double: previousdJx = 0
    Dim iterations As Integer: iterations = 0
  
    Call computeCost(fitter.Pt())

    If ((Jacb < EPSILON) Or (VBA.Sqr(((dJx * dJx) + (dJy * dJy))) < EPSILON)) Then
        ' we consider we are already at a local minimum
        minimize = 0
        Exit Function
    End If
    
    Do While (iterations < iterMax)
        ' search direction
        u = (dJx * -1)
        v = (dJy * -1)
        If (iterations <> 0) Then
            ' Polak-Ribiere coefficient
            beta = (((dJx * (dJx - previousdJx)) + (dJy * (dJy - previousdJy))) / ((previousdJx * previousdJx) + (previousdJy * previousdJy)))
            u = (u + (beta * previousU))
            v = (v + (beta * previousV))
        End If
        
        previousdJx = dJx
        previousdJy = dJy
        previousU = u
        previousV = v

        ' rough minimization along the search direction
        Do
            With fitter
                innerJ = Jacb
                lambda = newtonStep(.Pt(), u, v)
                .Center.X = (fitter.Center.X + (lambda * u))
                .Center.Y = (fitter.Center.Y + (lambda * v))
                Call updateRadius(.Pt())
                Call computeCost(.Pt())
            
                iterations = iterations + 1
            End With
        Loop While ((iterations < iterMax) And ((VBA.Abs((Jacb - innerJ)) / Jacb) > innerThreshold))
        
        If ((VBA.Abs((Jacb - previousJ)) / Jacb) < outerThreshold) Then
            minimize = iterations
            Exit Function
        End If
        
        previousJ = Jacb
    Loop
    
    lgRetVal = VBA.MsgBox("unable to converge after " & iterMax & " iterations")
End Function

Private Sub computeCost(ByRef oPt() As tXYZ)
' Compute the cost function and its gradient.
    Dim lgRetVal As Long
    Dim lgPt As Long
    Dim dx As Double
    Dim dy As Double
    Dim di As Double
    Dim dr As Double
    Dim ratio As Double

    Jacb = 0
    dJx = 0
    dJy = 0
    For lgPt = LBound(oPt) To UBound(oPt)
        dx = (oPt(lgPt).X - fitter.Center.X)
        dy = (oPt(lgPt).Y - fitter.Center.Y)
        di = VBA.Sqr(((dx * dx) + (dy * dy)))
        If (di < EPSILON) Then lgRetVal = VBA.MsgBox(("cost singularity: point at the circle center"))
        
        dr = (di - r´)
        ratio = (dr / di)
        Jacb = (Jacb + (dr * (di + r´)))
        dJx = (dJx + (dx * ratio))
        dJy = (dJy + (dy * ratio))
    Next lgPt
    
    dJx = (dJx * 2)
    dJy = (dJy * 2)
End Sub

Private Function newtonStep(ByRef oPt() As tXYZ, ByVal u As Double, ByVal v As Double) As Double
' Compute the length of the Newton step in the search direction.
' @param u abscissa of the search direction
' @param v ordinate of the search direction
' @return value of the step along the search direction

    Dim sumFac2R As Double
    Dim sum1 As Double
    Dim sum2 As Double
    Dim sumFac As Double
    Dim lgPt As Long
    Dim dx As Double
    Dim dy As Double
    Dim di As Double
    Dim coeff1 As Double
    Dim coeff2 As Double

    sumFac2R = 0
    sum1 = 0
    sum2 = 0
    sumFac = 0

    ' compute the first and second derivatives of the cost along the specified search direction
    For lgPt = LBound(oPt) To UBound(oPt)
        dx = (fitter.Center.X - oPt(lgPt).X)
        dy = (fitter.Center.Y - oPt(lgPt).Y)
        di = VBA.Sqr(((dx * dx) + (dy * dy)))
        coeff1 = (((dx * u) + (dy * v)) / di)
        coeff2 = (di - r´)
        sum1 = (sum1 + (coeff1 * coeff2))
        sum2 = (sum2 + (coeff2 / di))
        sumFac = (sumFac + coeff1)
        sumFac2R = (sumFac2R + (coeff1 * (coeff1 / di)))
    Next lgPt
    
    ' step length attempting to nullify the first derivative
    newtonStep = ((sum1 / (((((u * u) + (v * v)) * sum2) - (sumFac * (sumFac / (UBound(oPt) - LBound(oPt) + 1)))) + (r´ * sumFac2R))) * -1)
End Function

'Public Function getCenter(ByRef fitter As tCircleFitter) As Boolean
'    fitter.Center = oCenter: getCenter = True
'End Function

'Public Function getRadius(ByRef fitter As tCircleFitter) As Boolean
'    fitter.Radius = r´: getRadius = True
'End Function