10. Schuljahr Einige Unterrichtsaufgaben in VB aus 2005

'Komponenten:
'Label1: rot
'Label1: blau
'Label3: Balken
'label4: Kästchen außerhalb der Gitters
'Label5: Kästchen außerhalb der Gitters
'line1(0-10): Array von Linien
'line2(0-10): Array von Linien
'Command1
'Command2
'Command3
'Command4
'Command5
'Command6
'Command7
'Command8
Option Explicit
Const ABST = 500

Dim Spieler As Integer

Dim ZelleX1 As Integer
Dim ZelleY1 As Integer

Dim ZelleX2 As Integer
Dim ZelleY2 As Integer


Private Sub Command1_Click()
    Line1(i).X1 = 0
    Line1(i).Y1 = 0
    Line1(i).X2 = ABST
    Line1(i).Y2 = ABST
    
End Sub

Private Sub Command2_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
End Sub

Private Sub Command3_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = i * ABST + (ABST)
        Line1(i).Y1 = ABST
        Line1(i).X2 = i * ABST + (ABST)
        Line1(i).Y2 = (ABST + 10 * ABST)
    Next
End Sub

Private Sub Command4_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
    
    For i = 0 To 10
        Line2(i).X1 = i * ABST + (ABST)
        Line2(i).Y1 = ABST
        Line2(i).X2 = i * ABST + (ABST)
        Line2(i).Y2 = (ABST + 10 * ABST)
    Next

End Sub

Private Sub Command5_Click()
    Label1.Width = ABST * 1
    Label1.Height = ABST * 1
    Label1.Left = ABST + 15
    Label1.Top = ABST + 15
End Sub

Private Sub Command6_Click()
    Label2.Width = ABST * 1
    Label2.Height = ABST * 1
    Label2.Left = 10 * ABST + (15)
    Label2.Top = 10 * ABST + (15)
End Sub

Private Sub Command7_Click()
    Dim kollision As Boolean
    kollision = sprung1(3, 3)
    If kollision Then
        MsgBox "Kollision"
    End If
End Sub

Function sprung1(GitterX, GitterY) As Boolean
    Label1.Left = GitterX * ABST + (15)
    Label1.Top = GitterY * ABST + (15)
    sprung1 = (Label1.Left = Label2.Left) And (Label1.Top = Label2.Top)
End Function

Private Sub Command8_Click()
    Dim kollision As Boolean
    kollision = sprung2(3, 3)
    If kollision Then
        MsgBox "Kollision"
    End If
End Sub

Function sprung2(GitterX, GitterY) As Boolean
    Label2.Left = GitterX * ABST + (15)
    Label2.Top = GitterY * ABST + (15)
    sprung2 = (Label1.Left = Label2.Left) And (Label1.Top = Label2.Top)
End Function




Private Sub Form_Load()
    
    Dim kollision As Boolean
    
    Command1.Caption = "45°"
    Command2.Caption = "Parallel X"
    Command3.Caption = "Parallel Y"
    Command4.Caption = "Gitter"
    Command5.Caption = "label1"
    Command6.Caption = "label2"
    Command7.Caption = "label1 3-3"
    Command8.Caption = "label2 3-3"
    
    Spieler = 1
    Label1.Width = ABST * 0.98
    Label1.Height = ABST * 0.98
    Label2.Width = ABST * 0.98
    Label2.Height = ABST * 0.98
    gitter
    kollision = sprung1(1, 1)
    kollision = sprung2(10, 10)

