Posts by don22

don22 · May 14th 2021

I couldn't find much out there for information on the serviceids for linked data types so I thought I would post this. These are the serviceid's for the Excel linked data types. I created it as an enum so you reference it ServiceID.xxxxx. This way when you type serviceid with a period folowing it, it will display a list of the ids for you to select.

To use linked data types in VBA you would use the following statement:

Range.ConvertToLinkedDataType ServiceID:=268435456, LanguageCulture:="en-US".

To see what each linked data type provides please see this article by Microsoft.

As of this writing I believe the only LanguageCulture supported is "en-us".

This list is current as of 5/14/21. As other linked data types are added I will try to keep this updated.

Code

    Public Enum ServiceID
        Anatomy = 1911554304
        Animals = 1374683392
        Automatic = 268435712
        Chemistry = 1073742080
        Cities = 1107296512
        Currencies = 268435462
        Food = 1342177536
        Geography = 536870912
        Locations = 536871168
        Medical = 1578106624
        Movies = 1879047930
        People = 1610612480
        Plants = 504364800
        Stocks = 268435456
        Space = 805306624
        Terrain = 1375731968
        Universities = 536871218
        Yoga = 838861056
    End Enum

Display More

don22 · May 14th 2021

I used code that was supplied by Cory from this thread mouse-wheel-scroll-userform. I adapted it for 64 bit use. It partially works. It will scroll up but not down and it scrolls up for both up and down wheel movement. Here is the code.

Code

Option Explicit

'   Based on code from Peter Thornton here:
'   http://social.msdn.microsoft.com/Forums/en-US/7d584120-a929-4e7c-9ec2-9998ac639bea/mouse-scroll-in-userform-listbox-in-excel-2010?forum=isvvba
'   https://www.ozgrid.com/forum/index.php?thread/128354-mouse-wheel-scroll-userform/

'   Defince constants

    Private Const WH_MOUSE_LL As Long = 14
    Private Const WM_MOUSEWHEEL As Long = &H20A
    Private Const HC_ACTION As Long = 0
    Private Const GWL_HINSTANCE As Long = (-6)

    Private Const WM_KEYDOWN As Long = &H100
    Private Const WM_KEYUP As Long = &H101
    Private Const VK_UP As Long = &H26
    Private Const VK_DOWN As Long = &H28
    Private Const WM_LBUTTONDOWN As Long = &H201

    Private Const cSCROLLCHANGE As Long = 10

'   Define types for API calls

    Private Type POINTAPI
        x As Long
        y As Long
    End Type
    
#If Win64 Then
    Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As LongPtr
        wHitTestCode As Long
        dwExtraInfo As LongPtr
    End Type
#Else
    Private Type MOUSEHOOKSTRUCT
        pt As POINTAPI
        hwnd As Long
        wHitTestCode As Long
        dwExtraInfo As Long
    End Type
#End If

'   Delclare API functions

#If Win64 Then
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As LongPtr
        
    Private Declare PtrSafe Function GetWindowLong Lib "user32" Alias "GetWindowLongPtrA" ( _
        ByVal hwnd As LongPtr, _
        ByVal nIndex As Long) As LongPtr
    
    Private Declare PtrSafe Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As LongPtr, _
        ByVal hmod As LongPtr, _
        ByVal dwThreadId As Long) As LongPtr

    Private Declare PtrSafe Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As LongPtr, _
        ByVal ncode As Long, _
        ByVal wParam As LongPtr, _
        lParam As Any) As LongPtr
        
    Private Declare PtrSafe Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hhk As LongPtr) As Long
        
    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 WindowFromPoint Lib "user32" ( _
        ByVal Point As LongLong) As LongPtr
        
    Private Declare PtrSafe Function GetCursorPos Lib "user32" ( _
        lpPoint As POINTAPI) As Long
        
    Private Declare PtrSafe Function GetActiveWindow Lib "user32" () As LongPtr
