The following formulae can be used to transform geographic coordinates between geodetic datums using three and seven parameter similarity transformations.
These formulas are formally defined in the LINZ standard LINZS25000 (Standard for New Zealand Geodetic Datum 2000), and are summarised in the associated NZGD2000 fact sheet (LINZG25700) and LINZG25703 (Fact Sheet – Datum and Projection Transformations).
This conversion is a three-step process:
These formulae can be used to convert geographic coordinates, latitude ( Φ ), longitude ( λ ), and height ( h), into Cartesian coordinates (X, Y, Z ):
Where a and f are obtained from the reference ellipsoid used for the respective geodetic datum and the h is the height of the computation point or approximated as zero
The three parameter transformation is implemented using:
The Helmert seven parameter similarity transformation is implemented using:
Note: the rotation parameters ( R ) must be converted from arc-seconds to radians before being used in this equation.
Note: this is a simplified version of the Helmert formulae that applies for small rotation angles. This is the official formulae to use for the NZGD49-NZGD2000 seven parameter transformation.
These formulas can be used to convert Cartesian coordinates ( X, Y, Z ) into geographic coordinates latitude ( Φ ), longitude ( λ ), and height ( h ).
Where a and f are obtained from the reference ellipsoid used for the respective geodetic datum:
Note: because NZGD1949 is a horizontal datum the height resulting from the transformation will not be in terms of the output datum, the equation is shown here for completeness.
#If VBA7 Then
Private Declare PtrSafe Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#Else
Private Declare Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
#End If
Private Const VK_SNAPSHOT = &H2C
Private Const VK_MENU = &H12
Private Const KEYEVENTF_KEYUP = &H2
Private Sub sPrintScreen()
' To capture the screen
keybd_event VK_SNAPSHOT, 1, 0, 0
End Sub
Private Sub sAltPrintScreen()
' To capture the active window
Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
keybd_event VK_MENU, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, 0, 0
keybd_event VK_SNAPSHOT, 0, KEYEVENTF_KEYUP, 0
keybd_event VK_MENU, 0, KEYEVENTF_KEYUP, 0
Application.Wait VBA.Now() + TimeSerial(0, 0, 1)
' Add a new worksheet to paste image
Dim oXlWsh As Excel.Worksheet
Dim oXlShp As Excel.Shape
Dim sgLeft As Single
Dim sgTop As Single
Dim sgWidth As Single
Dim sgHeight As Single
Dim oCht As Excel.Chart
Dim oChtObj As Excel.ChartObject
Set oXlWsh = ThisWorkbook.Worksheets.Add 'ActiveSheet
With oXlWsh
'.Name = ...
.Range("A1").Select
.Paste
' Save image to file
Set oXlShp = .Shapes(.Shapes.Count)
With oXlShp
' Copy the picture
.Copy
'.CopyPicture
'' To Resize
'.Height = 600
'.Width = 800
'' To Position It: use the shape's TopLeftCell property.
'' To Crop It: use the shp.PictureFormat.Crop (and/or CropLeft, CropTop, CropBottom, CropRight)
'' if you need to fine-tune what part of the screenshot is needed.
'' For instance, this crops the pasted screenshot to 800x600:
'sgHeight = -(600 - .Height)
'sgWidth = -(800 - .Width)
'.LockAspectRatio = False
'.PictureFormat.CropRight = sgWidth
'.PictureFormat.CropBottom = sgHeight
' Save image
'Set oCht = ThisWorkbook.Charts.Add
'oCht.Location Where:=xlLocationAsObject, Name:=.Name
Set oChtObj = oXlWsh.ChartObjects.Add(0, 0, .Width, .Height)
With oChtObj
.Border.LineStyle = 0
.Left = oXlShp.Left
.Width = oXlShp.Width
.Top = oXlShp.Top
.Height = oXlShp.Height
'To save a range: oRng.CopyPicture xlScreen, xlPicture 'or xlPicture --> xlBitmap
With .Chart
.Paste
.Export Filename:=VBA.Environ$("UserProfile") & "\Documents\SavedRange.jpg", FilterName:="JPG"
End With
DoEvents
.Delete ' get rid of the chart
End With
'.Delete ' get rid of the image
End With
' Other options to save the JPG
'https://www.tek-tips.com/viewthread.cfm?qid=1764114
'http://www.mvps.org/emorcillo/en/code/vb6/index.shtml
' Delete worksheet
'Application.DisplayAlerts = False
'.Delete
'Application.DisplayAlerts = True
End With
End Sub
From there on I can, for example, get the controls in that window (following the idea in this enlightning post from Xristos Samaras’s MyEngineeringWorld).
Option Explicit
'Declaring the necessary API functions for both 64 and 32 bit applications.
#If VBA7 And Win64 Then
'For 64 bit applications.
'Performs an operation on a specified file.
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
'Retrieves a handle to the top-level window whose class name and window name match the specified strings.
'This function does not search child windows. This function does not perform a case-sensitive search.
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'Retrieves a handle to a window whose class name and window name match the specified strings.
'The function searches child windows, beginning with the one following the specified child window.
'This function does not perform a case-sensitive search.
Private Declare PtrSafe Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
'Sends the specified message to a window or windows. The SendMessage function calls the window procedure
'for the specified window and does not parentWindowurn until the window procedure has processed the message.
Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
'Places (posts) a message in the message queue associated with the thread that created the specified
'window and parentWindowurns without waiting for the thread to process the message.
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" (ByVal hWnd As LongPtr, ByVal lpString As String, ByVal cch As LongPtr) As LongPtr
Private Declare PtrSafe Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" (ByVal hWnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetClassName Lib "USER32" Alias "GetClassNameA" (ByVal hWnd As LongPtr, ByVal lpClassName As String, ByVal nMaxCount As LongPtr) As Long
Private Declare PtrSafe Function EnumChildWindows Lib "user32.dll" (ByVal hWndParent As LongPtr, ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Boolean
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hWnd As LongPtr, lpRect As RECT) As LongPtr
'Private Declare PtrSafe Function GetTopWindow Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
'Private Declare PtrSafe Function GetNextWindow Lib "user32.dll" Alias "GetWindow" (ByVal hWnd As LongPtr, ByVal wFlag As LongPtr) As LongPtr
'Private Declare PtrSafe Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As LongPtr) As LongPtr
#Else
'For 32 bit applications.
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpClassName As String, ByVal lpWindowName As String) As Long
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.dll" Alias "PostMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal hWnd As Long) 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 EnumChildWindows Lib "user32.dll" (ByVal hWndParent As Long, ByVal lpEnumFunc As Long, ByVal lParam As Long) As Long
Private Declare Function EnumWindows Lib "user32.dll" (ByVal lpEnumFunc As Long, ByVal lParam As Long) As Boolean
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
#End If
Private Const ERROR_INVALID_WINDOW_HANDLE As Long = 1400
Private Const ERROR_INVALID_WINDOW_HANDLE_DESCR As String = "Invalid window handle."
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' Windows API Constants --> https://doc.pcsoft.fr/en-US/?6510001&verdisp=160 & https://www.magnumdb.com/
Private Const SW_HIDE As Long = 0
Private Const SW_SHOWNORMAL As Long = 1
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const SW_SHOWMINIMIZED As Long = 2
Private Const VK_RETURN As Long = &HD
Private Const WM_SETTEXT As Long = &HC
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_LBUTTONDOWN As Long = 513
Private Const WM_LBUTTONUP As Long = 514
Private Const WM_LBUTTONDBLCLK As Long = 515
Private Const WM_RBUTTONDOWN As Long = 516
Private Const WM_RBUTTONUP As Long = 517
Private Const WM_RBUTTONDBLCLK As Long = 518
Private Const WM_MBUTTONDOWN As Long = 519
Private Const WM_MBUTTONUP As Long = 520
Private Const WM_MBUTTONDBLCLK As Long = 521
Private Const WS_TABSTOP As Long = 65536
Private Const WM_CLOSE As Long = &H10
Private Const BM_CLICK As Long = &HF5
#If VBA7 And Win64 Then
Private hWnd As LongPtr
Private CtrlHandle As LongPtr
#Else
Private hWnd As Long
Private CtrlHandle As Long
#End If
'Used a user defined type here rather than Enum so that it works on 97
Private Type winEnum
winHandle As Integer
winClass As Integer
winTitle As Integer
winHandleClass As Integer
winHandleTitle As Integer
winHandleClassTitle As Integer
End Type
Private winOutputType As winEnum
Private x As Integer
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
#If VBA7 And Win64 Then
Private Type tHandle
hWnd As LongPtr
Name As String
ClassName As String
End Type
#Else
Private Type tHandle
hWnd As Long
Name As String
ClassName As String
End Type
#End If
Private aChild() As tHandle
Private winNum As Long
#If VBA7 And Win64 Then
Private Sub Test()
' You can't call this on a button click, because then your window will be the foreground window.
' Add a timer/wait
' Run the procedure, click another window within 5 seconds.
Dim hWnd As LongPtr
Dim strTitle As String
Dim strClassName As String
Dim lgClassNameLength As LongPtr
Dim lgRetVal As Long
MsgBox "Go activate the Window you want to Spy"
Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
' If no handle, get active window
If hWnd = 0 Then hWnd = hWnd = GetForegroundWindow()
strTitle = fWindowTitle(hWnd)
strClassName = fWindowClassName(hWnd)
''https://stackoverflow.com/questions/6310731/window-click-ok-button-by-code
Erase aChild(): winNum = 0
lgRetVal = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
Stop
' For lgChild = LBound(aChild) To UBound(aChild)
' Next lgChild
Stop
' ' the Button's Caption is "Open" and it is a "Button".
' CtrlHandle = FindWindowEx(hWnd, 0, "Button", "&Open")
' ' send Click to the button(CtrlHandle).
' lgRetVal = SendMessage(CtrlHandle, BM_CLICK, 0, 0)
' 'Fill with text the TextBox.
' lgRetVal = SendMessage(CtrlHandle, WM_SETTEXT, 0&, ByVal strText)
' 'Press the OK button (it is the default action, so no need to find the handle of the button).
' lgRetVal = PostMessage(CtrlHandle, WM_KEYDOWN, VK_RETURN, 0)
End Sub
Private Function fWindowClassName(ByVal hWnd As LongPrt) As String
Dim strClassName As String
Dim lgClassNameLength As LongPtr
Dim lgRetVal As Long
strClassName = String$(100, Chr$(0))
lgRetVal = GetClassName(hWnd, strClassName, 100)
fWindowClassName = VBA.Mid$(strClassName, 1, VBA.InStr(1, strClassName, Chr$(0)) - 1)
End Function
Private Function fWindowTitle(ByVal hWnd As LongPtr) As String
Dim strTitle As String
' Dim lgBufferLen As Long
' Dim wintext As String ' window title text length and buffer
' Dim lgRetVal As Long ' return value
' Dim strBuffer As String
'
' lgBufferLen = GetWindowTextLength(hWnd) + 1 ' get length of title bar text
' strBuffer = VBA.Space$(lgBufferLen) ' make room in the buffer
' lgRetVal = GetWindowText(hWnd, strBuffer, lgBufferLen)
' fWindowTitle = VBA.Left$(strBuffer, lgBufferLen - 1) ' display title bar text of enumerated window
' If not handle, get the active window
If hWnd = 0 Then hWnd = GetForegroundWindow()
' get the title of the active window
strTitle = VBA.String(GetWindowTextLength(hWnd) + 1, VBA.Chr$(0)) ' Make the buffer
GetWindowText hWnd, strTitle, Len(strTitle) + 1
fWindowTitle = VBA.Mid$(strTitle, 1, VBA.InStr(1, strTitle, Chr$(0)) - 1)
End Function
Private Function EnumChildProc(ByVal hWnd As LongPtr, _
ByVal lParam As LongPtr) As Long
Dim lgRetVal As Long
winNum = winNum + 1
ReDim Preserve aChild(1 To winNum)
With aChild(winNum)
.ClassName = fWindowClassName(hWnd)
.Name = fWindowTitle(hWnd)
.hWnd = hWnd
'.hWnd = FindWindow(.ClassName, .Name)
'lgRetVal = FindWindowEx(hWnd, 0, .ClassName, .Name)
'lgRetVal = FindWindowEx(hWnd, .hWnd, vbNullString, vbNullString)
'lgRetVal = FindWindowEx(hWnd, 0&, vbNullString, vbNullString)
End With
EnumChildProc = 1 ' nonzero return value means continue enumeration
End Function
Private Function fWindowRec(ByVal hWnd As LongPtr, _
ByRef Top As Long, _
ByRef Left As Long, _
ByRef Right As Long, _
ByRef Bottom As Long, _
ByRef Width As Long, _
ByRef Height As Long) As Boolean
' Get left, right, top, and bottom positions of a window in pixels.
Dim rectWindow As RECT
' Pass in window handle and empty the data structure.
' If function returns 0, an error occurred.
If GetWindowRect(hWnd, rectWindow) = 0 Then
' Check LastDLLError and display a dialog box if the error
' occurred because an invalid handle was passed.
If Err.LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
fWindowRec = False
'MsgBox ERROR_INVALID_WINDOW_HANDLE_DESCR, Title:="Error!"
End If
Else
With rectWindow
Bottom = .Bottom
Left = .Left
Right = .Right
Top = .Top
Width = .Right - .Left
Height = .Bottom - .Top
End With
fWindowRec = True
End If
End Function
#Else
Private Sub Test()
' You can't call this on a button click, because then your window will be the foreground window.
' Add a timer/wait
' Run the procedure, click another window within 5 seconds.
Dim hWnd As Long
Dim strTitle As String
Dim strClassName As String
Dim lgClassNameLength As Long
Dim lgRetVal As Long
Dim lgChild As Long
Dim strText As String
MsgBox "Go activate the Window you want to Spy"
Application.Wait VBA.Now() + TimeSerial(0, 0, 5)
hWnd = GetForegroundWindow()
strTitle = fWindowTitle(hWnd)
strClassName = fWindowClassName(hWnd)
''https://stackoverflow.com/questions/6310731/window-click-ok-button-by-code
Erase aChild(): winNum = 0
lgRetVal = EnumChildWindows(hWnd, AddressOf EnumChildProc, 0)
Stop
' For lgChild = LBound(aChild) To UBound(aChild)
' Next lgChild
Stop
' ' the Button's Caption is "Open" and it is a "Button".
' CtrlHandle = FindWindowEx(hWnd, 0, "Button", "&Open")
' ' send Click to the button(CtrlHandle).
' lgRetVal = SendMessage(CtrlHandle, BM_CLICK, 0, 0)
' 'Fill with text the TextBox.
' lgRetVal = SendMessage(CtrlHandle, WM_SETTEXT, 0&, ByVal strText)
' 'Press the OK button (it is the default action, so no need to find the handle of the button).
' lgRetVal = PostMessage(CtrlHandle, WM_KEYDOWN, VK_RETURN, 0)
End Sub
Private Function fWindowClassName(ByVal hWnd As Long) As String
Dim strClassName As String
Dim lgClassNameLength As Long
Dim lgRetVal As Long
strClassName = String$(100, Chr$(0))
lgRetVal = GetClassName(hWnd, strClassName, 100)
fWindowClassName = VBA.Mid$(strClassName, 1, VBA.InStr(1, strClassName, Chr$(0)) - 1)
End Function
Private Function fWindowTitle(ByVal hWnd As Long) As String
Dim strTitle As String
' Dim lgBufferLen As Long
' Dim wintext As String ' window title text length and buffer
' Dim lgRetVal As Long ' return value
' Dim strBuffer As String
'
' lgBufferLen = GetWindowTextLength(hWnd) + 1 ' get length of title bar text
' strBuffer = VBA.Space$(lgBufferLen) ' make room in the buffer
' lgRetVal = GetWindowText(hWnd, strBuffer, lgBufferLen)
' fWindowTitle = VBA.Left$(strBuffer, lgBufferLen - 1) ' display title bar text of enumerated window
' If not handle, get the active window
If hWnd = 0 Then hWnd = GetForegroundWindow()
' get the title of the active window
strTitle = VBA.String(GetWindowTextLength(hWnd) + 1, VBA.Chr$(0)) ' Make the buffer
GetWindowText hWnd, strTitle, Len(strTitle) + 1
fWindowTitle = VBA.Mid$(strTitle, 1, VBA.InStr(1, strTitle, Chr$(0)) - 1)
End Function
Private Function EnumChildProc(ByVal hWnd As Long, _
ByVal lParam As Long) As Long
Dim lgRetVal As Long
winNum = winNum + 1
ReDim Preserve aChild(1 To winNum)
With aChild(winNum)
.ClassName = fWindowClassName(hWnd)
.Name = fWindowTitle(hWnd)
.hWnd = hWnd
'.hWnd = FindWindow(.ClassName, .Name)
'lgRetVal = FindWindowEx(hWnd, 0, .ClassName, .Name)
'lgRetVal = FindWindowEx(hWnd, .hWnd, vbNullString, vbNullString)
'lgRetVal = FindWindowEx(hWnd, 0&, vbNullString, vbNullString)
End With
EnumChildProc = 1 ' nonzero return value means continue enumeration
End Function
Private Function fWindowRec(ByVal hWnd As Long, _
ByRef Top As Long, _
ByRef Left As Long, _
ByRef Right As Long, _
ByRef Bottom As Long, _
ByRef Width As Long, _
ByRef Height As Long) As Boolean
' Get left, right, top, and bottom positions of a window in pixels.
Dim rectWindow As RECT
' Pass in window handle and empty the data structure.
' If function returns 0, an error occurred.
If GetWindowRect(hWnd, rectWindow) = 0 Then
' Check LastDLLError and display a dialog box if the error
' occurred because an invalid handle was passed.
If Err.LastDllError = ERROR_INVALID_WINDOW_HANDLE Then
fWindowRec = False
'MsgBox ERROR_INVALID_WINDOW_HANDLE_DESCR, Title:="Error!"
End If
Else
With rectWindow
Bottom = .Bottom
Left = .Left
Right = .Right
Top = .Top
Width = .Right - .Left
Height = .Bottom - .Top
End With
fWindowRec = True
End If
End Function
#End If
Following is another piece of code that did not came to much use, as I could not guess what was the intention of the code -I did really not put too much attention on the thing-. It’s filling the worksheet with names/properties, but barelly understand anything. Seems it getting all the windows in the operating system, and start a loop that seems to not have an end… But looks promissing enough to rip some code apart, starting from the winOutputType.
Public Sub GetWindowInfo()
MsgBox "Go activate the Window you want to Spy"
Application.Wait Now() + TimeSerial(0, 0, 5)
With winOutputType
.winHandle = 0
.winClass = 1
.winTitle = 2
.winHandleClass = 3
.winHandleTitle = 4
.winHandleClassTitle = 5
sGetWinInfo 0&, 0, .winHandleClassTitle
End With
End Sub
#If VBA7 And Win64 Then
Private Sub sGetWinInfo(ByRef hParent As LongPtr, _
ByRef intOffset As Integer, _
ByRef OutputType As Integer)
' Recursively obtain window handles, classes and text given a parent window to search
' Written by Mark Rowlinson
' www.markrowlinson.co.uk - The Programming Emporium
Dim hWnd As Long
Dim lngRet As Long
Dim y As Integer
Dim strText As String
hWnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
While hWnd <> 0
Select Case OutputType
Case winOutputType.winClass
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
Case winOutputType.winHandle
Range("a1").Offset(x, intOffset) = hWnd
Case winOutputType.winTitle
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset) = "N/A"
End If
Case winOutputType.winHandleClass
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
Case winOutputType.winHandleTitle
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset + 1) = "N/A"
End If
Case winOutputType.winHandleClassTitle
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset + 2) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset + 2) = "N/A"
End If
End Select
' check for children
y = x
Select Case OutputType
Case Is > 4
GetWinInfo hWnd, intOffset + 3, OutputType
Case Is > 2
GetWinInfo hWnd, intOffset + 2, OutputType
Case Else
GetWinInfo hWnd, intOffset + 1, OutputType
End Select
' increment by 1 row if no children found
If y = x Then x = x + 1
' now get next window
hWnd = FindWindowEx(hParent, hWnd, vbNullString, vbNullString)
Wend
End Sub
#Else
Private Sub sGetWinInfo(ByRef hParent As Long, _
ByRef intOffset As Integer, _
ByRef OutputType As Integer)
' Recursively obtain window handles, classes and text given a parent window to search
' Written by Mark Rowlinson
' www.markrowlinson.co.uk - The Programming Emporium
Dim hWnd As Long
Dim lngRet As Long
Dim y As Integer
Dim strText As String
hWnd = FindWindowEx(hParent, 0&, vbNullString, vbNullString)
While hWnd <> 0
Select Case OutputType
Case winOutputType.winClass
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
Case winOutputType.winHandle
Range("a1").Offset(x, intOffset) = hWnd
Case winOutputType.winTitle
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset) = "N/A"
End If
Case winOutputType.winHandleClass
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
Case winOutputType.winHandleTitle
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset + 1) = "N/A"
End If
Case winOutputType.winHandleClassTitle
Range("a1").Offset(x, intOffset) = hWnd
strText = String$(100, Chr$(0))
lngRet = GetClassName(hWnd, strText, 100)
Range("a1").Offset(x, intOffset + 1) = Left$(strText, lngRet)
strText = String$(100, Chr$(0))
lngRet = GetWindowText(hWnd, strText, 100)
If lngRet > 0 Then
Range("a1").Offset(x, intOffset + 2) = Left$(strText, lngRet)
Else
Range("a1").Offset(x, intOffset + 2) = "N/A"
End If
End Select
' check for children
y = x
Select Case OutputType
Case Is > 4
sGetWinInfo hWnd, intOffset + 3, OutputType
Case Is > 2
sGetWinInfo hWnd, intOffset + 2, OutputType
Case Else
sGetWinInfo hWnd, intOffset + 1, OutputType
End Select
' increment by 1 row if no children found
If y = x Then x = x + 1
' now get next window
hWnd = FindWindowEx(hParent, hWnd, vbNullString, vbNullString)
Wend
End Sub
#End If
Next steps in development should be get the captured image inside a picture control on a new UserForm, and once all the controls are identified and located by position, recreate the original UserForm, so the GUI is cloned in no time, with -depending on the original developer effort on tidyness- probably right names (instead of CommandButton1, ListBox1,…, you know), and all the labels filled with text. The internal code is where you as a developer should put your best to emulate the original code… but that is another history. Option Explicit
Sub ChangeWidthAndHeight()
SetColumnWidthMM 1, 10
SetRowHeightMM 1, 10
End Sub
Private Sub SetRowHeightMM(ByVal RowNo As Long, _
ByVal mmHeight As Integer)
' changes the Row Height to mm Height
With ActiveSheet
If RowNo < 1 Or RowNo > .Rows.Count Then Exit Sub
End With
With Application
.ScreenUpdating = False
ActiveSheet.Rows(RowNo).RowHeight = .CentimetersToPoints(mmHeight / 10)
.ScreenUpdating = True
End With
End Sub
Private Sub SetColumnWidthMM(ByVal ColNo As Long, _
ByVal mmWidth As Integer)
' changes the column width to mm Width
' Column widths are not really measured in any "unit" as such.
' Instead, the number refers to the number of characters which can be displayed in the column.
' For variable width fonts such as Arial, the "0" character is used.
' In VBA, the ColumnWidth property uses this measure of width, and the Width property uses Points.
' 1 inch = 72 points
' 1 pointH = 1/72 inches.
' 1 pointH = 0.0353 centimeters (or .353 millimetre)
' 1 pointH = ... x pixels
Dim w As Single
Dim wSize As Single
With ActiveSheet
If ColNo < 1 Or ColNo > .Columns.Count Then Exit Sub
End With
Application.ScreenUpdating = False
w = Application.CentimetersToPoints(mmWidth / 10)
With ActiveSheet
wSize = (.Columns(ColNo + 1).Left - .Columns(ColNo).Left)
' First approximation:
With .Columns(ColNo)
.ColumnWidth = .ColumnWidth * (w / wSize)
End With
While .Columns(ColNo + 1).Left - .Columns(ColNo).Left - 0.1 > w
'.Columns(ColNo).ColumnWidth = .Columns(ColNo).ColumnWidth - wMove
With .Columns(ColNo)
'Debug.Print .ColumnWidth
.ColumnWidth = .ColumnWidth - 0.1
End With
Wend
While .Columns(ColNo + 1).Left - .Columns(ColNo).Left + 0.1 < w
With .Columns(ColNo)
'Debug.Print .ColumnWidth
.ColumnWidth = .ColumnWidth + 0.1
End With
Wend
End With
Application.ScreenUpdating = True
End Sub
= CONCATENATE(DEC2HEX(RANDBETWEEN(0,4294967295),8),"-",DEC2HEX(RANDBETWEEN(0,6553??5),4),"-",DEC2HEX(RANDBETWEEN(16384,20479),4),"-",DEC2HEX(RANDBETWEEN(32768,49151??),4),"-",DEC2HEX(RANDBETWEEN(0,65535),4),DEC2HEX(RANDBETWEEN(0,4294967295),8))To get a more consistent method, we can rely on VBA. Here is the code:
' No VT_GUID available so must declare type GUID
Private Type GUID_TYPE
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
#If VBA7 Then
Private Declare PtrSafe Function CoCreateGuid Lib "ole32.dll" (Guid As GUID_TYPE) As LongPtr
Private Declare PtrSafe Function StringFromGUID2 Lib "ole32.dll" (Guid As GUID_TYPE, ByVal lpStrGuid As LongPtr, ByVal cbMax As Long) As LongPtr
Public Function GenerateGUID() As String
Dim Guid As GUID_TYPE
Dim strGuid As String
Dim retValue As Long 'Ptr
Const guidLength As Long = 39 'registry GUID format with null terminator {xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx}
retValue = CoCreateGuid(Guid)
If retValue = 0 Then
strGuid = String$(guidLength, vbNullChar)
retValue = StringFromGUID2(Guid, StrPtr(strGuid), guidLength)
If retValue = guidLength Then
' valid GUID as a string
GenerateGUID = strGuid
End If
End If
End Function
#Else
Private Declare Function CoCreateGuid Lib "ole32" (ByRef Guid As Byte) As Long
Public Function GenerateGUID() As String
Dim ID(0 To 15) As Byte
Dim N As Long
Dim Guid As String
Dim Res As Long
Res = CoCreateGuid(ID(0))
For N = 0 To 15
Guid = Guid & IIf(ID(N) < 16, "0", "") & Hex$(ID(N))
If Len(Guid) = 8 Or Len(Guid) = 13 Or Len(Guid) = 18 Or Len(Guid) = 23 Then
Guid = Guid & "-"
End If
Next N
GenerateGUID = Guid
End Function
'Private Declare Function CoCreateGuid_2 Lib "ole32" (ByRef Guid As GUID_TYPE) As Long
'Public Function NewGUID() As String
''(c) 2000 Gus Molina
'' Not working!
'
' Dim udtGUID As GUID_TYPE
'
' If (CoCreateGuid_2(udtGUID) = 0) Then
' GetGUID = _
String(8 - Len(Hex$(udtGUID.Data1)), "0") & Hex$(udtGUID.Data1) & _
String(4 - Len(Hex$(udtGUID.Data2)), "0") & Hex$(udtGUID.Data2) & _
String(4 - Len(Hex$(udtGUID.Data3)), "0") & Hex$(udtGUID.Data3) & _
IIf((udtGUID.Data4(0) < &H10), "0", "") & Hex$(udtGUID.Data4(0)) & _
IIf((udtGUID.Data4(1) < &H10), "0", "") & Hex$(udtGUID.Data4(1)) & _
IIf((udtGUID.Data4(2) < &H10), "0", "") & Hex$(udtGUID.Data4(2)) & _
IIf((udtGUID.Data4(3) < &H10), "0", "") & Hex$(udtGUID.Data4(3)) & _
IIf((udtGUID.Data4(4) < &H10), "0", "") & Hex$(udtGUID.Data4(4)) & _
IIf((udtGUID.Data4(5) < &H10), "0", "") & Hex$(udtGUID.Data4(5)) & _
IIf((udtGUID.Data4(6) < &H10), "0", "") & Hex$(udtGUID.Data4(6)) & _
IIf((udtGUID.Data4(7) < &H10), "0", "") & Hex$(udtGUID.Data4(7))
' End If
'End Function
#End If
Public Sub sGenerateGUID()
MsgBox GenerateGUID ' NewGUID
End Sub
Public Sub sFormatGet()
Call fFormatGet(Selection)
End Sub
Public Function fRangeR1C1(ByVal oXlRng As Excel.Range, _
Optional ByVal oXlRef As Excel.Range = Nothing) As String
Dim lgC As Long
Dim lgR As Long
Dim strRngR1C1 As String
If oXlRef Is Nothing Then
Set oXlRef = ActiveSheet.Cells(1, 1)
End If
lgR = oXlRng.Row
lgC = oXlRng.Column
fRangeR1C1 = strRngR1C1
End Function
Public Function fFormatGet(ByRef oXlRng As Excel.Range, _
Optional ByVal ReferenceStyle As XlReferenceStyle = xlA1) As Boolean
If oXlRng Is Nothing Then
Set oXlRng = Selection.Cells
End If
Dim oXlCell As Excel.Range
Dim lgBorder As Long
Dim iFileOut As Integer
Dim bFormat As Boolean
Dim bRange As Boolean
Dim strRange As String
Close
iFileOut = VBA.FreeFile()
Open VBA.Environ$("UserProfile") & "\Documents\" & "#Format.bas" For Output As #iFileOut
Print #iFileOut, "Private Sub sFormatSet(ByVal xlWsh As Excel.Worksheet)"
Print #iFileOut, " 'Dim oXlCell As Excel.Range"
Print #iFileOut, ""
Print #iFileOut, " With xlWsh"
For Each oXlCell In oXlRng.Cells
bFormat = False
bRange = False
If oXlCell.MergeCells Then
' only if cell is the left-top most cell in merge area,...
If oXlCell.MergeArea.Cells(1, 1).Address = oXlCell.Address Then
bFormat = True
oXlCell.MergeArea.Merge
bRange = True
strRange = ".Range(""" & oXlCell.MergeArea.Address & """)"
'If ReferenceStyle = xlA1 Then
' strRange = .Formula
'Else
' strRange = fRangeR1C1(oXlCell.MergeArea)
'End If
End If
Else
bFormat = True
strRange = ".Cells(" & oXlCell.Row & ", " & oXlCell.Column & ")"
'If ReferenceStyle = xlA1 Then
' strRange = .Formula
'Else
' strRange = fRangeR1C1(oXlCell)
'End If
End If
If bFormat Then
Print #iFileOut, " With " & strRange
Print #iFileOut, " .Merge"
If oXlCell.Formula <> vbNullString Then
'If ReferenceStyle = xlA1 Then
Print #iFileOut, " .Formula = " & VBA.Replace(oXlCell.Formula, """", """""")
'Else
' Print #iFileOut, " .Formula = " & VBA.Replace(oXlCell.FormulaR1C1, """", """""")
'End If
End If
With oXlCell
If .IndentLevel <> 0 Then
Print #iFileOut, " .IndentLevel = " & .IndentLevel
End If
With .Font
Print #iFileOut, " With .Font"
Print #iFileOut, " .Name = """ & .Name & """"
Print #iFileOut, " .Color = " & .Color
Print #iFileOut, " .Size = " & .Size
If .Bold Then Print #iFileOut, " .Bold = " & .Bold
If .Italic Then Print #iFileOut, " .Italic = " & .Italic
If .Underline <> xlNone Then Print #iFileOut, " .Underline = " & VBA.CBool(.Underline)
If .Strikethrough Then Print #iFileOut, " .Strikethrough = " & VBA.CBool(.Strikethrough)
If .Subscript Then Print #iFileOut, " .Subscript = " & VBA.CBool(.Subscript)
If .Superscript Then Print #iFileOut, " .Superscript = " & VBA.CBool(.Superscript)
Print #iFileOut, " End With"
End With
If .Hyperlinks.Count > 0 Then
With .Hyperlinks(1)
Print #iFileOut, " .Hyperlinks.Add(" & _
" Anchor:=" & oXlCell & ", " & _
VBA.IIf(.Address = vbNullString, "", " Address:=" & .Address & ", ") & _
VBA.IIf(.SubAddress = vbNullString, "", " SubAddress:=" & .SubAddress & ", ") & _
VBA.IIf(.ScreenTip = vbNullString, "", " ScreenTip:=" & .ScreenTip & ", ") & _
VBA.IIf(.TextToDisplay = vbNullString, "", " TextToDisplay:=" & .TextToDisplay & ", ") & _
")"
End With
End If
Print #iFileOut, " .NumberFormat = """ & .NumberFormat & """"
Print #iFileOut, " .Orientation = " & .Orientation
Print #iFileOut, " .ShrinkToFit = " & .ShrinkToFit
With .Interior
Print #iFileOut, " With .Interior"
If .ColorIndex <> xlNone Then Print #iFileOut, " .ColorIndex = " & .ColorIndex
If .PatternColor <> 0 Then Print #iFileOut, " .PatternColor = " & .PatternColor
If .Pattern <> xlNone Then Print #iFileOut, " .Pattern = " & .Pattern
Print #iFileOut, " End With"
End With
End With
For lgBorder = xlEdgeLeft To xlEdgeRight
With oXlCell.Borders(lgBorder)
Print #iFileOut, " With .Borders(" & lgBorder & ")"
Print #iFileOut, " .LineStyle = " & .LineStyle
'Print #iFileOut, " .ThemeColor = " & .ThemeColor
If .TintAndShade <> 0 Then Print #iFileOut, " .TintAndShade = " & .TintAndShade
If .Color <> 0 Then Print #iFileOut, " .Color = " & .Color
Print #iFileOut, " .Weight = " & .Weight
Print #iFileOut, " End With"
End With
Next lgBorder
Print #iFileOut, " End With"
Print #iFileOut, ""
End If
Next oXlCell
Print #iFileOut, " End With"
Print #iFileOut, "End Sub"
Close #iFileOut
End Function