End Sub
Sub gitter()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
    
    For i = 0 To 10
        Line2(i).X1 = i * ABST + (ABST)
        Line2(i).Y1 = ABST
        Line2(i).X2 = i * ABST + (ABST)
        Line2(i).Y2 = (ABST + 10 * ABST)
    Next
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim kollision As Boolean
    Dim iX, iY As Integer
    iX = Int(X / ABST)
    iY = Int(Y / ABST)
    If X > ABST And X < ABST * 11 And Y > ABST And Y < ABST * 11 Then
        If Button = 1 Then
            Spieler = 2
            Label3.BackColor = Label2.BackColor
            ZelleX1 = iX
            ZelleY1 = iY
            kollision = sprung1(ZelleX1, ZelleY1)
            
        ElseIf Button = 2 Then
            Spieler = 1
            Label3.BackColor = Label1.BackColor
            ZelleX2 = iX
            ZelleY2 = iY
            kollision = sprung2(ZelleX2, ZelleY2)
        End If
        
        label4.Caption = iX
        Label5.Caption = iY
        
    Else
        label4.Caption = "#"
        Label5.Caption = "#"
    End If

End Sub



Private Sub Label1_DblClick()
    Label1.Visible = False
End Sub
Private Sub Label2_DblClick()
    Label2.Visible = False
End Sub



Private Sub Label3_DblClick()
    Label1.Visible = True
    Label2.Visible = True
End Sub

'Komponenten:
'Label1: rot
'Label1: blau
'Label3: Balken
'label4: Kästchen außerhalb der Gitters
'Label5: Kästchen außerhalb der Gitters
'line1(0-10): Array von Linien
'line2(0-10): Array von Linien
'Command1
'Command2
'Command3
'Command4
'Command5
'Command6
'Command7
'Command8
Option Explicit
Const ABST = 500

Dim Spieler As Integer

Dim ZelleX1 As Integer
Dim ZelleY1 As Integer

Dim ZelleX2 As Integer
Dim ZelleY2 As Integer


Private Sub Command1_Click()
    Line1(i).X1 = 0
    Line1(i).Y1 = 0
    Line1(i).X2 = ABST
    Line1(i).Y2 = ABST
    
End Sub

Private Sub Command2_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
End Sub

Private Sub Command3_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = i * ABST + (ABST)
        Line1(i).Y1 = ABST
        Line1(i).X2 = i * ABST + (ABST)
        Line1(i).Y2 = (ABST + 10 * ABST)
    Next
End Sub

Private Sub Command4_Click()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
    
    For i = 0 To 10
        Line2(i).X1 = i * ABST + (ABST)
        Line2(i).Y1 = ABST
        Line2(i).X2 = i * ABST + (ABST)
        Line2(i).Y2 = (ABST + 10 * ABST)
    Next

End Sub

Private Sub Command5_Click()
    Label1.Width = ABST * 1
    Label1.Height = ABST * 1
    Label1.Left = ABST + 15
    Label1.Top = ABST + 15
End Sub

Private Sub Command6_Click()
    Label2.Width = ABST * 1
    Label2.Height = ABST * 1
    Label2.Left = 10 * ABST + (15)
    Label2.Top = 10 * ABST + (15)
End Sub

Private Sub Command7_Click()
    Dim kollision As Boolean
    kollision = sprung1(3, 3)
    If kollision Then
        MsgBox "Kollision"
    End If
End Sub

Function sprung1(GitterX, GitterY) As Boolean
    Label1.Left = GitterX * ABST + (15)
    Label1.Top = GitterY * ABST + (15)
    sprung1 = (Label1.Left = Label2.Left) And (Label1.Top = Label2.Top)
End Function

Private Sub Command8_Click()
    Dim kollision As Boolean
    kollision = sprung2(3, 3)
    If kollision Then
        MsgBox "Kollision"
    End If
End Sub

Function sprung2(GitterX, GitterY) As Boolean
    Label2.Left = GitterX * ABST + (15)
    Label2.Top = GitterY * ABST + (15)
    sprung2 = (Label1.Left = Label2.Left) And (Label1.Top = Label2.Top)
End Function




