' Create a variable to hold number of Visual Basic forms loaded 
' and visible.
Dim I, OpenForms
For I = 1 To 150000    ' Start loop.
    If I Mod 1000 = 0 Then     ' If loop has repeated 1000 times.
        OpenForms = DoEvents    ' Yield to operating system.
    End If
Next I    ' Increment loop counter.







Private Sub CommandButton1_Click()
  TextBox1 = "Texte 1"
  DoEvents
  For i = 1 To 50000000: Next
  TextBox2 = "Texte 2"
  DoEvents
  For i = 1 To 50000000: Next
  TextBox3 = "Texte 3"
End Sub



Option Explicit

Private Sub Form_Load()
    Module1.FillListWithFonts List1
End Sub




'Font enumeration types
Public Const LF_FACESIZE = 32
Public Const LF_FULLFACESIZE = 64

Type LOGFONT
        lfHeight As Long
        lfWidth As Long
        lfEscapement As Long
        lfOrientation As Long
        lfWeight As Long
        lfItalic As Byte
        lfUnderline As Byte
        lfStrikeOut As Byte
        lfCharSet As Byte
        lfOutPrecision As Byte
        lfClipPrecision As Byte
        lfQuality As Byte
        lfPitchAndFamily As Byte
        lfFaceName(LF_FACESIZE) As Byte
End Type

Type NEWTEXTMETRIC
        tmHeight As Long
        tmAscent As Long
        tmDescent As Long
        tmInternalLeading As Long
        tmExternalLeading As Long
        tmAveCharWidth As Long
        tmMaxCharWidth As Long
        tmWeight As Long
        tmOverhang As Long
        tmDigitizedAspectX As Long
        tmDigitizedAspectY As Long
        tmFirstChar As Byte
        tmLastChar As Byte
        tmDefaultChar As Byte
        tmBreakChar As Byte
        tmItalic As Byte
        tmUnderlined As Byte
        tmStruckOut As Byte
        tmPitchAndFamily As Byte
        tmCharSet As Byte
        ntmFlags As Long
        ntmSizeEM As Long
        ntmCellHeight As Long
        ntmAveWidth As Long
End Type

' ntmFlags field flags
Public Const NTM_REGULAR = &H40&
Public Const NTM_BOLD = &H20&
Public Const NTM_ITALIC = &H1&

'  tmPitchAndFamily flags
Public Const TMPF_FIXED_PITCH = &H1
Public Const TMPF_VECTOR = &H2
Public Const TMPF_DEVICE = &H8
Public Const TMPF_TRUETYPE = &H4

Public Const ELF_VERSION = 0
Public Const ELF_CULTURE_LATIN = 0

'  EnumFonts Masks
Public Const RASTER_FONTTYPE = &H1
Public Const DEVICE_FONTTYPE = &H2
Public Const TRUETYPE_FONTTYPE = &H4

Declare Function EnumFontFamilies Lib "gdi32" Alias _
     "EnumFontFamiliesA" _
     (ByVal hDC As Long, ByVal lpszFamily As String, _ 
     ByVal lpEnumFontFamProc As Long, LParam As Any) As Long
Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, _
     ByVal hDC As Long) As Long

Function EnumFontFamProc(lpNLF As LOGFONT, lpNTM As NEWTEXTMETRIC, _ 
     ByVal FontType As Long, LParam As ListBox) As Long
Dim FaceName As String
Dim FullName As String
    FaceName = StrConv(lpNLF.lfFaceName, vbUnicode)
    LParam.AddItem Left$(FaceName, InStr(FaceName, vbNullChar) - 1)
    EnumFontFamProc = 1
End Function

Sub FillListWithFonts(LB As ListBox)
Dim hDC As Long
    LB.Clear
    hDC = GetDC(LB.hWnd)
    EnumFontFamilies hDC, vbNullString, AddressOf EnumFontFamProc, LB
    ReleaseDC LB.hWnd, hDC
End Sub



