• Práce s Excel tabulkami

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

Přidat věk ze začátku opakování v den narození…

Sub VěkDoKalendáře()

  Dim contacts As MAPIFolder
  Dim a As AppointmentItem
  Dim r As RecurrencePattern
  Dim o As AppointmentItem
   
  Dim born As Date
  
  
    Set contacts = Session.PickFolder
     
    For i = contacts.Items.Count To 1 Step -1
        Set a = contacts.Items(i)
        If a.IsRecurring And a.Start < #1/1/2004# Then
           born = DateAdd("yyyy", 9, a.Start)
           Set r = a.GetRecurrencePattern()
           l = 9
           
           While born < #1/1/2021#
            born = DateAdd("yyyy", 1, born)
            l = l + 1
            If born >= #1/1/2000# Then
            Set o = r.GetOccurrence(born)
            o.Location = l & " let" ' (" & DatePart("yyyy", a.Start) & ")"
            o.Save
            End If
           Wend
            
        End If
    Next i
End Sub

Public Const FilePath As String = "I:\Desktop\paths.txt"

Public Sub ExportCurrentSlidePaths()

Dim s As Slide
Dim e As Effect
Dim b As AnimationBehavior

Dim eI As Integer
Dim bI As Integer

Set s = Application.ActiveWindow.View.Slide

Open FilePath For Output As #1

eI = 1
For Each e In s.TimeLine.MainSequence
    bI = 1
    
    For Each b In e.Behaviors
        Debug.Print eI & vbTab & bI & vbTab & b.MotionEffect.Path & vbTab & e.DisplayName
        Print #1, eI & vbTab & bI & vbTab & b.MotionEffect.Path & vbTab & e.DisplayName
        bI = bI + 1
    Next b
    
    eI = eI + 1
Next e

Close #1

End Sub

Public Sub ImportCurrentSlidePaths()

Dim line As String
Dim tokens() As String

Dim eI As Integer
Dim bI As Integer
Dim motionPath As String

Open FilePath For Input As #1
While Not EOF(1)
 Line Input #1, line
 
 tokens = Split(line, vbTab)
 eI = CInt(tokens(0))
 bI = CInt(tokens(1))
 motionPath = tokens(2)
 
 Application.ActiveWindow.View.Slide.TimeLine.MainSequence(eI).Behaviors(bI).MotionEffect.Path = motionPath
Wend

Close #1

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