Private Sub Form_Load()
    
    Dim kollision As Boolean
    
    Command1.Caption = "45°"
    Command2.Caption = "Parallel X"
    Command3.Caption = "Parallel Y"
    Command4.Caption = "Gitter"
    Command5.Caption = "label1"
    Command6.Caption = "label2"
    Command7.Caption = "label1 3-3"
    Command8.Caption = "label2 3-3"
    
    Spieler = 1
    Label1.Width = ABST * 0.98
    Label1.Height = ABST * 0.98
    Label2.Width = ABST * 0.98
    Label2.Height = ABST * 0.98
    gitter
    kollision = sprung1(1, 1)
    kollision = sprung2(10, 10)

End Sub
Sub gitter()
    Dim i As Integer
    For i = 0 To 10
        Line1(i).X1 = ABST
        Line1(i).Y1 = i * ABST + (ABST)
        Line1(i).X2 = (ABST + 10 * ABST)
        Line1(i).Y2 = i * ABST + (ABST)
        
    Next
    
    For i = 0 To 10
        Line2(i).X1 = i * ABST + (ABST)
        Line2(i).Y1 = ABST
        Line2(i).X2 = i * ABST + (ABST)
        Line2(i).Y2 = (ABST + 10 * ABST)
    Next
End Sub


Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim kollision As Boolean
    Dim iX, iY As Integer
    iX = Int(X / ABST)
    iY = Int(Y / ABST)
    If X > ABST And X < ABST * 11 And Y > ABST And Y < ABST * 11 Then
        If Button = 1 Then
            Spieler = 2
            Label3.BackColor = Label2.BackColor
            ZelleX1 = iX
            ZelleY1 = iY
            kollision = sprung1(ZelleX1, ZelleY1)
            
        ElseIf Button = 2 Then
            Spieler = 1
            Label3.BackColor = Label1.BackColor
            ZelleX2 = iX
            ZelleY2 = iY
            kollision = sprung2(ZelleX2, ZelleY2)
        End If
        
        label4.Caption = iX
        Label5.Caption = iY
        
    Else
        label4.Caption = "#"
        Label5.Caption = "#"
    End If

End Sub



Private Sub Label1_DblClick()
    Label1.Visible = False
End Sub
Private Sub Label2_DblClick()
    Label2.Visible = False
End Sub



Private Sub Label3_DblClick()
    Label1.Visible = True
    Label2.Visible = True
End Sub

Option Explicit
Const RAND = 200

Private Sub Command1_Click()
Dim ctl As Control
   For Each ctl In Controls
       If ctl.Name = "Image1" Then
           '********************************************************
           ' Wenn Index > 0 dann Bildelement löschen
           '********************************************************
           If ctl.Index Then Unload ctl
       End If
   Next ctl
    aufrufen Val(Text1.Text)
End Sub

Private Sub Form_Load()
    aufrufen 2
    Me.Left = 0
    Me.Top = 0
End Sub

Sub aufrufen(iMax As Integer)
    Dim pfad As String
    Dim resultat As Variant
    Dim i, ii, iLeftStart As Integer
    Me.Left = 0
    Me.Top = 0
    pfad = App.Path & ""
    resultat = DirReadFiles(pfad, "*.jpg")
    ii = 1
    Image1(i).Left = RAND
    Image1(i).Top = RAND + Command1.Height
    Me.Width = (iMax + 1) * RAND + iMax * Image1(0).Width
    For i = 0 To UBound(resultat)
        If i > 0 Then
            Load Image1(i)
            If ii = iMax Then
                ii = 0
                Image1(i).Left = RAND
                Image1(i).Top = Image1(i - 1).Top + Image1(i - 1).Height + RAND
            Else
                Image1(i).Top = Image1(i - 1).Top
                Image1(i).Left = Image1(i - 1).Left + Image1(i - 1).Width + RAND
            End If
            ii = ii + 1
            Image1(i).Visible = True
        End If
        Image1(i).Picture = LoadPicture(resultat(i))
    Next
End Sub

Private Sub Image1_Click(Index As Integer)
   Form2.Show
   Form2.Image1.Picture = Image1(Index).Picture
   Form2.Width = Form2.Image1.Width
   Form2.Height = Form2.Image1.Height
End Sub

