VBA DLL explorer

If you want to use DLL from VBA, you’ll need to know which functions are exported on that DLL so that they can be called from within VBA. There is that nirsoft dllExplorer app, but, could that be done with pure VBA code?. For sure, just paste code in normal module, and run listExportedFuncs to get list (in code it’ll show on msgBox -where you can Ctrl+C to copy to clipboard-, or uncomment lines “‘!” to get in file):

' https://renenyffenegger.ch/notes/development/languages/VBA/Win-API/examples/DbgHelp/ListExportedFuncsOfDll
' http://www.tech-archive.net/Archive/VB/microsoft.public.vb.general.discussion/2007-09/msg00228.html
'
Option Explicit

Private Declare Sub MoveMemoryLong Lib "kernel32" Alias "RtlMoveMemory" (Target As Any, ByVal LPointer As Long, ByVal cbCopy As Long)

Private Const IMAGE_NUMBEROF_DIRECTORY_ENTRIES = 16
Private Const IMAGE_DIRECTORY_ENTRY_EXPORT = 0
Private Const IMAGE_DIRECTORY_ENTRY_IMPORT = 1

Declare Function MapAndLoad Lib "Imagehlp.dll" (ByVal ImageName As String, ByVal DLLPath As String, LoadedImage As LOADED_IMAGE, DotDLL As Long, ReadOnly As Long) As Long
Declare Function UnMapAndLoad Lib "Imagehlp.dll" (LoadedImage As LOADED_IMAGE) As Long
Declare Function ImageRvaToVa Lib "Imagehlp.dll" (ByVal NTHeaders As Long, ByVal Base As Long, ByVal RVA As Long, ByVal LastRvaSection As Long) As Long

Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpsz As Long) As Long

#If VBA7 Then
Declare Sub PrtSafe RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef source As Any, ByVal size As longPtr)
Declare Sub PrtSafe RtlZeroMemory Lib "kernel32" (dest As Any, ByVal length As Long)
#Else
Declare Sub RtlMoveMemory Lib "kernel32" (ByRef dest As Any, ByRef source As Any, ByVal size As Long)
Declare Sub RtlZeroMemory Lib "kernel32" (dest As Any, ByVal length As Long)
#End If

Type LIST_ENTRY ' { Used by LOADED_IMAGE
FLink As Long
Blink As Long
End Type ' }

Type IMAGE_EXPORT_DIRECTORY_TABLE ' WinNT.h {
Characteristics As Long
TimeDateStamp As Long
MajorVersion As Integer
MinorVersion As Integer
Name As Long
Base As Long
NumberOfFunctions As Long
NumberOfNames As Long
AddressOfFunctions As Long ' Relative virtual address (RVA) from base of image. Points to an array of RVAs of functions/symbols in the module
AddressOfNames As Long ' Relative virtual address (RVA) from base of image
AddressOfNameOrdinals As Long ' Relative virtual address (RVA) from base of image
End Type ' }

Private Type IMAGE_DATA_DIRECTORY ' WinNT.h {
RVA As Long ' Relative VA
size As Long
End Type ' }

Type IMAGE_OPTIONAL_HEADER32 ' WinNT.h {
' Standard fields:
Magic As Integer
MajorLinkerVersion As Byte
MinorLinkerVersion As Byte
SizeOfCode As Long
SizeOfInitializedData As Long
SizeOfUninitializedData As Long
AddressOfEntryPoint As Long
BaseOfCode As Long
BaseOfData As Long

' NT additional fields:
ImageBase As Long
SectionAlignment As Long
FileAlignment As Long
MajorOperatingSystemVersion As Integer
MinorOperatingSystemVersion As Integer
MajorImageVersion As Integer
MinorImageVersion As Integer
MajorSubsystemVersion As Integer
MinorSubsystemVersion As Integer
Win32VersionValue As Long
SizeOfImage As Long
SizeOfHeaders As Long
CheckSum As Long
Subsystem As Integer
DllCharacteristics As Integer
SizeOfStackReserve As Long
SizeOfStackCommit As Long
SizeOfHeapReserve As Long
SizeOfHeapCommit As Long
LoaderFlags As Long
NumberOfRvaAndSizes As Long
' Data directories
DataDirectory(0 To IMAGE_NUMBEROF_DIRECTORY_ENTRIES) As IMAGE_DATA_DIRECTORY ' 17*8 + 96 = 232
End Type ' }