Sub ClassNamer()
    Dim MyClasses As New Collection    ' Create a Collection object.
    Dim Num    ' Counter for individualizing keys.
    Dim Msg As String    ' Variable to hold prompt string.
    Dim TheName, MyObject, NameList    ' Variants to hold information.
    Do
        Dim Inst As New Class1    ' Create a new instance of Class1.
        Num = Num + 1    ' Increment Num, then get a name.
        Msg = "Please enter a name for this object." & vbNewLine _
         & "Press Cancel to see names in collection."
        TheName = InputBox(Msg, "Name the Collection Items")
        Inst.InstanceName = TheName    ' Put name in object instance.
        ' If user entered name, add it to the collection.
        If Inst.InstanceName <> "" Then
            ' Add the named object to the collection.
            MyClasses.Add item := Inst, key := CStr(Num)
        End If
        ' Clear the current reference in preparation for next one.
        Set Inst = Nothing
    Loop Until TheName = ""
    For Each MyObject In MyClasses    ' Create list of names.
        NameList = NameList & MyObject.InstanceName & vbNewLine
    Next MyObject
    ' Display the list of names in a message box.
    MsgBox NameList, , "Instance Names In MyClasses Collection"

    For Num = 1 To MyClasses.Count    ' Remove name from the collection.
        MyClasses.Remove 1    ' Since collections are reindexed automatically, remove the first member on each iteration.
    Next
End Sub



Module Multiline
    Public Sub Main()
        'Create a Random object to seed our starting value 
        Dim randomizer As New Random()
        'set our variable
        Dim count As Integer = randomizer.Next(0, 5)

        Dim message As String

        'If count is zero, output will be no items
        If count = 0 Then
            message = "There are no items."
        'If count is 1, output will be "There is 1 item.".        
        ElseIf count = 1 Then
            message = "There is 1 item."
        'If count is greater than 1, output will be "There are {count} items.", where {count} is replaced by the value of count. 
        Else
            message = $"There are {count} items."
        End If

        Console.WriteLine(message)
    End Sub
End Module



Module Nested
    Public Sub Main() 
        ' Run the function as part of the WriteLine output.
        Console.WriteLine("Time Check is " & CheckIfTime() & ".")     
    End Sub

    Private Function CheckIfTime() As Boolean
        ' Determine the current day of week and hour of day.
        Dim dayW As DayOfWeek = DateTime.Now.DayOfWeek
        Dim hour As Integer = DateTime.Now.Hour

        ' Return True if Wednesday from 2 to 3:59 P.M.,
        ' or if Thursday from noon to 12:59 P.M.
        If dayW = DayOfWeek.Wednesday Then
            If hour = 14 Or hour = 15 Then
                Return True
            Else
                Return False
            End If
        ElseIf dayW = DayOfWeek.Thursday Then
            If hour = 12 Then
                Return True
            Else
                Return False
            End If
        Else
            Return False
        End If
    End Function
End Module

Module SingleLine
    Public Sub Main()

        'Create a Random object to seed our starting values 
        Dim randomizer As New Random()

        Dim A As Integer = randomizer.Next(10, 20)
        Dim B As Integer = randomizer.Next(0, 20)
        Dim C As Integer = randomizer.Next(0, 5)

        'Let's display the initial values for comparison
        Console.WriteLine($"A value before If: {A}")
        Console.WriteLine($"B value before If: {B}")
        Console.WriteLine($"C value before If: {C}")

        ' If A > 10, execute the three colon-separated statements in the order
        ' that they appear
        If A > 10 Then A = A + 1 : B = B + A : C = C + B

        'If the condition is true, the values will be different
        Console.WriteLine($"A value after If: {A}")
        Console.WriteLine($"B value after If: {B}")
        Console.WriteLine($"C value after If: {C}")

    End Sub
End Module


Private Sub AddCustomer()
    Dim theCustomer As New Customer

    With theCustomer
        .Name = "Coho Vineyard"
        .URL = "http://www.cohovineyard.com/"
        .City = "Redmond"
    End With

    With theCustomer.Comments
        .Add("First comment.")
        .Add("Second comment.")
    End With
End Sub

Public Class Customer
    Public Property Name As String
    Public Property City As String
    Public Property URL As String

    Public Property Comments As New List(Of String)
End Class


Dim theWindow As New EntryWindow