Public Function DirReadFiles(ByVal sPath As String, sExt As String) As Variant
    Dim nZaehler As Long
    Dim i As Long
    Dim sDatei As String
    ReDim sDateien(0) As String
    ' ggf. abschließenden Backslash anfügen
    If Right$(sPath, 1) <> "" Then sPath = sPath & ""
    ' alle Dateien ermitteln und in ein Array speichern
    nZaehler = -1
    sDatei = Dir$(sPath & sExt)
    Do While Len(sDatei) > 0
      If sDatei <> "." And sDatei <> ".." Then
        ' Array bei Bedarf redimensionieren
        nZaehler = nZaehler + 1
        If UBound(sDateien) < nZaehler Then
          ReDim Preserve sDateien(nZaehler * 2)
        End If
        ' Array füllen
        sDateien(nZaehler) = sDatei
      End If
      sDatei = Dir$
    Loop
    DirReadFiles = sDateien
 End Function

Option Explicit
Dim arrFuncs() As String

Private Sub cmdAusfuehren_Click()
Ausführen
End Sub

Private Sub lstFuncs_Change()
Me.lblInfo.Caption = arrFuncs(2, lstFuncs.ListIndex + 1)
Ausführen
End Sub

Private Sub UserForm_Initialize()
Dim ok As Boolean
Dim i As Integer
Me.txtEingabe.Text = Date
ReDim arrFuncs(2, 0)
ok = arrAdd("Day (VBA)", "Datumstag herausholen")
ok = arrAdd("Month (VBA)", "Monat herausholen")
ok = arrAdd("Year (VBA)", "Datumsjahr herausholen")
ok = arrAdd("Weekday (VBA)", "Nummer des Datumstages in der Woche - Start mit Sonntag = 1")
ok = arrAdd("Wochentagsname (UDF)", "Wochentag ermitteln: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Monatssname (UDF)", "Monat ermitteln: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Ausführliches Datum (UDF)", "Briefdatum: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Bis heute (UDF)", "Zeitabstand zwischen Eingabedatum und heute: User Defined Function (UDF) Benutzerdefinierte Funktion")

For i = 1 To UBound(arrFuncs, 2)
    Me.lstFuncs.AddItem (arrFuncs(1, i))
Next
Me.lstFuncs.Selected(0) = True
End Sub
Function arrAdd(sFunc As String, sTip As String) As Boolean
ReDim Preserve arrFuncs(2, UBound(arrFuncs, 2) + 1)
arrFuncs(1, UBound(arrFuncs, 2)) = sFunc
arrFuncs(2, UBound(arrFuncs, 2)) = sTip
arrAdd = True
End Function

Sub Ausführen()
Dim Datum As Date
Datum = CDate(Me.txtEingabe.Text)
Select Case Me.lstFuncs.ListIndex
    Case 0 'day
        Me.lblAusgabe.Caption = Day(Datum)
        
    Case 1 ' month
        Me.lblAusgabe.Caption = Month(Datum)

    Case 2 'year
        Me.lblAusgabe.Caption = Year(Datum)

    Case 3 'weekday
        Me.lblAusgabe.Caption = Weekday(Datum)
        
    Case 4 'Wochentag
        Me.lblAusgabe.Caption = WochentagsName(Weekday(Datum))
        
    Case 5 'Monat
        Me.lblAusgabe.Caption = Monatsname(Month(Datum))
        
  Case 6 'Monat
        Me.lblAusgabe.Caption = WochentagsName(Weekday(Datum)) & " " & Day(Datum) & ". " & Monatsname(Month(Datum)) & " " & Year(Datum)
   
  Case 7 'Monat
        Me.lblAusgabe.Caption = BisHeute(Datum)
 End Select
End Sub

Function BisHeute(Datum As Date) As String
Dim Vergangenheit As Boolean
Dim Heute As Date
Dim iTage As Integer
Dim iJahreCnt As Integer
Dim iJahre As Integer
Dim sDat As String
Dim sDatTmp As String
Heute = Date
Vergangenheit = Heute > Datum
If Vergangenheit Then
    iTage = Heute - Datum
