Option Explicit

Private Declare Function AddFontResource Lib "gdi32" _
        Alias "AddFontResourceA" (ByVal lpFileName As _
        String) As Long

Private Declare Function RemoveFontResource Lib "gdi32" _
        Alias "RemoveFontResourceA" (ByVal lpFileName As _
        String) As Long

Dim TierkreisBuchstabe As String
Dim FontExist As Boolean
Dim FontTempLoaded As Boolean

Private Sub Form_Load()
  If IsFont("Almanac MT") Then
    FontExist = True
  Else
    Dim lngRet As Long

    lngRet = AddFontResource(App.Path & "\almanac.ttf")
    If lngRet > 0 Then
      FontTempLoaded = True
    End If
  End If

  With Label1
    .Font = "Almanac MT"
    .FontBold = True
    .FontSize = 25
  End With

  DTPicker1.Value = Date
  TierkreisZeichen
End Sub

Private Sub DTPicker1_Change()
  TierkreisZeichen
End Sub

Function IsFont(sF As String) As Boolean
  Dim i As Integer

  Screen.MousePointer = vbHourglass
  For i = 0 To Screen.FontCount - 1
    If UCase(sF) = UCase(Screen.Fonts(i)) Then
      IsFont = True
      Exit For
    Else
      IsFont = False
    End If
  Next i
  Screen.MousePointer = vbNormal
End Function

Sub TierkreisZeichen()
  Select Case DTPicker1.Month
    Case 1
      If DTPicker1.Day > 19 Then
        Label2 = "Wassermann"
        TierkreisBuchstabe = "k"
      Else
        Label2 = "Steinbock"
        TierkreisBuchstabe = "j"
      End If
    Case 2
      If DTPicker1.Day > 18 Then
        Label2 = "Fische"
        TierkreisBuchstabe = "l"
      Else
        Label2 = "Wassermann"
        TierkreisBuchstabe = "k"
      End If
    Case 3
      If DTPicker1.Day > 20 Then
        Label2 = "Widder"
        TierkreisBuchstabe = "a"
      Else
        Label2 = "Fische"
        TierkreisBuchstabe = "l"
      End If
    Case 4
      If DTPicker1.Day > 19 Then
        Label2 = "Stier"
        TierkreisBuchstabe = "b"
      Else
        Label2 = "Widder"
        TierkreisBuchstabe = "a"
      End If
   Case 5
      If DTPicker1.Day > 20 Then
        Label2 = "Zwillinge"
        TierkreisBuchstabe = "c"
      Else
        Label2 = "Stier"
        TierkreisBuchstabe = "b"
      End If
    Case 6
      If DTPicker1.Day > 20 Then
        Label2 = "Krebs"
        TierkreisBuchstabe = "d"
      Else
        Label2 = "Zwillinge"
        TierkreisBuchstabe = "c"
      End If
    Case 7
      If DTPicker1.Day > 22 Then
        Label2 = "Löwe"
        TierkreisBuchstabe = "e"
      Else
        Label2 = "Krebs"
        TierkreisBuchstabe = "d"
      End If
    Case 8
      If DTPicker1.Day > 22 Then
        Label2 = "Jungfrau"
        TierkreisBuchstabe = "f"
      Else
        Label2 = "Löwe"
        TierkreisBuchstabe = "e"
      End If
    Case 9
      If DTPicker1.Day > 22 Then
        Label2 = "Waage"
        TierkreisBuchstabe = "g"
      Else
        Label2 = "Jungfrau"
        TierkreisBuchstabe = "f"
      End If
    Case 10
      If DTPicker1.Day > 22 Then
        Label2 = "Skorpion"
        TierkreisBuchstabe = "h"
      Else
        Label2 = "Waage"
        TierkreisBuchstabe = "g"
      End If
    Case 11
      If DTPicker1.Day > 21 Then
        Label2 = "Schütze"
        TierkreisBuchstabe = "i"
      Else
        Label2 = "Skorpion"
        TierkreisBuchstabe = "h"
      End If
    Case 12
      If DTPicker1.Day > 21 Then
        Label2 = "Steinbock"
        TierkreisBuchstabe = "j"
      Else
        Label2 = "Schütze"
        TierkreisBuchstabe = "i"
      End If
  End Select

  If FontExist Or FontTempLoaded Then
    Label1 = TierkreisBuchstabe
  End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
  Dim lngRet As Long

  If FontTempLoaded Then
    lngRet = RemoveFontResource(App.Path & "\almanac.ttf")
  End If
  End
End Sub