#Else
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
        ByVal lpClassName As String, _
        ByVal lpWindowName As String) As Long
    
    Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" ( _
        ByVal hwnd As Long, _
        ByVal nIndex As Long) As Long
    
    Private Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" ( _
        ByVal idHook As Long, _
        ByVal lpfn As Long, _
        ByVal hmod As Long, _
        ByVal dwThreadId As Long) As Long
    
    Private Declare Function CallNextHookEx Lib "user32" ( _
        ByVal hHook As Long, _
        ByVal nCode As Long, _
        ByVal wParam As Long, _
        lParam As Any) As Long
    
    Private Declare Function UnhookWindowsHookEx Lib "user32" ( _
        ByVal hHook As Long) 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 WindowFromPoint Lib "user32" ( _
        ByVal xPoint As Long, _
        ByVal yPoint As Long) As Long
    
    Private Declare Function GetCursorPos Lib "user32.dll" ( _
        ByRef lpPoint As POINTAPI) As Long
        
    Declare Function GetActiveWindow Lib "user32" () As Long
#End If

'   Define variables

#If Win64 Then
    Private mFormHwnd As LongPtr
    Private mLngMouseHook As LongPtr
#Else
    Private mFormHwnd As Long
    Private mLngMouseHook As Long
#End If

    Private mbHook As Boolean

    Dim mForm As Object

Display More

Code

Sub HookFormScroll(oForm As Object)

#If Win64 Then
    Dim hwndUnderCursor As LongPtr
    Dim lngAppInst As LongPtr
#Else
    Dim hwndUnderCursor As Long
    Dim lngAppInst As Long
#End If
    
    Set mForm = oForm
    hwndUnderCursor = FindWindow("ThunderDFrame", oForm.Caption)
    Debug.Print "Form window: " & hwndUnderCursor
    If mFormHwnd <> hwndUnderCursor Then
        UnhookFormScroll
        Debug.Print "Unhook old proc"
        mFormHwnd = hwndUnderCursor
        lngAppInst = GetWindowLong(mFormHwnd, GWL_HINSTANCE)
        If Not mbHook Then
            mLngMouseHook = SetWindowsHookEx( _
            WH_MOUSE_LL, AddressOf MouseProc, lngAppInst, 0)
            mbHook = mLngMouseHook <> 0
            If mbHook Then Debug.Print "Form hooked"
        End If
    End If
    
End Sub

Display More

Code

#If Win64 Then
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As LongPtr
#Else
    Private Function MouseProc(ByVal ncode As Long, ByVal wParam As Long, ByRef lParam As MOUSEHOOKSTRUCT) As Long
#End If

    On Error GoTo errH 'Resume Next
    
    If (ncode = HC_ACTION) Then
        If GetActiveWindow = mFormHwnd Then
            If wParam = WM_MOUSEWHEEL Then
                MouseProc = True
                'Debug.Print lParam.hwnd
                If lParam.hwnd > 0 Then
                    mForm.ScrollTop = Application.Max(0&, mForm.ScrollTop - cSCROLLCHANGE)
                Else
                    mForm.ScrollTop = Application.Min(mForm.ScrollHeight - mForm.InsideHeight, mForm.ScrollTop + cSCROLLCHANGE)
                End If
                Exit Function
            End If
        End If
    End If
    
    MouseProc = CallNextHookEx(mLngMouseHook, ncode, wParam, ByVal lParam)
    Exit Function
    
errH:

    UnhookFormScroll
    
End Function

Display More

Code

Sub UnhookFormScroll()

    If mbHook Then
        UnhookWindowsHookEx mLngMouseHook
        mLngMouseHook = 0
        mFormHwnd = 0
        mbHook = False
    End If
    
End Sub

Anyone see what is wrong?

Thanks

don22 · Mar 2nd 2021

Hi Pike,

Thanks for posting. It is almost what I am looking for. A few issues with

Code

 ^(http|ftp|https?:\/\/)?([\da-z\.-]+)\.([a-z\.]{2,6})([\/\w \.-]*)*\/?$

I used https://regex101.com/ to validate the expression and found the following issues

Allows anything to be entered for TLD
Does not work for ftp
Does not work for the URL to this post - https://www.ozgrid.com/forum/index.php?thread/1229139-regex-expression-to-validate-urls-and-email-addresses/&postID=1245552#post1245552
More than 2 forward slashes (//) following the :
- http:///www.abc.com
- http:///////www.abc.com
Beginning address with one or more forward slashes (/)
- /www.abc.com
://www.abc.com

Getting closer. I changed it to the following and now it works for all of the above except # 6.

Code

^((http|ftp|https)?:\/\/)?([a-z|0-9])([\da-z\/\.-]+)\.(com|edu|org|gov)([\/\w \?\&\=\#\.-]*)*\/?$

I turned on the flag for testing case insensitivity. In VBA as you would add ".ignorecase = true" to your code.

Just need to figure out how to handle # 6.

Added bonus is to allow IP addresses to be entered instead of "www.abc.com". Not needed but probably an interesting exercise as you would have to test for valid ranges. IP addresses are entered as you would normally express them but I believe that IPV6 addresses need to be enclosed in brackets "[]".

don22 · Mar 1st 2021

Quote from Carim

Re,

If RegExp can be used for emails ... regarding Valid URLS ... there is the need to test them ...

See code designed by Leith

Code

' Written: April 29, 2012
' Author:  Leith Ross
' Summary: Returns the status for a URL along with the Page Source HTML text.

Public PageSource As String
Public httpRequest As Object

Function GetURLStatus(ByVal URL As String, Optional AllowRedirects As Boolean)

    Const WinHttpRequestOption_EnableRedirects = 6
  
  
        If httpRequest Is Nothing Then
            On Error Resume Next
                Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5.1")
                If httpRequest Is Nothing Then
                    Set httpRequest = CreateObject("WinHttp.WinHttpRequest.5")
                End If
            Err.Clear
            On Error GoTo 0
        End If

        ' Control if the URL being queried is allowed to redirect.
          httpRequest.Option(WinHttpRequestOption_EnableRedirects) = AllowRedirects

        ' Clear any pervious web page source information
          PageSource = ""
    
        ' Add protocol if missing
          If InStr(1, URL, "://") = 0 Then
             URL = "http://" & URL
          End If

             ' Launch the HTTP httpRequest synchronously
               On Error Resume Next
                  httpRequest.Open "GET", URL, False
                  If Err.Number <> 0 Then
                   ' Handle connection errors
                     GetURLStatus = Err.Description
                     Err.Clear
                     Exit Function
                  End If
               On Error GoTo 0
           
             ' Send the http httpRequest for server status
               On Error Resume Next
                  httpRequest.Send
                  httpRequest.WaitForResponse
                  If Err.Number <> 0 Then
                   ' Handle server errors
                     PageSource = "Error"
                     GetURLStatus = Err.Description
                     Err.Clear
                  Else
                   ' Show HTTP response info
                     GetURLStatus = httpRequest.Status & " - " & httpRequest.StatusText
                   ' Save the web page text
                     PageSource = httpRequest.ResponseText
                  End If
               On Error GoTo 0
            
End Function

Sub ValidateURLs()

    Dim Cell As Range
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Status As String
    Dim Wks As Worksheet
    
        Set Wks = ActiveSheet
        Set Rng = Wks.Range("F2")
        
        Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
        If RngEnd.Row < Rng.Row Then Exit Sub Else Set Rng = Wks.Range(Rng, RngEnd)
        
            For Each Cell In Rng
                Status = GetURLStatus(Cell)
                If Status <> "200 - OK" Then
                   Cell = Status
                End If
            Next Cell
        
End Sub

Display More

Hope this will help

Display More

Thanks again. A little more than I was looking for but good. I'll still come up with a Regex that will validate that a URL contains a valid (optional) Scheme (http:, https:, ftp:, ...) and a valid TLD. When i have it I will share..

don22 · Mar 1st 2021

Quote from Carim
Hello,

Regarding e-mail addresses, the best solution is to use the UDF designed by Jindon ...
Code
Function IsEmailAddress(txt As String) As Boolean
With CreateObject("VBScript.RegExp")
 .Pattern = "^[\w-\.][email protected]([\w-]+\.)+[A-Za-z]{2,3}$"
 IsEmailAddress = .test(txt)
End With
End Function
Hope this will help
Display More

Thanks for the reply.

While this will validate if an email address is properly formatted it does not validate that the Top Level Domain (TLD) or extension is valid. I modified the pattern to the following.

Code

^[\w-\.][email protected]([\w-]+\.)+(com|edu|org|gov)$

This will not only validate that the email address is properly formatted but that it contains a valid TLD. The TLD list can be modified to meet your needs.

don22 · Feb 26th 2021

I am looking for routines to validate URLs and email addresses. Searching the web 99% of the answers involve using regular expressions.I know what regex are but am not familiar with structuring the expressions. The examples I have found don't take into account the fact that certain portions of the URL must be specific values. For example the beginning part of a URL, if present, must be HTTP, HTTPS, FTP, etc. Also the extension part of the domain name must be com, edu, org, etc.

Valid examples:

http://www.somedomain.com

http://www.somedomain.com/something1/something2/...

Invalid examples:

htttp://www.somedomain.com

http://www.somedomain.comm

The filters I have found would say the invalid examples are ok. Does anyone have regex expressions that take the ICANN (I beleive it is this org) rules for URLs and email addresses into account?

Thanks

Don

don22 · Feb 19th 2021

I running this at work on a 12 year old PC running Windows 7 and a not up to date office version. I’ll have to try it at home which has current hardware and software to see what the timings are.

Thanks for the assistance.

don22 · Feb 18th 2021

Roy, this is the same code as mine. Same results.

don22 · Feb 18th 2021

Typo in the code section in the original post. Corrected.

Code

Public Function SpellCheck(ByRef SC_TextBox As MSForms.TextBox) As Boolean

 Dim varWords As Variant
 Dim ndx As Long
 Dim lngLen As Long
 
 varWords = Split(SC_TextBox.Text, " ")

 For ndx = LBound(varWords) To UBound(varWords)
 If Not Application.CheckSpelling(Word:=varWords(ndx), IgnoreUppercase:=True) Then
 With SC_TextBox
 .SelStart = lngLen
 .SelLength = Len(varWords(ndx))
 .SetFocus
 End With
 SpellCheck = False
 Exit Function
 Else
 lngLen = lngLen + Len(varWords(ndx)) + 1
 End If
 Next ndx
 
 SpellCheck = True
 
End Function

Display More

don22 · Feb 18th 2021

Searching I found code to spell check a text box on a userform. I created the following function.

Code

Public Function SpellCheck(ByRef SC_TextBox As MSForms.TextBox) As Boolean

    Dim varWords As Variant
    Dim ndx As Long
    Dim lngLen As Long
    
    varWords = Split(SDebug.Print Timer
    For ndx = LBound(varWords) To UBound(varWords)
        If Not Application.CheckSpelling(Word:=varWords(ndx), IgnoreUppercase:=True) Then
            With SC_TextBox
                .SelStart = lngLen
                .SelLength = Len(varWords(ndx))
                .SetFocus
            End With
            SpellCheck = False
            Exit Function
        Else
            lngLen = lngLen + Len(varWords(ndx)) + 1
        End If
    Next ndx
    
    SpellCheck = True
    
End Function

Display More

It works fine except that it is very slow. With everything spelled correctly a text box with 34 words takes 27 seconds to run. One with 11 words takes 10 seconds. It is the Application.CheckSpelling that is taking a long time. Anyone have any suggestions on speeding this up?

Thanks

Don

don22 · Jan 28th 2021

I have a class module that is used to send emails via Outlook from Excel. I would like to present the user a list of email accounts to send from. I know how to get the number of accounts and the email address from Outlook. Since class modules are supposed to be self contained how can I present this list to a user from the class module?

Thanks

Don

Posts by don22

Excel VBA Linked Data Types - ServiceId

Mouse Wheel Scroll

Regex expression to validate URLs and email addresses

Regex expression to validate URLs and email addresses

Regex expression to validate URLs and email addresses

Regex expression to validate URLs and email addresses

Spell Checking TextBox on UserForm

Spell Checking TextBox on UserForm

Spell Checking TextBox on UserForm

Spell Checking TextBox on UserForm

Dropdown list from class module