Measuring Tool - Automatically Default To "All Decimals"
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Employees at our company have to switch to "all decimals" in the measuring tool many times per day, which is an annoying setting that Autodesk has failed to implement for years, including the 2017 release. I wrote a macro that automates the "all decimals" process. If you copy and paste this code into a new module, then make a hotkey or add a button on the assembly/part/drawing ribbons for the "AllDecimals" subroutine, it will launch the measure tool and automatically switch your measure tool to "all decimals". I used direct window messages for the most robust possible command processing. There are no "SendKeys" in this program.
My PC setup is 64 bit Windows 7 Professional, Intel i7 3.5GHz, 32GB RAM
Disclaimer: this code is largely untested by anyone other than myself. It may contain errors, programming mistakes, hinder performance, or any other potential negative effect, though I have not personally experienced these issues. It is likely not full of best programming practices and contains snippets of code from many other sources. I have not commented the code to explain the processes. I did not want to spend time on anything other than simply developing a usable program (primarily for myself and others at my company). There is essentially no error handling. Proceed at your own risk.
Public Type DWORDAsLong
lLong As Long
End Type
Public Type DWORDAsInts
iLow As Integer
iHigh As Integer
End Type
Public Const WM_COMMAND = 273
Public Const WM_GETTEXT = 13
Public Const WM_GETTEXTLENGTH = 14
Public Declare PtrSafe Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare PtrSafe Function FindWindowEx Lib "user32.dll" Alias "FindWindowExA" (ByVal Phwnd As Long, ByVal Nhwnd As Long, ByVal lpszClass As String, ByVal lpszName As String) As Long
Public Declare PtrSafe Function GetNextWindow Lib "user32" Alias "GetWindow" (ByVal hWnd As Long, ByVal wFlag As Long) As Long
Public Declare PtrSafe Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Public Declare PtrSafe Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) As Long
Public Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
Public Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lparam As Any) As Long
Public Declare PtrSafe Function GetDesktopWindow Lib "user32" () As Long
Public Declare PtrSafe Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Sub AllDecimals()
Dim TboxTxt As String
Dim BHwnd As Long
Dim TboxHwnd As Long
Dim wParam1 As Long
Dim MPhwnd As Long
MPhwnd = FindTool
If MPhwnd = 0 Then
InventorName = FindWindowLike(GetDesktopWindow(), "Inventor", "")
wParam2 = MAKEWPARAM(&H73C9, &H0)
SendMessage InventorName, WM_COMMAND, wParam2, Null
CopyTxt = False
End If
Do While MPhwnd = 0
MPhwnd = FindTool
If MPhwnd <> 0 Then Exit Do
num = num + 1
If num >= 1000 Then
Exit Sub
MsgBox "Measuring Tool Not Found"
End If
Loop
wParam1 = MAKEWPARAM(&H87A2, &H0)
PostMessage MPhwnd, WM_COMMAND, wParam1, Null
End Sub
Public Function MAKEWPARAM(ByVal wLow As Integer, ByVal wHigh As Integer) As Long
Dim t1 As DWORDAsInts
Dim t2 As DWORDAsLong
t1.iLow = wLow
t1.iHigh = wHigh
LSet t2 = t1
MAKEWPARAM = t2.lLong
End Function
Public Function getNameFromHwnd(ByVal hWnd As Long) As String
Dim title As String * 255
Dim tLen As Long
tLen = GetWindowTextLength(hWnd)
If tLen = 0 Then
getNameFromHwnd = "No Value Available"
Exit Function
End If
GetWindowText hWnd, title, 255
getNameFromHwnd = Left(title, tLen)
End Function
Function FindTool()
Dim Phwnd As Long
Phwnd = FindWindow("#32770", "Measure Distance")
If Phwnd = 0 Then Phwnd = FindWindow("#32770", "Length")
If Phwnd = 0 Then Phwnd = FindWindow("#32770", "Position")
If Phwnd = 0 Then Phwnd = FindWindow("#32770", "Minimum Distance")
If Phwnd = 0 Then Phwnd = FindWindow("#32770", "Diameter")
FindTool = Phwnd
End Function
Sub API_Window()
Dim ClassName$, SearchName$, WinName$
ClassName = ""
SearchName = "Inventor"
WinName = FindWindowLike(GetDesktopWindow(), SearchName, ClassName)
wParam2 = MAKEWPARAM(&H73C9, &H0)
SendMessage WinName, WM_COMMAND, wParam2, Null
End Sub
Function FindWindowLike(hWndParent As Long, Caption As String, ClassName As String) As String
Dim hWnd&
Const GW_HWNDNEXT = 2, GW_CHILD = 5
hWnd = GetWindow(hWndParent, GW_CHILD)
Do Until hWnd = 0
If WindowText(hWnd) Like "*" & Caption & "*" Then
FindWindowLike = hWnd
Exit Do
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop
End Function
Function WindowText(hWnd As Long) As String
Dim lng&, str$
Const WM_GETTEXT = &HD, WM_GETTEXTLENGTH = &HE
If hWnd <> 0 Then
lng = SendMessage(hWnd, WM_GETTEXTLENGTH, 0&, 0&) + 1
If lng > 0 Then
str = String$(lng, vbNullChar)
lng = SendMessage(hWnd, WM_GETTEXT, lng, ByVal str)
If lng > 0 Then WindowText = Left$(str, lng)
End If
End If
End Function
