Conditional Formatting to Border Overflow Text - excel

Like my title says, I need a formula for conditional formatting that will apply my specified border on cells that contain overflow text. Is this possible?
I have a formula that applies a border to cells that contain text, and it works great, but the border won't extend to a cell that has overflow text in it.
Thanks

Option 1: The simple solution
Using Gordon's idea, if you use a mono-spaced font (like Courrier New for instance), you could count the number of characters it takes to overflow the cell and use the number of characters in the cells (via the LEN function) to create your conditional formatting.
For example, if you are using Courrier New with size 11 and regular column width (8.43, 64 pixels), you could fit 6 characters before the cell overflows.
So the conditional formatting formula would look like this:
=LEN(B2)>6
Option 2 : The more sophisticated solution
You could create a VBA function that determines the pixel width of the text in the cell using the method provided in this answer and then compare it with the column width in pixels. Then return TRUE if TextWidth > ColumnWidth.
Public Function DetectOverflowTextWidth(c As Range) As Boolean
'Get column size in pixels
Dim ColumnWidth As Long
ColumnWidth = (c.EntireColumn.Width / 72) * c.Parent.Parent.WebOptions.PixelsPerInch
'Get Text size in pixels
Dim TextWidth As Long
TextWidth = GetStringPixelWidth(c.Value2, c.font.Name, c.font.Size, c.font.Bold, c.font.Italic)
If ColumnWidth < TextWidth Then DetectOverflowTextWidth = True
End Function
And to have the pixel width of the text you'd have to include this in a (seperate) module:
Option Explicit
'API Declares
#If VBA7 Then
Declare PtrSafe Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Declare PtrSafe Function CreateFontIndirect Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As LongPtr
Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As LongPtr, ByVal lpsz As String, ByVal cbString As Long, lpSize As FNTSIZE) As Long
Declare PtrSafe Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hdc As LongPtr) As Long
#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 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 FNTSIZE) 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
#End If
Private Const LOGPIXELSY As Long = 90
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type FNTSIZE
cx As Long
cy As Long
End Type
Private Sub test()
MsgBox (GetStringPixelWidth("Test String", "Calibri", 10))
MsgBox (GetStringPixelWidth(" ", "Calibri", 10, True, False))
End Sub
Public Function GetStringPixelHeight(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer
Dim font As New StdFont
Dim sz As FNTSIZE
font.Name = fontName
font.Size = fontSize
font.Bold = isBold
font.Italic = isItalics
sz = GetLabelSize(text, font)
GetStringPixelHeight = sz.cy
End Function
Public Function GetStringPixelWidth(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer
Dim font As New StdFont
Dim sz As FNTSIZE
font.Name = fontName
font.Size = fontSize
font.Bold = isBold
font.Italic = isItalics
sz = GetLabelSize(text, font)
GetStringPixelWidth = sz.cx
End Function
Private Function GetLabelSize(text As String, font As StdFont) As FNTSIZE
#If VBA7 Then
Dim tempDC As LongPtr
Dim tempBMP As LongPtr
Dim f As LongPtr
#Else
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
#End If
Dim lf As LOGFONT
Dim textSize As FNTSIZE
On Error GoTo CleanUp
' Create a device context and a bitmap that can be used to store a
' temporary font object
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font
lf.lfFaceName = font.Name & chr$(0)
lf.lfHeight = -MulDiv(font.Size, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure
GetTextExtentPoint32 tempDC, text, Len(text), textSize
CleanUp:
' Clean up (very important to avoid memory leaks!)
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
' Return the measurements
GetLabelSize = textSize
End Function
Finally, you'd use DetectOverflowTextWidth inside your custom conditional formatting formula to determine if the conditional formatting is applied.
Disclaimer: Option 2 is using certain Windows API functions and this could lead to memory leaks if not handled properly. I've added some error handling to the original answer to reduce the risks of it being a problem, but it's still something to keep in mind.

Related

How to fix a VBA "type mismatch" error after switching to 64-bit Excel

I was using code that was working fine when I was running the 32-bit version of Excel. After I was switched to the 64-Bit version, the macro broke. I updated the dll calls to use LongPtr everywhere instead of Long.
Is there any way to determine which arguments and return types need to be changed for VBA7, and which don't, for a specific Declare Function?
Here is an example of some of the "Declare Functions" that I have updated (there were actually several more too).
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As LongPtr, ByVal nHeight As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As LongPtr
Private Const LOGPIXELSY As Long = 90
#Else
Private Declare 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 Const LOGPIXELSY As Long = 90
#End If
This code was adapted from an answer to this question:
vb macro string width
Relevant snippet is copied here below:
Private Function GetLabelSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
I get a runtime error that just says "Compile Error: Type Mismatch." The function call to CreateDC is highlighted, and the debugger breaks on the function GetLabelSize. I have no idea which variable is now causing the error. I'm also assuming that once I fix this first error, I'll have other errors too.
Do I need to pass the value of that last argument (ByVal 0) as an explicitly typed variable? If so how?
I updated the dll calls to use LongPtr everywhere instead of Long.
You should have not done that.
By adding PtrSafe to a function declaration, you promise to the compiler that you have put LongPtr in all places where it needs to be, and nowhere else.
LongPtr is a pointer-sized integer. It must be used for things that have the same size as a pointer.
To learn which Windows API types should be described as LongPtr, you must look at the original function signature, consult https://learn.microsoft.com/en-us/windows/win32/winprog/windows-data-types, track the used data types through all the typedefs down to the basic types, and use LongPtr for those that are pointers to things.
For the functions that you have shown, that would be
#If VBA7 Then
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
#Else
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, ByVal 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 DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
#End If
When you declare variables to hold your LongPtr results, you need to use #If VBA7 too:
#If VBA7 Then
Dim tempDC As LongPtr
Dim tempBMP As LongPtr
#Else
Dim tempDC As Long
Dim tempBMP As Long
#End If
If you don't have to support Office 2007 and older, you can ditch the #If VBA7s and only use the LongPtr branch.

How to get the border sizes of a userform?

I have a userform (userform1) with several controls. One control is a command button which will open a second userform (userform2).
I want that userform2 opens immediately bellow the button and centered with it.
To have the same behavior regardless the system/themes definitions for Windows, I need to know the sizes of the borders of userform1.
After digging during 3 days, I used API functions GetWindowRect and GetWindowClient. With these two API routines, I can find the TOTAL sizes of the horizontal borders (upper plus lower) and of the vertical borders (left plus right), but not them individually.
For vertical borders, it is common sense that they will have the same thickness (width) — in fact, I’ve never seen a window with different left and right borders. So, the solution is to divide by 2 the total size. However, for horizontal borders this cannot be used, since the upper border is usually thicker that the lower.
Eventually, I found a workaround for the problem, but it cannot be applied always. That is, if there is a frame control inside userform1, then the API function GetWindowRect can be used to find the “absolute” coordinates of the frame, i.e., referred to the screen, not to userform1. Then, the upper border size is given by: frame.top_Absolute – (Userform1.top_Absolute - frame.top_RelativeToUserform1).
The problem of this approach is, userforms have not frame controls always. On the other hand, not all controls have a “rectangle” property; therefore, GetWindowRect cannot be used for all controls.
Question: is there a “direct” way to find the size of the borders of a userform?
Code
In an ordinary module:
Option Explicit
'API Declarations
#If VBA7 Then
Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#Else
Declare Function GetSystemMetrics Lib "user32" (ByVal Index As Long) As Long
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
#End If
Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type BorderSize
TopHeight As Long
LeftWidth As Long
BottomHeight As Long
RightWidth As Long
End Type
Public FormBorders As BorderSize
'To determine the sizes of the borders
Public Sub GetFormBorders(ByVal FormHandler As Long, ByVal FrameHandler As Long)
Dim rectForm As udtRECT
Dim rectFrame As udtRECT
Dim rectClientForm As udtRECT
Dim Trash As Long
Trash = GetWindowRect(FormHandler, rectForm)
Trash = GetWindowRect(FrameHandler, rectFrame)
Trash = GetClientRect(FormHandler, rectClientForm)
FormBorders.TopHeight = ConvertPixelsToPoints(rectFrame.Top - rectForm.Top, "Y") - frmFlyschGSI.fraRockProp.Top 'userform1.frame.top
FormBorders.LeftWidth = ConvertPixelsToPoints(rectFrame.Left - rectForm.Left, "X") - frmFlyschGSI.fraRockProp.Left
FormBorders.BottomHeight = ConvertPixelsToPoints(rectForm.Bottom - rectForm.Top, "Y") - FormBorders.TopHeight - _
ConvertPixelsToPoints(rectClientForm.Bottom - rectClientForm.Top, "Y")
FormBorders.RightWidth = ConvertPixelsToPoints(rectForm.Right - rectForm.Left, "X") - FormBorders.LeftWidth - _
ConvertPixelsToPoints(rectClientForm.Right - rectClientForm.Left, "X")
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
End Sub
'To convert pixels to points
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
Dim hDC As Long
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
End Function
'In the Userform code sheet:
Option Explicit
Private Sub UserForm_Initialize()
'Some code here
If Me.Visible = False Then
Call GetFormBorders(FindWindow(vbNullString, frmFlyschGSI.Caption), frmFlyschGSI.fraRockProp.[_GethWnd])
End If
'More code here
End Sub
Private Sub cmdMiHarder_Click()
Dim FrameBorder As udtRECT
Dim Trash As Long
Dim sngTopBorder As Single
Dim sngLeftBorder As Single
'Some code here
Trash = GetWindowRect(Me.fraRockProp.[_GethWnd], FrameBorder)
sngTopBorder = ConvertPixelsToPoints(FrameBorder.Top, "Y") - (Me.Top + Me.fraRockProp.Top)
sngLeftBorder = ConvertPixelsToPoints(FrameBorder.Left, "X") - (Me.Left + Me.fraRockProp.Left)
'More code here
End Sub
Logic:
Show Userform1 as modeless. This is required so that Userform2 can be shown as modeless
Show Userform2 as modeless. This is required so that Userform2 can be moved
Move Userform2 to the relevant position
New Position Calculations:
Can be much better explained with the below image
In a Module:
Option Explicit
Sub Sample()
UserForm1.Show vbModeless
End Sub
In Userform1 code area:
Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function ClientToScreen Lib "user32" _
(ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetDeviceCaps Lib "Gdi32" _
(ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" _
(ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function SetWindowPos Lib "user32" ( _
ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
ByVal cy As Long, ByVal wFlags As Long) As Long
Private Const LOGPIXELSX = 88
Private Const LOGPIXELSY = 90
Private Type POINTAPI
x As Long
y As Long
End Type
Private Const HWND_TOP = 0
Private Const SWP_NOSIZE = &H1
Private Sub CommandButton1_Click()
RepositionForm UserForm2, CommandButton1
End Sub
Public Sub RepositionForm(f As Object, c As Object)
Dim P As POINTAPI
Dim meHwnd As Long, hwnd As Long
meHwnd = FindWindow(vbNullString, Me.Caption)
P.x = (c.Left - (f.Width / 4)) / PointsPerPixelX
P.y = (c.Top + c.Height) / PointsPerPixelY
'~~> The ClientToScreen function converts the client coordinates
'~~> of a specified point to screen coordinates.
ClientToScreen meHwnd, P
UserForm2.Show vbModeless
'~~> Get Handle of Userform2
hwnd = FindWindow("ThunderDFrame", "UserForm2")
'~~> Move the form to relevant location
SetWindowPos hwnd, HWND_TOP, P.x, P.y, 0, 0, SWP_NOSIZE
End Sub
Private Function PointsPerPixelX() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelX = 72 / GetDeviceCaps(hDC, LOGPIXELSX)
ReleaseDC 0, hDC
End Function
Public Function PointsPerPixelY() As Double
Dim hDC As Long
hDC = GetDC(0)
PointsPerPixelY = 72 / GetDeviceCaps(hDC, LOGPIXELSY)
ReleaseDC 0, hDC
End Function
Screenshot
I can answer to my own question now after reading Siddharth Rout’s code. The key is to use the ClientToScreen API function to find the “screen” coordinates of the upper left corner of the client window (of the userform).
I am leaving here the code, in case someone needs to know the border sizes of a userform.
In a ordinary module:
Option Explicit
'
'API Declarations
'
#If VBA7 Then
Declare PtrSafe Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#Else
Declare Function GetDC Lib "user32" (ByVal hWnD As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnD As Long, ByVal hDC As Long) As Long
Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal Index As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function GetClientRect Lib "user32" (ByVal hWnD As Long, ByRef lpRect As udtRECT) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function ClientToScreen Lib "user32" (ByVal hWnD As Long, ByRef lpPoint As PointAPI) As Long
#End If
'
Public Type udtRECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'
Public Type PointAPI
x As Long
y As Long
End Type
'
Public Type BorderSize
TopHeight As Single
LeftWidth As Single
BottomHeight As Single
RightWidth As Single
End Type
'
' To determine the sizes of the borders
'
Public Function FormBorders(ByVal FormHandler As Long) As BorderSize
'
' Credits to Siddharth Rout for the usage of ClientToScreen API function in this context.
'
Dim rectWindow As udtRECT
Dim rectClient As udtRECT
Dim P As PointAPI
Dim VerBorders As Single
Dim HorBorders As Single
Dim Trash As Long
'
Trash = GetWindowRect(FormHandler, rectWindow)
Trash = GetClientRect(FormHandler, rectClient)
'
' Sets the upper left corner of the "client" window...
P.x = 0
P.y = 0
Trash = ClientToScreen(FormHandler, P) '...and gets its screen coordinates.
'
' Total dimensions of the borders in points, after converting pixels to points:
VerBorders = ConvertPixelsToPoints((rectWindow.Right - rectWindow.Left) - (rectClient.Right - rectClient.Left), "X")
HorBorders = ConvertPixelsToPoints((rectWindow.Bottom - rectWindow.Top) - (rectClient.Bottom - rectClient.Top), "Y")
'
' Now the individual borders, one by one, in points:
FormBorders.TopHeight = ConvertPixelsToPoints(P.y - rectWindow.Top, "Y")
FormBorders.BottomHeight = HorBorders - FormBorders.TopHeight
FormBorders.LeftWidth = ConvertPixelsToPoints(P.x - rectWindow.Left, "X")
FormBorders.RightWidth = VerBorders - FormBorders.LeftWidth
'
Debug.Print FormBorders.TopHeight, FormBorders.LeftWidth, FormBorders.BottomHeight, FormBorders.RightWidth
'
End Function
'
'To convert pixels to points
'
Public Function ConvertPixelsToPoints(ByVal sngPixels As Single, ByVal sXorY As String) As Single
'
'Credits to: https://bettersolutions.com/vba/userforms/positioning.htm
'
Dim hDC As Long
'
hDC = GetDC(0)
If sXorY = "X" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 88))
End If
'
If sXorY = "Y" Then
ConvertPixelsToPoints = sngPixels * (72 / GetDeviceCaps(hDC, 90))
End If
Call ReleaseDC(0, hDC)
'
End Function
In the code sheet of the userform:
Option Explicit
Private Sub UserForm_Initialize()
'
Dim MeBorders As BorderSize
MeBorders = FormBorders(FindWindow(vbNullString, Me.Caption))
Debug.Print MeBorders.TopHeight, MeBorders.LeftWidth, MeBorders.BottomHeight, MeBorders.RightWidth
End Sub

Looking To Get The Colour Of A Picture In Excel

I have a requirement where I need to get the colour of a picture in one of the cells.
Ideally I would like to do this via a piece of VBA Code, but I would be happy enough with a formula if one exists.
Please see attached screenshot.
In this scenario, I would like one of the following options
Replace Each of the Black Box Pictures with False and Replace the White Box Pictures with True
Have a formula that I could type into Column D which would describe the colour of the Picture.
Any help greatly appreciated.
Thanks,
Mark
Screenshot Of Example
This is a beast since we have to hit up a bunch of windows libraries to get the absolute position of the top-left of a cell, grab the pixel, figure out the color, and dump that back into the workbook.
I just did an "Assign Macro" to a picture in Cell D2 so when I click on it, this will stick that same color in Cell A1. You can monkey around with it to get it to do what you need, but all the necessary junk is here to do it.
#If VBA7 Then
Private Declare PtrSafe Function GetPixel Lib "gdi32" (ByVal hDC As LongPtr, ByVal x As Long, ByVal y As Long) As Long
Private Declare PtrSafe Function GetWindowDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare PtrSafe Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
#Else
Private Declare Function GetPixel Lib "gdi32" (ByVal hDC As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hDC As Long) As Long
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDC As Long, ByVal nIndex As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
#End If
Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type POINTAPI
x As Long
y As Long
End Type
Private Function ScreenDPI(bVert As Boolean) As Long
'in most cases this simply returns 96
Static lDPI&(1), lDC&
If lDPI(0) = 0 Then
lDC = GetDC(0)
lDPI(0) = GetDeviceCaps(lDC, 88&) 'horz
lDPI(1) = GetDeviceCaps(lDC, 90&) 'vert
lDC = ReleaseDC(0, lDC)
End If
ScreenDPI = lDPI(Abs(bVert))
End Function
Private Function PTtoPX(Points As Single, bVert As Boolean) As Long
PTtoPX = Points * ScreenDPI(bVert) / 72
End Function
Private Sub GetRangeRect(ByVal rng As Range, ByRef rc As RECT)
Dim wnd As Window
'requires additional code to verify the range is visible
'etc.
Set wnd = rng.Parent.Parent.Windows(1)
With rng
rc.Left = PTtoPX(.Left * wnd.Zoom / 100, 0) _
+ wnd.PointsToScreenPixelsX(0)
rc.Top = PTtoPX(.Top * wnd.Zoom / 100, 1) _
+ wnd.PointsToScreenPixelsY(0)
rc.Right = PTtoPX(.Width * wnd.Zoom / 100, 0) _
+ rc.Left
rc.Bottom = PTtoPX(.Height * wnd.Zoom / 100, 1) _
+ rc.Top
End With
End Sub
Sub CellColor(cellRange As Range)
Dim lColour As Long
Dim lDC As Variant
lDC = GetWindowDC(0)
'Grab the pixel that we will use to determine the color
Dim rc As RECT
Dim xPos As Integer
Dim yPos As Integer
Call GetRangeRect(cellRange, rc)
xPos = rc.Left
yPos = rc.Top
lColour = GetPixel(lDC, xPos, yPos)
Debug.Print xPos, yPos, lColour
Sheet1.Range("a1").Interior.Color = lColour
End Sub
Sub Picture1_Click()
CellColor Sheet1.Range("D2")
End Sub

Set TabStops on a ListBox control in VBA Excel

I first came onto that post here by Randy Birch about listing clipboard formats. As you can see, he is using Visual Basic 6 and also a .Refresh method on List1 after sending the LB_SETTABSTOPS messages to the WNDPROC handling the window corresponding to his "List1" ListBox
Since the .Refresh method is not available in VBA (and also the .Hwnd, but that is less a problem withing this post by C. PEARSON and Private Declare Function GetFocus Lib "user32" () As Long), I tried to 'mimic' it.
Apparently, the .Refresh method invalidates the whole client area of the ListBox Window, and then sends a WM_PAINT message to the WNDPROC bypassing any other pending messages in message queue, causing an immediate repaint of the update region, which should be the entire visible "List1" ListBox in this particular case.
My config :
Debug.Print Application.Version
Debug.Print Application.VBE.Version
Debug.Print Application.OperatingSystem
#If VBA6 Then
Debug.Print "VBA6 = True"
#Else
Debug.Print "VBA6 = False"
#End If
#If VBA7 Then
Debug.Print "VBA7 = True"
#Else
Debug.Print "VBA7 = False"
#End If
Results in:
16.0
7.01
Windows (32-bit) NT 10.00
VBA6 = True
VBA7 = True
Now my attempt #1 :
Option Explicit
Private Const LB_SETTABSTOPS As Long = &H192
Private Const EM_SETTABSTOPS As Long = &HCB
Private Const RDW_ALLCHILDREN = &H80
Private Const RDW_ERASE = &H4
Private Const RDW_ERASENOW = &H200
Private Const RDW_FRAME = &H400
Private Const RDW_INTERNALPAINT = &H2
Private Const RDW_INVALIDATE = &H1
Private Const RDW_NOCHILDREN = &H40
Private Const RDW_NOERASE = &H20
Private Const RDW_NOFRAME = &H800
Private Const RDW_NOINTERNALPAINT = &H10
Private Const RDW_UPDATENOW = &H100
Private Const RDW_VALIDATE = &H8
Private hWndList1 As Long
Private Type Rect
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hWnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Private Declare Function GetFocus Lib "user32" () 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 UpdateWindow Lib "user32" (ByVal hWnd As LongPtr) As Boolean
Private Declare Function VarPtrArray Lib "msvbvm60.dll" Alias "VarPtr" (ByRef lpRect As Rect) As Long
Private Declare Function RedrawWindow Lib "user32" (ByVal hWnd As Long, ByRef lprcUpdate As Rect, ByVal hrgnUpdate As Long, Optional ByVal flags As Integer) As Boolean
Private Declare Function InvalidateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Long
Private Declare Function GetUpdateRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect, ByVal bErase As Boolean) As Boolean
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Boolean
Private Declare Function CreateRectRgnIndirect Lib "gdi32" (ByRef lpRect As Rect) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, ByRef lpRect As Rect) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Sub UserForm_Initialize()
Dim ListWindowUpdated As Boolean
Dim ListWindowRedrawn As Boolean
ReDim TabStop(0 To 1) As Long
TabStop(0) = 90
TabStop(1) = 130
With List1
.Clear
.SetFocus
hWndList1 = GetFocus
Call SendMessage(hWndList1, LB_SETTABSTOPS, 0&, ByVal 0&)
Call SendMessage(hWndList1, LB_SETTABSTOPS, 2, TabStop(0))
Dim rectList1 As Rect
Call GetWindowRect(hWndList1, rectList1)
Dim lprcList1 As Long
lprcList1 = VarPtrArray(rectList1)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, lprcList1, RDW_INVALIDATE)
ListWindowRedrawn = RedrawWindow(hWndList1, rectList1, 0, RDW_INVALIDATE)
MsgBox "ListWindowRedrawn = " & ListWindowRedrawn & " and RDW_INVALIDATE message sent"
'Call RedrawWindowAny(hWndForm2, vbNull, 1&, RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_ALLCHILDREN)
ListWindowUpdated = UpdateWindow(hWndList1)
MsgBox "ListWindowUpdated = " & ListWindowUpdated
End With
End Sub
My attempt #2 :
Dim ScreenRect As Rect
Dim hClientRect As Long
hClientRect = GetClientRect(hWndList1), ScreenRect)
Dim udtScrDim As Rect
Dim lReturn As Long
Dim hRegion As Long
udtScrDim.Left = 0
udtScrDim.Top = 0
udtScrDim.Right = ScreenRect.Right - ScreenRect.Left
MsgBox "Screen width = " & ScreenRect.Right - ScreenRect.Left
udtScrDim.Bottom = ScreenRect.Bottom - ScreenRect.Top
MsgBox "Screen height = " & ScreenRect.Bottom - ScreenRect.Top
hRegion = CreateRectRgnIndirect(udtScrDim)
If hRegion <> 0 Then
lReturn = RedrawWindow(0, udtScrDim, hRegion, RDW_ERASE Or RDW_FRAME Or RDW_INVALIDATE Or RDW_UPDATENOW Or RDW_INTERNALPAINT Or RDW_ALLCHILDREN)
End If
After many attemps, I still can't get the client area to be updated with the custom tabstop positions. But the attempt #1 above still seems to be the more logical to me. It works fine, no errors, but nothing changes, any item (containing vbTab) in the ListBox won't be affected, even with a later UserForm1.Repaint.
Please help :)
This is not quite an answer but more a workaround :
My understanding of the problem (and of Randy Birch) :
The only explaination is that the VBA Listbox control simply can't deal with LB_SETTABSTOPS messages. Indeed I also tried sending the LB_SETTABSTOPS message later, but it's still ignored. Same thing with the invalidate message and WM_PAINT.
That might be why the Office devs implemented the .ColumnWidth property in VBA Excel which can do exactly the same things that what I was trying to do above.

vb macro string width in pixel

How would you calculate the number of pixels for a String (in an arbitrary font), using an Excel VBA macro?
Related:
http://www.mrexcel.com/forum/excel-questions/19267-width-specific-text-pixels.html
http://www.ozgrid.com/forum/showthread.php?t=94339
Write a new module class and put the following code in it.
'Option Explicit
'API Declares
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 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 SIZE) 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 Const LOGPIXELSY As Long = 90
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type SIZE
cx As Long
cy As Long
End Type
Public Function getLabelPixel(label As String) As Integer
Dim font As New StdFont
Dim sz As SIZE
font.Name = "Arial Narrow"
font.SIZE = 9.5
sz = GetLabelSize(label, font)
getLabelPixel = sz.cx
End Function
Private Function GetLabelSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
' Create a device context and a bitmap that can be used to store a
' temporary font object
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font
lf.lfFaceName = font.Name & Chr$(0)
lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure
GetTextExtentPoint32 tempDC, text, Len(text), textSize
' Clean up (very important to avoid memory leaks!)
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
' Return the measurements
GetLabelSize = textSize
End Function
Call the getLabelPixel function with parameter(string whose width has to be calculated).
User 1355's (now Sarika.S) answer is excellent! (I would have put that in the comments, but my reputation is not high enough... yet.)
I'm not measuring labels, but text within a cell and I didn't want to make assumptions about the font, so I made some minor modifications and additions.
As instructed by 1355, Write a new code module and put the following code in it.
'Option Explicit
'API Declares
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 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 FNTSIZE) 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 Const LOGPIXELSY As Long = 90
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type FNTSIZE
cx As Long
cy As Long
End Type
Public Function GetLabelPixelWidth(label As String) As Integer
Dim font As New StdFont
Dim sz As FNTSIZE
font.Name = "Arial Narrow"
font.Size = 9.5
sz = GetLabelSize(label, font)
getLabelPixelWidth = sz.cx
End Function
Public Function GetStringPixelHeight(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer
Dim font As New StdFont
Dim sz As FNTSIZE
font.Name = fontName
font.Size = fontSize
font.Bold = isBold
font.Italic = isItalics
sz = GetLabelSize(text, font)
GetStringPixelHeight = sz.cy
End Function
Public Function GetStringPixelWidth(text As String, fontName As String, fontSize As Single, Optional isBold As Boolean = False, Optional isItalics As Boolean = False) As Integer
Dim font As New StdFont
Dim sz As FNTSIZE
font.Name = fontName
font.Size = fontSize
font.Bold = isBold
font.Italic = isItalics
sz = GetLabelSize(text, font)
GetStringPixelWidth = sz.cx
End Function
Private Function GetLabelSize(text As String, font As StdFont) As FNTSIZE
Dim tempDC As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As FNTSIZE
' Create a device context and a bitmap that can be used to store a
' temporary font object
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font
lf.lfFaceName = font.Name & Chr$(0)
lf.lfHeight = -MulDiv(font.Size, GetDeviceCaps(GetDC(0), 90), 72) 'LOGPIXELSY
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure
GetTextExtentPoint32 tempDC, text, Len(text), textSize
' Clean up (very important to avoid memory leaks!)
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
' Return the measurements
GetLabelSize = textSize
End Function
Some examples of calling the GetStringPixelWidth function
MsgBox (GetStringPixelWidth("Test String", "Calibri", 10))
MsgBox (GetStringPixelWidth(" ", "Calibri", 10, True, False))
Thanks again to 1355/Sarika S. for saving me tons of work!
Also, there is a memory leak as noted by one commenter, which didn't affect my uses but I did detect it. I will re-post with any changes if I make them to account for/correct that.
If you are using a UserForm, a much less technically solution would be to add a label to the form with the same font style and size as the text to be evaluated. Set AutoSize to True, Caption to 'blank', Visible to False, Width to 0, and wordWrap to False.
This hidden label will become of measurement tool of sorts for text using the Function below:
Public Function TextLength(sString As String) As Long
UserForm.TextMeasure.Caption = sString
TextLength = UserForm.TextMeasure.Width
End Function
If you are running on a 64bit system and you get a compile error due to that, the solution will be to change the API Declares to:
'API Declares
#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 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 SIZE) 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
#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 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 SIZE) 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
#End If
I put this code on a timer and ran it every second, then opened up Task Manager and enabled the GDI Objects column. I could see it keep on increasing for my process.
Although tempDC is being deleted, I think the result of GetDC(0) needs to be as well?
(This is in relation to the accepted answer btw)
This slight adjustment worked for me:
...
Private Function GetLabelSize(text As String, font As StdFont) As SIZE
Dim tempDC As Long
Dim tempDC2 As Long
Dim tempBMP As Long
Dim f As Long
Dim lf As LOGFONT
Dim textSize As SIZE
' Create a device context and a bitmap that can be used to store a
' temporary font object
tempDC = CreateDC("DISPLAY", vbNullString, vbNullString, ByVal 0)
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font
lf.lfFaceName = font.Name & Chr$(0)
tempDC2 = GetDC(0)
lf.lfHeight = -MulDiv(font.SIZE, GetDeviceCaps(tempDC2, 90), 72) 'LOGPIXELSY
lf.lfItalic = font.Italic
lf.lfStrikeOut = font.Strikethrough
lf.lfUnderline = font.Underline
If font.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
f = CreateFontIndirect(lf)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize SIZE structure
GetTextExtentPoint32 tempDC, text, Len(text), textSize
' Clean up (very important to avoid memory leaks!)
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
DeleteDC tempDC2
' Return the measurements
GetLabelSize = textSize
End Function
To expand on and hone Dustin's answer, here is the code that I use.
Like Dustin, I have a label on a hidden user form with AutoSize = True. Make sure WordWrap = False or else you get bizarre results;)
However, there is a bit of extra fluff added onto the label's width each time. To correct for it, you need to also find the width of an blank caption and subtract the difference. Even that is problematic sometimes so in my code I find the difference between the string plus an arbitrary character and the arbitrary character by itself.
The following code can go in any module you like. frmTextWidth is the name of the custom form and Label1 is the label that will measure the width of text.
Public Function TextWidth(ByVal Text As Variant, _
Optional ByVal FontName As Variant, _
Optional FontSize As Double) As Single
If TypeName(Text) = "Range" Then
If IsMissing(FontName) Then Set FontName = Text
Text = Text.Value
End If
If TypeName(FontName) = "Range" Then
frmTextWidth.Label1.Font = FontName.Font
ElseIf VarType(FontName) = vbString Then
If FontName <> "" Then frmTextWidth.Label1.Font.Name = FontName
If FontSize <> 0 Then frmTextWidth.Label1.Font.Size = FontSize
End If
frmTextWidth.Label1.Caption = CStr(Text) + "."
TextWidth = frmTextWidth.Label1.Width
frmTextWidth.Label1.Caption = "."
TextWidth = TextWidth - frmTextWidth.Label1.Width
End Function
You can supply a range as the string source and the function will automatically pick up the string and its font. If you have a string in a cell that has mixed fonts and font sizes, you can understand that this function won't work. You would have to find the size of each individual formated character but the code involved is not too tricky.
If you call the function allot, you may not want to set the font of the label every time because it will bog down the function. Simply test to see if the requested font name/size is different than what Label1 is set to before changing it.
I see GetLabelSize() method is wrong with Japanese character.
Ex: With font 'MS Pゴシック' size 11
'a' = 9 pixel
'あ' = 9 pixel
But I see 'あ' is wider then 'a'.
This is my adapted code supporting 32- and 64-bit and unicode strings by usage of '*W'-api's:
Minimum supported Microsoft Access version is 2010 (VBA 7).
Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type
Private Type FNTSIZE
cx As Long
cy As Long
End Type
Private Declare PtrSafe Function CreateDC Lib "gdi32.dll" Alias "CreateDCW" (ByVal lpDriverName As LongPtr, ByVal lpDeviceName As LongPtr, ByVal lpOutput As LongPtr, lpInitData As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectW" (ByRef lpLogFont As LOGFONT) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function GetTextExtentPoint32 Lib "gdi32.dll" Alias "GetTextExtentPoint32W" (ByVal hdc As LongPtr, ByVal lpsz As LongPtr, ByVal cbString As Long, lpSize As FNTSIZE) 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 LongPtr) As LongPtr
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" (ByVal hdc As LongPtr) As Long
Public Function GetLabelPixel(ByVal xLabel As String) As Integer
Dim xFont As New StdFont
Dim sz As FNTSIZE
xFont.Name = "Segoe UI"
xFont.Size = 10
sz = GetLabelSize(xLabel, xFont)
GetLabelPixel = sz.cx
End Function
Private Function GetLabelSize(ByVal xText As String, ByVal xFont As StdFont) As FNTSIZE
' Create a device context and a bitmap that can be used to store a
' temporary font object
Dim tempDC As LongPtr
tempDC = CreateDC(StrPtr("DISPLAY"), StrPtr(vbNullString), StrPtr(vbNullString), ByVal 0)
Dim tempBMP As LongPtr
tempBMP = CreateCompatibleBitmap(tempDC, 1, 1)
' Assign the bitmap to the device context
DeleteObject SelectObject(tempDC, tempBMP)
' Set up the LOGFONT structure and create the font
Dim lf As LOGFONT
lf.lfFaceName = xFont.Name & Chr$(0)
Dim tempDC2 As LongPtr
tempDC2 = GetDC(0)
lf.lfHeight = -MulDiv(xFont.Size, GetDeviceCaps(tempDC2, 90), 72) 'LOGPIXELSY
lf.lfItalic = xFont.Italic
lf.lfStrikeOut = xFont.Strikethrough
lf.lfUnderline = xFont.Underline
If xFont.Bold Then lf.lfWeight = 800 Else lf.lfWeight = 400
Dim f As LongPtr
f = CreateFontIndirect(lf)
' Assign the font to the device context
DeleteObject SelectObject(tempDC, f)
' Measure the text, and return it into the textSize FNTSIZE structure
Dim textSize As FNTSIZE
GetTextExtentPoint32 tempDC, StrPtr(xText), Len(xText), textSize
' Clean up (very important to avoid memory leaks!)
DeleteObject f
DeleteObject tempBMP
DeleteDC tempDC
DeleteDC tempDC2
' Return the measurements
GetLabelSize = textSize
End Function
If you're using Word VBA (as SO MANY of us do :) ), you can always set up a Word.Range object (NOT Excel.Range!) to be the text whose width you want, which must actually exist in the document and be rendered in the relevant font. Then calculate the Range's End minus Start -- of course the results includes Word's Format/Font settings re kerning, spacing, etc., but that might be exactly what you want, the true width.
I've always been a fan of creating an invisible scratch document, or in Excel a scratch workbook, to use for stuff like this in code. So in Word I'd remove all of the scratch document's contents, reset all settings per the Normal style, insert the text, render it in the font/size desired, set a Word.Range object to the text (without the final paragraph mark) and get the object's End - Start.
Likewise in Excel I'd use a scratch workbook to clear all content from one column in some tab, set the column's width to 255, make sure of no word-wrap, insert the text (with a preceding apostrophe prefix just in case!) into a cell, render it in the desired font/size, auto-fit the column, and get the column's width.
If you need a mix of fonts sizes etc., why not use:
DrawText tempDC, Text, Len(Text), wRect, DT_CALCRECT ' Or DT_BOTTOM
instead of
GetTextExtentPoint32 tempDC, text, Len(text), textSize
with wRect as zero rectangle that returns .cx as .right and .cy as .bottom

Resources