With theWindow
    With .InfoLabel
        .Content = "This is a message."
        .Foreground = Brushes.DarkSeaGreen
        .Background = Brushes.LightYellow
    End With

    .Title = "The Form Title"
    .Show()
End With


Dim Msg
Err.Clear
On Error Resume Next
Err.Raise 6 ' Generate "Overflow" error.
If Err.Number <> 0 Then
    Msg = "Press F1 or HELP to see " & Err.HelpFile & " topic for" & _
    " the following HelpContext: " & Err. HelpContext
    MsgBox Msg, , "Error: " & Err.Description, Err.HelpFile, _
Err.HelpContext
End If

Private Sub PrintError()
    Dim ErrorNumber As Long, count As Long
    count = 1: ErrorNumber = 1
    On Error GoTo EOSb
    Do While count < 100
        Do While Error(ErrorNumber) = "Application-defined or object-defined error": ErrorNumber = ErrorNumber + 1: Loop
        Debug.Print count & "-Error(" & ErrorNumber & "): " & Error(ErrorNumber)
        ErrorNumber = ErrorNumber + 1
        count = count + 1
    Loop
EOSb: Debug.Print ErrorNumber
End Sub


Dim lst As New List(Of String) _
    From {"abc", "def", "ghi"}

' Iterate through the list.
For Each item As String In lst
    Debug.Write(item & " ")
Next
Debug.WriteLine("")

Dim numberSeq() As Integer =
    {1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12}

For Each number As Integer In numberSeq
    ' If number is between 5 and 7, continue
    ' with the next iteration.
    If number >= 5 And number <= 8 Then
        Continue For
    End If

    ' Display the number.
    Debug.Write(number.ToString & " ")

    ' If number is 10, exit the loop.
    If number = 10 Then
        Exit For
    End If
Next
Debug.WriteLine("")
' Output: 1 2 3 4 9 10


Public Function GetAgePhrase(ByVal age As Integer) As String
    If age > 60 Then Return "Senior"
    If age > 40 Then Return "Middle-aged"
    If age > 20 Then Return "Adult"
    If age > 12 Then Return "Teen-aged"
    If age > 4 Then Return "School-aged"
    If age > 1 Then Return "Toddler"
    Return "Infant"
End Function


Dim threeDimArray(9, 9, 9), twoDimArray(9, 9) As Integer
Erase threeDimArray, twoDimArray
ReDim threeDimArray(4, 4, 9)

On Error Resume Next   ' Defer error handling.  
Error 11   ' Simulate the "Division by zero" error.  


Delegate Function MathOperator( 
    ByVal x As Double, 
    ByVal y As Double 
) As Double

Function AddNumbers( 
    ByVal x As Double, 
    ByVal y As Double 
) As Double
    Return x + y
End Function

Function SubtractNumbers( 
    ByVal x As Double, 
    ByVal y As Double
) As Double
    Return x - y
End Function

Sub DelegateTest( 
    ByVal x As Double, 
    ByVal op As MathOperator, 
    ByVal y As Double 
)
    Dim ret As Double
    ret = op.Invoke(x, y) ' Call the method.
    MsgBox(ret)
End Sub

Protected Sub Test()
    DelegateTest(5, AddressOf AddNumbers, 3)
    DelegateTest(9, AddressOf SubtractNumbers, 3)
End Sub