Else
    iTage = Datum - Heute
End If
sDat = Day(Datum) & "." & Month(Datum) & "."
iJahreCnt = 0
iJahre = Year(Datum)
Do While True
    If Vergangenheit Then
        sDatTmp = sDat & iJahre
        iJahre = iJahre + 1
        If Heute - CDate(sDatTmp) < 365 Then
            Exit Do
        End If
        iJahreCnt = iJahreCnt + 1
    Else
        sDatTmp = sDat & iJahre
        iJahre = iJahre - 1
        If CDate(sDatTmp) - Heute < 365 Then
            Exit Do
        End If
        iJahreCnt = iJahreCnt + 1
 
    End If
Loop
If Vergangenheit Then
    BisHeute = iJahreCnt & " Jahre, " & Heute - CDate(sDatTmp) & " Tage"
Else
    BisHeute = iJahreCnt & " Jahre, " & CDate(sDatTmp) - Heute & " Tage"

End If
End Function



Private Function Monatsname(iMonat As Integer) As String
Dim s As String
Select Case iMonat
    Case 1: s = "Januar"
    Case 2: s = "Februar"
    Case 3: s = "März"
    Case 4: s = "April"
    Case 5: s = "Mai"
    Case 6: s = "Juni"
    Case 7: s = "Juli"
    Case 8: s = "August"
    Case 9: s = "September"
    Case 10: s = "Oktober"
    Case 11: s = "November"
    Case 12: s = "Dezember"
End Select
Monatsname = s
End Function


Private Function WochentagsName(iTag As Integer) As String
Dim s As String
Select Case iTag
    Case 1: s = "Sonntag"
    Case 2: s = "Montag"
    Case 3: s = "Dienstag"
    Case 4: s = "Mittwoch"
    Case 5: s = "Donnerstag"
    Case 6: s = "Freitag"
    Case 7: s = "Samstag"
    
End Select
WochentagsName = s
End Function



Private Sub Form_Load()
Dim ok As Boolean
Dim i As Integer
Me.txtEingabe.Text = Date
ReDim arrFuncs(2, 0)
ok = arrAdd("Day (VBA)", "Datumstag herausholen")
ok = arrAdd("Month (VBA)", "Monat herausholen")
ok = arrAdd("Year (VBA)", "Datumsjahr herausholen")
ok = arrAdd("Weekday (VBA)", "Nummer des Datumstages in der Woche - Start mit Sonntag = 1")
ok = arrAdd("Wochentagsname (UDF)", "Wochentag ermitteln: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Monatssname (UDF)", "Monat ermitteln: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Ausführliches Datum (UDF)", "Briefdatum: User Defined Function (UDF) Benutzerdefinierte Funktion")
ok = arrAdd("Bis heute (UDF)", "Zeitabstand zwischen Eingabedatum und heute: User Defined Function (UDF) Benutzerdefinierte Funktion")

For i = 1 To UBound(arrFuncs, 2)
    Me.lstFuncs.AddItem (arrFuncs(1, i))
Next
Me.lstFuncs.Selected(0) = True

End Sub

'Label1 Height 3000 Width 500  Beide Labels liegen
'Label2 Height 3000 Width 500  deckungsgleich übereinander
'Command1
'Text1
'Text2
'Text3

Option Explicit

Private Sub Command1_Click()
    Dim dz1 As Double
    Dim dz2 As Double
    Dim dRes As Double
    dz1 = CDbl(Text1.Text)
    dz2 = CDbl(Text2.Text)
    dRes = Prozent(dz1, dz2)
    Label2.Height = Label1.Height * dRes / 100
    Label2.Top = Label1.Top + Label1.Height - Label2.Height
    Text3.Text = Str(dRes)
End Sub

Function Prozent(GM As Double, TM As Double) As Double
    Prozent = TM * 100 / GM
End Function