Type IMAGE_FILE_HEADER ' { WinNT.h / COFF file header
Machine As Integer
NumberOfSections As Integer
TimeDateStamp As Long
PointerToSymbolTable As Long
NumberOfSymbols As Long
SizeOfOptionalHeader As Integer
Characteristics As Integer
End Type ' }

Type IMAGE_NT_HEADERS32 ' WinNT.h {
' Compare with IMAGE_NT_HEADERS64, also defined in WinNT.h
'
Signature As Long
FileHeader As IMAGE_FILE_HEADER
OptionalHeader As IMAGE_OPTIONAL_HEADER32 ' or IMAGE_OPTIONAL_HEADER64
End Type ' }
'
' LOADED_IMAGE
' Is defined in both ImageHlp.h and DbgHelp.h
'
Type LOADED_IMAGE ' 48 bytes (46 bytes packed ) ' { Used with MapAndLoad
ModuleName As Long
hFile As Long
MappedAddress As Long ' Base address of mapped file
FileHeader As Long ' Pointer to IMAGE_NT_HEADERS32 ' (Compare with IMAGE_NT_HEADERS64) -- Note: the pointed to IMAGE_NT_HEADERS32 also has a member named FileHeader.
LastRvaSection As Long ' Pointer to first COFF section header (section table)?
NumberOfSections As Long
Sections As Long ' Pointer to IMAGE_SECTION_HEADER (First COFF section header (section table)??)
Characteristics As Long ' Image characteristics value
fSystemImage As Byte ' bool
fDOSImage As Byte ' bool
'
' At least in C, the compiler pads the following two (new) members
' with the previous two bytes into 4 byte so that in C, adding
' or omitting them should not change anything.
'
' fReadOnly as byte ' bool
' Version as byte ' UCHAR
'
' ----------------------------------------------------------
Links As LIST_ENTRY ' 2 longs
SizeOfImage As Long
End Type ' }

Function GetOpenFileName(Optional FileFilter As String = "All files", _
Optional FileExtension As String = "*.*", _
Optional Title As String = "Select a file", _
Optional InitialPath As String = "MyDocs") As String
Dim fDialog As FileDialog, result As Integer
Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

'Optional: FileDialog properties
fDialog.AllowMultiSelect = False
fDialog.Title = "Select a file"
If InitialPath = "MyDocs" Then
fDialog.InitialFileName = VBA.Environ$("UserProfile") & "Documents\"
ElseIf InitialPath = "Downloads" Then
fDialog.InitialFileName = VBA.Environ$("UserProfile") & "Downloads\"
Else
fDialog.InitialFileName = VBA.Environ$("SystemDrive") & "Downloads\"
End If
'Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "DLL files", "*.dll"
If Not FileExtension = "*.*" Then fDialog.Filters.Add "All files", "*.*"

'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
GetOpenFileName = fDialog.SelectedItems(1)
End If
End Function

Sub listExportedFuncs()
Dim img As LOADED_IMAGE
Dim peHeader As IMAGE_NT_HEADERS32
Dim expTable As IMAGE_EXPORT_DIRECTORY_TABLE
Dim strFunctions As String
Dim DLLPath As String

DLLPath = GetOpenFileName 'Application.GetOpenFileName(FileFilter:="DLL files (*.dll), *.dll", Title:="Select DLL file to open", MultiSelect:=True)

If MapAndLoad(DLLPath, DLLPath, img, True, True) = 0 Then
Debug.Print "Could not map " & DLLPath
Exit Sub
End If

On Error GoTo err_

Dim fOut As Integer: fOut = FreeFile
'! Open Environ$("TEMP") & "\exportedFuncs.txt" For Output As #fOut

' Copy PE file header:
RtlMoveMemory ByVal VarPtr(peHeader), ByVal img.FileHeader, LenB(peHeader)

' Get export table offset as relative virtual address (RVAs)
Dim expRVA As Long
expRVA = peHeader.OptionalHeader.DataDirectory(IMAGE_DIRECTORY_ENTRY_EXPORT).RVA

If expRVA = 0 Then
Call UnMapAndLoad(img)
End If

' Convert RVA to VA:
Dim expVA As Long
expVA = ImageRvaToVa(img.FileHeader, img.MappedAddress, expRVA, 0&)

RtlMoveMemory ByVal VarPtr(expTable), ByVal expVA, LenB(expTable)

Dim nofExports As Long
nofExports = expTable.NumberOfNames

Dim ptrToArrayOfExportedFuncNames As Long
Dim ptrToArrayOfExportedFuncAddresses As Long

ptrToArrayOfExportedFuncNames = ImageRvaToVa(img.FileHeader, img.MappedAddress, expTable.AddressOfNames, 0&)
ptrToArrayOfExportedFuncAddresses = ImageRvaToVa(img.FileHeader, img.MappedAddress, expTable.AddressOfFunctions, 0&)

Dim i As Long
For i = 0 To nofExports - 1
Dim RVAfuncName As Long
Dim RVAfuncAddress As Long

MoveMemoryLong RVAfuncName, ptrToArrayOfExportedFuncNames, 4
MoveMemoryLong RVAfuncAddress, ptrToArrayOfExportedFuncAddresses, 4

Dim VAfuncName As Long
Dim VAfuncAddress As Long

VAfuncName = ImageRvaToVa(img.FileHeader, img.MappedAddress, RVAfuncName, 0&)
VAfuncAddress = ImageRvaToVa(img.FileHeader, img.MappedAddress, RVAfuncAddress, 0&)

'! Print #fOut, VAfuncAddress & ": " & LPSTRtoBSTR(VAfuncName)
strFunctions = strFunctions & vbNewLine & VAfuncAddress & ": " & LPSTRtoBSTR(VAfuncName)

ptrToArrayOfExportedFuncNames = ptrToArrayOfExportedFuncNames + 4
ptrToArrayOfExportedFuncAddresses = ptrToArrayOfExportedFuncAddresses + 4
Next i

Call UnMapAndLoad(img)

'! Close #fOut
MsgBox strFunctions
Exit Sub

err_:
Call UnMapAndLoad(img)
Debug.Print "Error occured: " & Err.Description
End Sub

Private Function LPSTRtoBSTR(ByVal lpString As Long) As String
Dim lenS As Long
Dim ptrToZero As Long

lenS = lstrlen(lpString)

LPSTRtoBSTR = String$(lenS, 0)
RtlMoveMemory ByVal StrPtr(LPSTRtoBSTR), ByVal lpString, lenS

LPSTRtoBSTR = StrConv(LPSTRtoBSTR, vbUnicode)

ptrToZero = InStr(1, LPSTRtoBSTR, Chr(0), 0)

If ptrToZero > 0 Then
LPSTRtoBSTR = Left$(LPSTRtoBSTR, ptrToZero - 1)
End If
End Function


Nearly all the code came from Rene Nyffeneger’s outstanding site

Excel as teleprompter/autocue

This week I was on the need to record a short video that should not look as me reading it on a screen.
In my innocence, I thought it would be as easy as preparing some content and then declaming it with confidence. Well, it took me some time to get the thing done without ever appearing stuck on the next sentence.
Do not fail where I did!. Having excruciated in my flesh that I do not have the gift of public speaking, I have decided to find a solution for the next occasion. In the non-amateur world this is solved with a teleprompter / autocue… although I was not in the business of buying one for the occasion or getting into the DIY world.
The online webapps didn’t seem very helpful in first run. And even if you can also get it done with a mobile application, tests were not good: still looks as you staring not to the camera, apps are full of ads… and I have been scared by the size of the videos recorded with the phone.
My best alternative lies on using the laptop’s webcam. There are some apps/browser extensions that can reach it. Placing the text to be displayed just below the point of the lens will get it done.
With the following code you can get a “very basic” Excel based teleprompter.
Sub AutoCueV1()
Dim dtScreencastNext As Date
dtScreencastNext = VBA.Now() + VBA.TimeSerial(0, 0, 1)
Do
If VBA.Now() > dtScreencastNext Then
ActiveWindow.SmallScroll Down:=1
dtScreencastNext = VBA.Now() + VBA.TimeSerial(0, 0, 1)
End If
DoEvents
Loop
End Sub

The scrolling of the screen is jerky, and as we still have to solve the mirror issue it’s only usable as a poor man teleprompter, but with no use of glass, and no black shelling of light… just need a webcam and pour some text on Excel.

To mimic the mirror effect and get a nice scrolling behaviour, we can use shapes that scroll over the screen. In order to do so, insert a shape, and to fill it with the text of a cell into the shape, type =[cellAddress] in the formula bar and press Enter. Take care, you are only allowed to point to one cell address, and do not make use of any formulas or chars, if needed apply inside the cell formula.
I have named this shape as “oShp”, and will be replicated to handle the rest of the text lines. Tune the format of this shape until you get the desired looking, but the better is black background, and text in white-grey color.
To mirror the content, select the Drawing-Format tab, click ‘Text Effects’, move down to ‘3-D rotation’ options (at the bottom of the menu), and set 180° in the X axis for a horizontal rotation (as if the mirror is to the right or left) and in the Y axis for a vertical rotation (as if the mirror is above or below).
In order to start/stop control, use another shape to trigger all, with  .onAction property set to sPrompterControlprocedure

Public bRun As Boolean
Public Sub sPrompterControl()
bRun = Not bRun
If bRun Then Call AutoCueV2
End Sub
Private Sub AutoCueV2()
Dim bMirror As Boolean: bMirror = True
Dim NumberOfTextLines As Long: NumberOfTextLines = 10
Dim VerticalSpeed As Single: VerticalSpeed = 10
Dim TimeStep As Single: TimeStep = 0.005
Dim xInc As Single, yInc As Single
'---------------------------------------------------------
Dim TextRow As Long
Dim oShp As Excel.Shape
Dim oShp2 As Excel.Shape
Dim oShpRng As Excel.ShapeRange
Dim i As Long

Set oShp = ActiveSheet.Shapes.Item("oShp")
With oShp
'.Formula = "=$A$" & ...
.Placement = xlFreeFloating
.Locked = msoFalse

.Select
Selection.ShapeRange.TextFrame2.ThreeD.RotationX = VBA.IIf(bMirror, -180, 0)
Selection.PrintObject = msoFalse
End With

' Duplicate shapes...
TextRow = 0
For i = 1 To NumberOfTextLines
With oShp
Set oShp2 = .Duplicate
oShp2.Left = .Left
oShp2.Top = oShp.Top + (oShp.Height * i)
End With
With oShp2
TextRow = TextRow + 1
.Name = "oShp_Tmp_" & VBA.Format(i, "00")
.DrawingObject.Formula = "=$A$" & TextRow
End With
Next i

' Scroll text
Dim dtScreencastNext As Date
yInc = oShp.Height / 100 'VerticalSpeed / 10000
Do
'Do While Timer < Start + TimeStep: DoEvents: Loop
For i = 1 To NumberOfTextLines
Set oShp2 = ActiveSheet.Shapes.Item("oShp_Tmp_" & VBA.Format(i, "00"))
With oShp2
If .Top + -yInc < 0 Then
.Top = .Height * NumberOfTextLines
TextRow = TextRow + 1
.DrawingObject.Formula = "=$A$" & TextRow
End If

'.IncrementLeft xInc
.IncrementTop -yInc
'.Top = .Top - VerticalSpeed / 10000
Start = Timer
End With
Next i
DoEvents
Loop While bRun

' Delete shapes, clean worksheet
For i = ActiveSheet.Shapes.Count To 1 Step -1
If ActiveSheet.Shapes.Item(i).Name Like "oShp_Tmp_#*" Then
ActiveSheet.Shapes.Item(i).Delete
End If
Next i
End Sub

You can set NumberOfTextLines, TimeStep  and VerticalSpeed to fit your needings, and can use with the mirrowed effect or not via bMirror variable.

In both cases (the first or the second version), there is one more thing that shoud be done, that is to get everything the closer to the webcam lens as possible. To achieve this you’ll need to collapse the ribbon and the formula bar, but if you do not want to mess this “kiosk mode” with your Excel Windows, better open a new instance of Excel to run this teleprompter thing. Use following code, that can be also triggered via Workbook_Openand with Workbook_BeforeClose:

Private Sub AutoCue()
Dim oXlApp As Excel.Application
Dim oXlWbk As Excel.Workbook
Dim fDialog As FileDialog, result As Integer
Dim filePath As String
Dim fileName As String

Set fDialog = Application.FileDialog(msoFileDialogFilePicker)

' Optional: FileDialog properties
fDialog.AllowMultiSelect = False
fDialog.Title = "Select autocue file"
fDialog.InitialFileName = VBA.Environ$("HomeDrive") & "\"

' Optional: Add filters
fDialog.Filters.Clear
fDialog.Filters.Add "Excel macro files", "*.xlsm"
'fDialog.Filters.Add "All files", "*.*"

'Show the dialog. -1 means success!
If fDialog.Show = -1 Then
filePath = fDialog.SelectedItems(1)
fileName = Right(filePath, VBA.Len(filePath) - VBA.InStrRev(filePath, "\"))
Set oXlApp = Excel.Application
Set oXlWbk = oXlApp.Workbooks.Open(filePath)
oXlApp.Visible = True
AppActivate fileName ' Brings it to Front & gives it the Focus
If oXlApp.Workbooks.Count = 1 Then
oXlApp.Quit
Else
oXlWbk.Close False
Set oXlApp = Nothing
Set oXlWbk = Nothing
End If
End If
End Sub

'Private Sub Workbook_Open()
' Call UIHide
'End Sub
'Private Sub Workbook_Activate()
' Call UIHide
'End Sub
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
' Call UIRestore
'End Sub
'Private Sub Workbook_Deactivate()
' Call UIRestore
'End Sub

Public Sub UIHide()
' code to hide UI to get kiosk mode:
With Application
OldScreenUpdating = .ScreenUpdating
OldCalculation = .Calculation
OldWindowState = .WindowState

.ScreenUpdating = False
.Calculation = xlCalculationManual
.WindowState = xlNormal

OldRibbonShow = (Application.CommandBars("Ribbon").Height > 100)
.ExecuteExcel4Macro "Show.Toolbar(""Ribbon"",False)"

OldFullScreen = .CommandBars("Full Screen").Visible
OldMenuBar = .CommandBars("Worksheet Menu Bar").Enabled
.CommandBars("Full Screen").Visible = False
.CommandBars("Worksheet Menu Bar").Enabled = False

OldDisplayStatusBar = .DisplayStatusBar
OldDisplayScrollBars = .DisplayScrollBars
OldDisplayFormulaBar = .DisplayFormulaBar
.DisplayStatusBar = False
.DisplayScrollBars = False
.DisplayFormulaBar = False

OldWidth = .Width
OldHeight = .Height
.Width = 800
.Height = 450

OldTop = .Top
OldLeft = .Left
.Top = -100
.Left = 0
End With

With ActiveWindow
OldDisplayWorkbookTabs = .DisplayWorkbookTabs
OldDisplayHeadings = .DisplayHeadings
OldDisplayRuler = .DisplayRuler
OldDisplayFormulas = .DisplayFormulas
OldDisplayGridlines = .DisplayGridlines
OldDisplayHorizontalScrollBar = .DisplayHorizontalScrollBar
OldDisplayVerticalScrollBar = .DisplayVerticalScrollBar

' .DisplayWorkbookTabs = False
.DisplayHeadings = False
' .DisplayRuler = False
' .DisplayFormulas = False
' .DisplayGridlines = False
' .DisplayHorizontalScrollBar = False
' .DisplayVerticalScrollBar = True
End With
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Public Sub UIRestore()
' code to reset everything back displayed:
With Application
.ExecuteExcel4Macro "Show.Toolbar(""Ribbon""," & VBA.IIf(OldRibbonShow, "True", "False") & ")"
.CommandBars("Full Screen").Visible = OldFullScreen
.CommandBars("Worksheet Menu Bar").Enabled = OldMenuBar
.DisplayStatusBar = OldDisplayStatusBar
.DisplayScrollBars = OldDisplayScrollBars
.DisplayFormulaBar = OldDisplayFormulaBar
.Top = OldTop
.Left = OldLeft
.Width = OldWidth
.Height = OldHeight
End With

With ActiveWindow
' .DisplayWorkbookTabs = OldDisplayWorkbookTabs
.DisplayHeadings = OldDisplayHeadings
' .DisplayRuler = OldDisplayRuler
' .DisplayFormulas = OldDisplayFormulas
' .DisplayGridlines = OldDisplayGridlines
' .DisplayHorizontalScrollBar = OldDisplayHorizontalScrollBar
' .DisplayVerticalScrollBar = OldDisplayVerticalScrollBar
End With

With Application
.ScreenUpdating = OldScreenUpdating
.Calculation = OldCalculation
.WindowState = OldWindowState
End With
End Subb


You can set the top window position to be negative, so you can also have the UserForm title bar out of sight. OnStore previous values of window configuration to restore from variables:
Private OldScreenUpdating As Boolean
Private OldCalculation As Long
Private OldWindowState As Long
Private OldRibbonShow As Boolean
Private OldFullScreen As Boolean
Private OldMenuBar As Boolean
Private OldDisplayStatusBar As Boolean
Private OldDisplayScrollBars As Boolean
Private OldDisplayFormulaBar As Boolean
Private OldWidth As Single
Private OldHeight As Single
Private OldTop As Single
Private OldLeft As Single
Private OldDisplayWorkbookTabs As Boolean
Private OldDisplayHeadings As Boolean
Private OldDisplayRuler As Boolean
Private OldDisplayFormulas As Boolean
Private OldDisplayGridlines As Boolean
Private OldDisplayHorizontalScrollBar As Boolean
Private OldDisplayVerticalScrollBar As Boolean

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: