GetKeyboardLayoutList na MSDN

Private Declare Function GetKeyboardLayoutList Lib "User32.dll" (ByVal nBuff As Long, ByRef lpList As Long) As Long

Public Function GetKeyboardLayouts() As Long()
Dim NumLayouts As Long
Dim Layouts() As Long
 
NumLayouts = GetKeyboardLayoutList(0, ByVal 0&)
 
If (NumLayouts) Then
 ReDim Layouts(NumLayouts - 1) As Long
 
 GetKeyboardLayoutList NumLayouts, Layouts(0)
 GetKeyboardLayouts = Layouts
End If

End Function

ActivateKeyboardLayout na MSDN

Private Declare Function ActivateKeyboardLayout Lib "user32" (ByVal HKL As Long, ByVal Flags As Long) As Long

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Select Case Target.Column
 Case 1
  ActivateKeyboardLayout &H4490449, &H100
 Case 2
  ActivateKeyboardLayout &HF0050405, &H100
End Select

End Sub

Seznam LCID (které, ovšem, nemá s klávesnicemi nic společného)

Sub ExportSelectedMailItems()

    Dim Selection As Selection
    Dim Mail As MailItem

    Set Selection = ActiveExplorer.Selection

    For Each Mail In Selection

        Subject = Mail.Subject
        Body = Mail.HTMLBody
        Received = Mail.ReceivedTime

        FilePath = Subject & ".html"

        MakeSureDirectoryPathExists FilePath
        Open FilePath For Output As #1
            Print #1, Body
        Close #1
    Next

End Sub

Možná to tak trochu funguje jen při krokování…

Const EmptyDate As Date = #1/1/4501#
Sub AddBirthdaysAnniversaries()
 
    Dim a As Date, b As Date
    
    Dim contacts As MAPIFolder
    Set contacts = Session.PickFolder
     
    For i = contacts.Items.Count To 1 Step -1
    If contacts.Items(i).Class = 40 Then
         b = contacts.Items(i).Birthday
         If b <> EmptyDate Then
            contacts.Items(i).Birthday = Now
            contacts.Items(i).Birthday = b
         End If
         a = contacts.Items(i).Anniversary
         If a <> EmptyDate Then
            contacts.Items(i).Anniversary = Now
            contacts.Items(i).Anniversary = a
         End If
            
         If b <> EmptyDate Or a <> EmptyDate Then
         contacts.Items(i).Save
         contacts.Items(i).Close olSave
         End If
    End If
    Next i
 
End Sub

Function TrimLeft(s As String, c As String)
While Len(c) < Len(s)
 If Left(s, Len(c)) <> c Then GoTo EndFunction
 s = Mid(s, Len(c) + 1)
Wend

EndFunction:
TrimLeft = s
End Function

Function TrimRight(s As String, c As String)
While Len(c) < Len(s)
 If Right(s, Len(c)) <> c Then GoTo EndFunction
 s = Left(s, Len(s) - Len(c))
Wend

EndFunction:
TrimRight = s
End Function

Function TrimBoth(s As String, c As String)
s = TrimLeft(s, c)
s = TrimRight(s, c)
TrimBoth = s
End Function

Jako složku bere do posledního lomítka.

Declare PtrSafe Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal path As String) As Long