Related
I have a userform with several label controls, all belong to a class that on mouseover, another userform containing some information about that label will be shown. Now I wanted that form to be closed after mouse leaves the control. Now I am using application.ontime and closing the second form after 2 seconds, which makes the form flickers when the mouse is still over the label. I am wondering if there is anyway better? Here is my code so far.
My Code on the class Module
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, _
ByVal X As Single, ByVal Y As Single)
Dim m
On Error Resume Next
If Button = XlMouseButton.xlPrimaryButton And LabelBase.Edit.Caption = "Done" Then
Label1.Left = Label1.Left + X - x_offset
Label1.Top = Label1.Top + Y - y_offset
ElseIf LabelBase.Edit.Caption = "Edit" Then
With CurrentJob
.Caption = "Current Job of " & Label1.Caption
.LBcurr.list = openJobs
.LLast = LastJob
.LClsd = WorksheetFunction.CountIfs(oprecord.Range("e:e"), Label1.Caption, oprecord.Range("f:f"), Date, oprecord.Range("s:s"), "CLOSED")
.LAc = Fix(Right(Label1.Tag, Len(Label1.Tag) - 1) / 24) + 70006
m = WorksheetFunction.VLookup(Label1.Caption, rooster.Range("b:e"), 4, 0)
.LSkill = Right(m, Len(m) - InStr(1, m, " "))
.StartUpPosition = 0
.Top = X + 10
.Left = Y + 10
.Show
End With
With Label1
If X < .Left Or X > (.Left + .Width) Or Y > (.Top + .Height) Or Y < .Top Then closeee
End With
End If
End Sub
My code on the second userform
Private Sub UserForm_Activate()
Application.OnTime Now + TimeValue("00:00:03"), "closeee"
End Sub
Private Sub UserForm_Terminate()
On Error Resume Next
With Me
clearallcontrols
End With
Application.OnTime Now + TimeValue("00:00:03"), "closeee", , False
End Sub
Here is a picture of MAin userform when the Info Form is loaded.
Regards,
M
You don't need a timing ... if you want to work with mouse moves, the code to close the info display form (I suppose its name is CurrentJob) should be fired by a UserForm_MouseMove event on the main form, as when leaving the label, the mouse will next be over the form itself (unless you position labels next to each other without any space - which will make the next comment appear as it should).
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
CurrentJob.Hide
End Sub
I also recommend to pack the info display code in a private sub of its own to keep the code for the various labels clean.
example: I have a form with Label1, Label2, Label3, Textbox1 and following code:
Private Sub ShowInfo(InfoText As String)
' code to query info and show in seperate window
' make sure window doesn't get focus
' I prefer to use non editable text boxes in my main window
Me.TextBox1 = InfoText
End Sub
Private Sub Label1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label1"
End Sub
Private Sub Label2_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label2"
End Sub
Private Sub Label3_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
ShowInfo "Mouse is over Label3"
End Sub
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
' this is the exit code
' as here we left all labels
ShowInfo "Mouse is not on a label"
End Sub
Here is the Answer I got on another forum (MrExcel). All the credits go to Jaafar Tribak:
1- Code in a Standard module:
Option Explicit
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 Then
#If Win64 Then
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal arg1 As LongPtr, ppacc As Any, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal arg2 As LongPtr) As Long
#Else
Private Declare PtrSafe Function AccessibleObjectFromPoint Lib "oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare PtrSafe Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
#End If
Private Declare PtrSafe Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As LongPtr) As Long
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As LongPtr)
Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#Else
Private Declare Function AccessibleObjectFromPoint Lib "Oleacc" (ByVal lX As Long, ByVal lY As Long, ppacc As IAccessible, pvarChild As Variant) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function WindowFromAccessibleObject Lib "oleacc" (ByVal pacc As IAccessible, phwnd As Long) As Long
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
#End If
Private tCursPos As POINTAPI, tControlRect As RECT
Private bFlag As Boolean
Public Function EnableMouseLeaveEevent(ByVal MainUserForm As UserForm, ByVal Ctrl As Control, ByVal TargetUserForm As Object, Optional ByVal TimeOutInSeconds As Long) As Boolean
Dim oIA As IAccessible
Dim w As Long, h As Long
TargetUserForm.StartUpPosition = 0 '<=== (for testing only .. edit out this line if required)
If bFlag = False Then EnableMouseLeaveEevent = True
Ctrl.Tag = IIf(TimeOutInSeconds > 0, ObjPtr(TargetUserForm) & "*" & TimeOutInSeconds & "*" & Timer, ObjPtr(TargetUserForm))
GetCursorPos tCursPos
#If VBA7 Then
Dim Formhwnd As LongPtr
#If Win64 Then
Dim lngPtr As LongPtr
CopyMemory lngPtr, tCursPos, LenB(tCursPos)
Call AccessibleObjectFromPoint(lngPtr, oIA, 0)
#Else
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
#Else
Dim Formhwnd As Long
Call AccessibleObjectFromPoint(tCursPos.x, tCursPos.y, oIA, 0)
#End If
WindowFromAccessibleObject MainUserForm, Formhwnd
With tControlRect
oIA.accLocation .Left, .Top, w, h, 0&
.Right = w + .Left
.Bottom = h + .Top
End With
SetTimer Formhwnd, CLng(ObjPtr(Ctrl)), 0, AddressOf TimerProc
End Function
Private Sub TimerProc(ByVal hwnd As Long, ByVal MSG As Long, ByVal nIDEvent As Long, ByVal dwTimer As Long)
Static tPrevCurPos As POINTAPI
Dim tCurrCurPos As POINTAPI
Dim sArray() As String
Dim oCtrolObj As Object, oTargetFormObj As Object
Dim lTimeOut As Long, lStartTimer As Long
CopyMemory oCtrolObj, nIDEvent, LenB(nIDEvent)
sArray = Split(oCtrolObj.Tag, "*")
CopyMemory oTargetFormObj, CLng(sArray(0)), LenB(nIDEvent)
If UBound(sArray) = 2 Then
lTimeOut = CLng(sArray(1))
lStartTimer = CLng(sArray(2))
End If
GetCursorPos tCurrCurPos
#If VBA7 Then
Dim lngPtr As LongPtr
#If Win64 Then
CopyMemory lngPtr, tCurrCurPos, LenB(tCurrCurPos)
If PtInRect(tControlRect, lngPtr) = 0 Then
#Else
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
#Else
Dim lngPtr As Long
If PtInRect(tControlRect, tCurrCurPos.x, tCurrCurPos.y) = 0 Then
#End If
bFlag = False
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "Mouse Cursor outside button!"
GoTo Xit
Else
If lTimeOut > 0 Then
With tCurrCurPos
If .x = tPrevCurPos.x And .y = tPrevCurPos.y Then
If Timer - lStartTimer > lTimeOut Then
bFlag = True
lStartTimer = Timer
KillTimer hwnd, nIDEvent
Unload oTargetFormObj
Debug.Print "TimeOut!"
End If
Else
bFlag = False
oCtrolObj.Tag = IIf(lTimeOut > 0, ObjPtr(oTargetFormObj) & "*" & lTimeOut & "*" & Timer, ObjPtr(oTargetFormObj))
GoTo Xit
End If
End With
End If
End If
Xit:
CopyMemory oCtrolObj, 0, LenB(nIDEvent)
CopyMemory oTargetFormObj, 0, LenB(nIDEvent)
GetCursorPos tPrevCurPos
End Sub
2- Code usage in UserForm Module:
Private Sub CommandButton1_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal x As Single, ByVal y As Single)
If EnableMouseLeaveEevent(MainUserForm:=Me, Ctrl:=Me.CommandButton1, TargetUserForm:=UserForm2, TimeOutInSeconds:=5) Then ' 5 Sec timeout
UserForm2.Show
End If
End Sub
Thats was a perfect answer.
Links:
VBA- how to have a secondary userform behaviours just like controltiptext
Also a
Demo Excel File
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.
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
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 'ＭＳ Ｐゴシック' 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
I am using the CheckTokenMembership Windows API to check if the user is an Administrator.
Here's the code:
Option Explicit
Private Const SECURITY_BUILTIN_DOMAIN_RID As Long = &H20
Private Const DOMAIN_ALIAS_RID_ADMINS As Long = &H220
Private Declare Function AllocateAndInitializeSid Lib "advapi32.dll" (pIdentifierAuthority As Any, ByVal nSubAuthorityCount As Byte, ByVal nSubAuthority0 As Long, ByVal nSubAuthority1 As Long, ByVal nSubAuthority2 As Long, ByVal nSubAuthority3 As Long, ByVal nSubAuthority4 As Long, ByVal nSubAuthority5 As Long, ByVal nSubAuthority6 As Long, ByVal nSubAuthority7 As Long, lpPSid As Long) As Long
Private Declare Sub FreeSid Lib "advapi32.dll" (ByVal pSid As Long)
Private Declare Function CheckTokenMembership Lib "advapi32.dll" (ByVal hToken As Long, ByVal pSidToCheck As Long, pbIsMember As Long) As Long
Private Type SID_IDENTIFIER_AUTHORITY
Value(0 To 5) As Byte
End Type
Private Function pvIsAdmin() As Boolean
Dim uAuthNt As SID_IDENTIFIER_AUTHORITY
Dim pSidAdmins As Long
Dim lResult As Long
uAuthNt.Value(5) = 5
If AllocateAndInitializeSid(uAuthNt, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, pSidAdmins) <> 0 Then
If CheckTokenMembership(0, pSidAdmins, lResult) <> 0 Then
pvIsAdmin = (lResult <> 0)
End If
Call FreeSid(pSidAdmins)
End If
End Function
Problem is that on Windows 7 and Windows 2008 SP2, the call to FreeSID is causing the app to crash. The crash is intermittent.
Has anyone encountered this problem?
Thanks!
EDIT:
I just rechecked my code and I found out that I declared FreeSID as such:
Private Declare Sub FreeSid Lib "advapi32.dll" (pSid As Long)
As compared to the above code, the pSid parameter here is not flagged as ByVal. I added the ByVal flag and the problem is no longer present. Somehow, I am not convinced that this fixed the problem. Can this possibly have fixed the problem?
Separate pvIsAdmin in a completely separate module and copy function declarations verbatim from the snippet. In AllocateAndInitializeSid lpPSid is ByRef. In FreeSid param is ByVal.