Public Function GetFolders() As String
    ' Create a new StringBuilder, which is used
    ' to efficiently build strings.
    Dim sb As New System.Text.StringBuilder

    Dim dInfo As New System.IO.DirectoryInfo("c:\")

    ' Obtain an array of directories, and iterate through
    ' the array.
    For Each dir As System.IO.DirectoryInfo In dInfo.GetDirectories()
        sb.Append(dir.Name)
        sb.Append(Microsoft.VisualBasic.ControlChars.CrLf)
    Next

    Return sb.ToString
End Function



Imports systxt = System.Text
Imports sysio = System.IO
Imports ch = Microsoft.VisualBasic.ControlChars

Public Function GetFolders() As String
    Dim sb As New systxt.StringBuilder

    Dim dInfo As New sysio.DirectoryInfo("c:\")
    For Each dir As sysio.DirectoryInfo In dInfo.GetDirectories()
        sb.Append(dir.Name)
        sb.Append(ch.CrLf)
    Next

    Return sb.ToString
End Function


Class simpleMessageList
    Public messagesList() As String = New String(50) {}
    Public messagesLast As Integer = -1
    Private messagesLock As New Object
    Public Sub addAnotherMessage(ByVal newMessage As String)
        SyncLock messagesLock
            messagesLast += 1
            If messagesLast < messagesList.Length Then
                messagesList(messagesLast) = newMessage
            End If
        End SyncLock
    End Sub
End Class


Public Class doubleMessageList
    Inherits simpleMessageList
    ' Add code to override, overload, or extend members 
    ' inherited from the base class.
    ' Add new variable, property, procedure, and event declarations.
	Public Sub Coucou()
		X=3
	End Sub
End Class

Public Sub RunSample()
    Try
        CreateException()
    Catch ex As System.IO.IOException
        ' Code that reacts to IOException.
    Catch ex As NullReferenceException
        MessageBox.Show("NullReferenceException: " & ex.Message)
        MessageBox.Show("Stack Trace: " & vbCrLf & ex.StackTrace)
    Catch ex As Exception
        ' Code that reacts to any other exception.
    End Try
End Sub

Private Sub CreateException()
    ' This code throws a NullReferenceException.
    Dim obj = Nothing
    Dim prop = obj.Name

    ' This code also throws a NullReferenceException.
    Throw New NullReferenceException("Something happened.")
End Sub

Public Sub TryExample()
    ' Declare variables.
    Dim x As Integer = 5
    Dim y As Integer = 0

    ' Set up structured error handling.
    Try
        ' Cause a "Divide by Zero" exception.
        x = x \ y

        ' This statement does not execute because program
        ' control passes to the Catch block when the
        ' exception occurs.
        MessageBox.Show("end of Try block")
    Catch ex As Exception
        ' Show the exception's message.
        MessageBox.Show(ex.Message)

        ' Show the stack trace, which is a list of methods
        ' that are currently executing.
        MessageBox.Show("Stack Trace: " & vbCrLf & ex.StackTrace)
    Finally
        ' This line executes whether or not the exception occurs.
        MessageBox.Show("in Finally block")
    End Try
End Sub

Private Sub WriteFile()
    Using writer As System.IO.TextWriter = System.IO.File.CreateText("log.txt")
        writer.WriteLine("This is line one.")
        writer.WriteLine("This is line two.")
    End Using
End Sub

Private Sub ReadFile()
    Using reader As System.IO.TextReader = System.IO.File.OpenText("log.txt")
        Dim line As String

        line = reader.ReadLine()
        Do Until line Is Nothing
            Console.WriteLine(line)
            line = reader.ReadLine()
        Loop
    End Using
End Sub

Sub Main()
    Dim theGalaxies As New Galaxies
    For Each theGalaxy In theGalaxies.NextGalaxy
        With theGalaxy
            Console.WriteLine(.Name & "  " & .MegaLightYears)
        End With
    Next
    Console.ReadKey()
End Sub

Public Class Galaxies
    Public ReadOnly Iterator Property NextGalaxy _
    As System.Collections.Generic.IEnumerable(Of Galaxy)
        Get
            Yield New Galaxy With {.Name = "Tadpole", .MegaLightYears = 400}
            Yield New Galaxy With {.Name = "Pinwheel", .MegaLightYears = 25}
            Yield New Galaxy With {.Name = "Milky Way", .MegaLightYears = 0}
            Yield New Galaxy With {.Name = "Andromeda", .MegaLightYears = 3}
        End Get
    End Property
End Class

Public Class Galaxy
    Public Property Name As String
    Public Property MegaLightYears As Integer
End Class

Public Interface IDemo
    Sub DoSomething()
End Interface
Public Class implementIDemo
    Implements IDemo
    Private Sub DoSomething() Implements IDemo.DoSomething
    End Sub
End Class
Dim varAsInterface As IDemo = New implementIDemo()
Dim varAsClass As implementIDemo = New implementIDemo()

