![]() |
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
|
|
|
|
|
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: [ 2504 ]
|
|
|