Tipp 0292 Tierkreiszeichen eines Datums anzeigen
Autor/Einsender:
Datum:
  Michael Werner
05.12.2002
Entwicklungsumgebung:   VB 5
Mit Hilfe der beigefügten Schriftart "Almanac MT" können die Tierkreiszeichen-Symbole eines beliebigen Datums dargestellt werden. Sofern die Schriftart nicht im System vorhanden ist, wird der Font aus dem Anwendungspfad temporär geladen und mit dem Beenden des Programms wieder entfernt.
Aus dem DTPicker-Steuerelement (Microsoft Windows Common Controls-2 6.0) wird das entsprechende Datum angewählt und das dazugehörige Tierkreiszeichen angezeigt.
 
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
 
Weitere Links zum Thema
Mondphase eines Datums anzeigen
Wochentag aus einem Datum ermitteln

Windows-Version
95
98/SE
ME
NT
2000
XP
Vista
Win 7
VB-Version
VBA 5
VBA 6
VB 4/16
VB 4/32
VB 5
VB 6


Download  (25 kB) Downloads bisher: [ 2511 ]

Vorheriger Tipp Zum Seitenanfang Nächster Tipp

Startseite | Projekte | Tutorials | API-Referenz | VB-/VBA-Tipps | Komponenten | Bücherecke | VB/VBA-Forum | VB.Net-Forum | DirectX-Forum | Foren-Archiv | DirectX | VB.Net-Tipps | Chat | Spielplatz | Links | Suchen | Stichwortverzeichnis | Feedback | Impressum

Seite empfehlen Bug-Report
Letzte Aktualisierung: Dienstag, 13. September 2011