copyright 1999 - 2014 by heinz prelle - hannover  - lenbachstraße 42 - www.visual-basic5.de | impressum
Männliche und weibliche muslimische Vornamen und deren Bedeutung
Männliche und weibliche muslimische Vornamen und deren Bedeutung.

'
Private UserdefinedFontname As String
Private IsFontIsLoaded As Boolean
Const TranslateFromID = "EN"

Private Function Translation(ByVal TextToTranslate As String, ByVal IDFrom As String, ByVal IDTo As String) As String
    Dim Result As String
    If modTranslate.UseGoogleTranslatorToTranslateTextFromLanguageToLanguage(TextToTranslate, IDFrom, IDTo, Result) Then
        Translation = Result
    Else
        Label6.Caption = "Fehler"
        Exit Function
    End If
End Function

Private Function InitLanguageID() As Variant
    Dim n As Long
    For n = 0 To 9
        InitLanguageID = Array("DE", "FR", "PL", "DA", "IT", "NL", "ES", "RO", "HU", "CS")
    Next
End Function

Private Sub Command1_Click()
    Dim MasculineNames As String
    MasculineNames = modFileHandle.GetAppPath & modFileHandle.MasculineNames
    List1.Enabled = False: List2.Enabled = False: Command1.Enabled = False: Command2.Enabled = False: Command3.Enabled = False: Command4.Enabled = False
    LoadNamesFromFiles MasculineNames
End Sub

Private Sub Command2_Click()
    Dim FeminineNames As String
    FeminineNames = modFileHandle.GetAppPath & modFileHandle.FeminineNames
    List1.Enabled = False: List2.Enabled = False: Command1.Enabled = False: Command2.Enabled = False: Command3.Enabled = False: Command4.Enabled = False
    LoadNamesFromFiles FeminineNames
End Sub

Private Sub Command3_Click()
    Dim s As String
    s = Text1.Text
    s = LTrim(s)
    s = RTrim(s)
    Text1.Text = s
    SearchInListBox s
End Sub

Private Sub SearchInListBox(ByVal s As String)
    If Len(s) <> 0 Then
        On Error Resume Next
        Dim n As Long
        For n = 0 To List1.ListCount - 1
            If List1.List(n) = s Or LCase(List1.List(n)) = LCase(s) Then
                List1.Selected(n) = True
                Exit For
            End If
        Next n
    Else
        MsgBox "Zum suchen müssen etwas in die Textbox eingeben.", vbOKOnly Or vbInformation, "Eingabefehler"
        Text1.Text = ""
    End If
End Sub

Private Sub Command4_Click()
    Clipboard.Clear
    If Label3.Caption <> "" And Label4.Caption <> "" And Label7.Caption <> "" Then
        Clipboard.SetText "Vorname: " & Label3.Caption & vbCrLf & "Beschreibung: " & Label4.Caption & vbCrLf & "Übersetzung: " & Label7.Caption, vbCFText
        MsgBox "Folgender Text wurde in die Zwischenablage kopiert:" & vbCrLf & _
        "Vorname: " & Label3.Caption & vbCrLf & "Beschreibung: " & Label4.Caption & vbCrLf & "Übersetzung: " & Label7.Caption, vbOKOnly Or vbInformation, "Info"
    Else
        MsgBox "Eins der benötigten Felder, Vorname, Beschreibung oder Übersetzung sind leer. Kopiervorgang wird nicht ausgeführt!", vbOKOnly Or vbInformation, "Info"
    End If
End Sub

Private Sub Form_Load()
    Me.Text1.Text = ""
   
    Call InitLanguageID
    Dim n As Long
    For n = LBound(InitLanguageID) To UBound(InitLanguageID)
        Option1(n).Caption = InitLanguageID(n)
    Next
   
    UserdefinedFontname = "Script 12 Pitch BT"
    LoadUserDefinedFont
   
     'Die Bilder für das Menue (.bmp) dürfen nur 13x13 gross sein...
    Dim MenueHandle As Long
    Dim id As Long

    MenueHandle = GetMenu(Me.hwnd)
    'Menue Datei
    id = GetSubMenu(MenueHandle, 0)
    SetMenuItemBitmaps id, 0, MF_BYPOSITION, Picture2.Picture, Picture5.Picture
    'Menue Optionen
    id = GetSubMenu(MenueHandle, 1)
    SetMenuItemBitmaps id, 1, MF_BYPOSITION, Picture3.Picture, Picture6.Picture
    SetMenuItemBitmaps id, 0, MF_BYPOSITION, Picture4.Picture, Picture7.Picture
    'SetMenuItemBitmaps id, 3, MF_BYPOSITION, Picture5.Picture, Picture5.Picture
    'SetMenuItemBitmaps id, 4, MF_BYPOSITION, Picture6.Picture, Picture6.Picture
   
    '

    Select Case IsConnectedWithINET
        Case True
            Label6.Caption = "Ein Test hat ergeben das Sie mit dem Internet verbunden sind."
        Case False
            Label6.Caption = "Ein Test hat ergeben das Sie nicht mit dem Internet verbunden sind. Stellen Sie eine Verbindung her."
    End Select
    Command3.Enabled = False
    Command4.Enabled = False
   
End Sub

Private Sub LoadUserDefinedFont()
    Dim Result As Long
    Result = LoadFont(UserdefinedFontname & ".ttf", App.Path)
    If Result = 0 Then
        MsgBox "Kann Font " & UserdefinedFontname & " im Verzeichnis " & App.Path & " nicht LoadUserDefinedFont." & vbCrLf & "Die Verarbeitung wird abgebrochen !", vbCritical, "Fehler "
        End
    Else
        IsFontIsLoaded = True
    End If
 
    With Label1
        .Font = UserdefinedFontname '"Verdana"
        .FontBold = False
        .FontItalic = False
        .FontSize = 10
        .Caption = "Vorname: Bitte auswählen"
        With Label2
            .Font = UserdefinedFontname
            .FontBold = False
            .FontItalic = False
            .FontSize = 10
            .Caption = "Beschreibung: Was bedeutet der Name"
            With Command1
                    .Font = UserdefinedFontname
                    .FontBold = False
                    .FontItalic = False
                    .FontSize = 10
                    .Caption = "Männliche Vorname anzeigen"
                With Command2
                    .Font = UserdefinedFontname
                    .FontBold = False
                    .FontItalic = False
                    .FontSize = 10
                    .Caption = "Weibliche Vorname anzeigen"
                    With List1
                        .Font = UserdefinedFontname
                        .FontBold = False
                        .FontItalic = False
                        .FontSize = 10
                        With List2
                            .Font = UserdefinedFontname
                            .FontBold = False
                            .FontItalic = False
                            .FontSize = 10
                            With Me
                                .Caption = "Männliche und Weibliche muslimische Vornamen" & " Version: " & App.Major & "." & App.Minor & "." & App.Revision
                            End With
                        End With
                    End With
                End With
            End With
        End With
    End With
    With Label3
        .Font = UserdefinedFontname
        .FontBold = True
        .FontItalic = False
        .FontSize = 18
        .ForeColor = vbRed
        With Label4
            .Font = UserdefinedFontname
            .FontBold = False
            .FontItalic = False
            .FontSize = 14
            With Label5
                .Font = UserdefinedFontname
                .FontBold = False
                .FontItalic = True
                .FontSize = 12
                With Label6
                    .Font = "Verdana"
                    .FontBold = False
                    .FontItalic = False
                    .FontSize = 10
                    .ForeColor = vbBlack
                    With Label7
                        .Font = UserdefinedFontname
                        .FontBold = True
                        .FontItalic = False
                        .FontSize = 11
                    End With
                End With
            End With
        End With
    End With
    With Command3
        .Font = UserdefinedFontname
        .FontBold = False
        .FontItalic = False
        .FontSize = 10
        .Caption = "Liste durchsuchen"
        With Command4
            .Font = UserdefinedFontname
            .FontBold = False
            .FontItalic = False
            .FontSize = 10
            .Caption = "In die Zwischenablage kopieren"
        End With
    End With
End Sub

Private Sub UnloadUserDefinedFont()
  Dim Result As Long
 
  If IsFontIsLoaded Then
    Result = RemoveFont(UserdefinedFontname & ".ttf", App.Path)
    IsFontIsLoaded = False
    Debug.Print Result
  End If
End Sub

Private Sub LoadNamesFromFiles(Filename As String)
    Dim fno As Integer
    Dim Content() As String
    Dim s As String
    Dim n As Integer
    n = 0: s = ""
   
    If List1.ListCount > 0 Then List1.Clear: If List2.ListCount > 0 Then List2.Clear
   
    fno = FreeFile
    On Error Resume Next
    Open Filename For Input As fno
        Do While Not EOF(fno)
            Line Input #fno, s
            Content() = Split(s, "|", -1, vbTextCompare)
            List1.AddItem Content(0)
            List2.AddItem Content(1)
            n = n + 1
            DoEvents
        Loop
    Close #fno
    Erase Content
    List1.Enabled = True: List2.Enabled = False: Command1.Enabled = True: Command2.Enabled = True: Command3.Enabled = True: Command4.Enabled = True
    List1.ListIndex = 5
    Label6.Caption = List1.ListCount & " Vornamen und " & List2.ListCount & " Beschreibungen vorhanden."
End Sub

Private Sub Form_Unload(Cancel As Integer)
    UnloadUserDefinedFont
End Sub

Private Sub Label4_Click()
    Dim Result As String
    Dim IDTranslateTo As String
   
    If Len(Label4.Caption) < 2 Then
        Label6.Caption = "Es ist kein Text zur Übersetzung vorhanden."
        Exit Sub
    End If
    If Label4.ForeColor = vbBlue Then
        Label6.Caption = "Der Text wurde schon übersetzt. Wählen Sie einen neuen Namen um übersetzen aus..."
    End If
   
    '
    If IsConnectedWithINET = False Then
        Label6.Caption = "Sie sind nicht Online. Bitte Programm beenden, Verbindung herstellen und neu starten."
        Exit Sub
    End If
    '
    '
    Dim n As Long
    For n = 0 To 9
        If Option1(n).Value = True Then
            IDTranslateTo = Option1(n).Caption
            Exit For
        Else
            Debug.Print Option1(n).Value
        End If
    Next
    If IDTranslateTo <> "" Then
        Result = Translation(Label4.Caption, TranslateFromID, IDTranslateTo)
    Else
   
    End If
    Select Case Result
        Case Is <> ""
            Label7.ForeColor = vbBlue
            Label7.Caption = Result
        Case Is = ""
            Label6.Caption = "Fehler..."
    End Select
End Sub

Private Sub List1_Click()
    '
    Dim s As String
    Dim arr() As String
   
    s = List1.List(List1.ListIndex) & "|" & List2.List(List1.ListIndex)
    arr = Split(s, "|", -1, vbTextCompare)
    Label3.Caption = arr(0)
    Label4.ForeColor = vbBlack
    Label4.Caption = arr(1)
    Label6.Caption = "."
    Label7.Caption = ""
End Sub

Private Sub List2_Click()
    '
End Sub

Private Sub mnuAbout_Click(Index As Integer)
    On Error Resume Next
    frmAbout.Show vbModal
    mnuAbout.Item(3).Checked = True
    If mnuHelp.Item(4).Checked = True Then mnuHelp.Item(4).Checked = False
End Sub

Private Sub mnuExit_Click(Index As Integer)
    Call Unload(Me)
End Sub

Private Sub mnuHelp_Click(Index As Integer)
    On Error Resume Next
    frmHelp.Show vbModal
    mnuHelp.Item(4).Checked = True
    If mnuAbout.Item(3).Checked = True Then mnuAbout.Item(3).Checked = False
End Sub

Private Sub Picture1_Click()
    Call Label4_Click
End Sub

Private Sub Timer1_Timer()
    Dim tmp As Long
    Static n As Integer
   
    tmp = List1.TopIndex
   
    If tmp <> n Then
        List2.TopIndex = tmp
        n = tmp
    End If
   
    If List1.ListIndex <> List2.ListIndex Then
        List2.ListIndex = List1.ListIndex
    End If
End Sub
------------------
Private Sub Command1_Click()
    Call Unload(Me)
    frmMain.Show
End Sub

Private Sub Form_Load()
   
    Label1.Caption = "Wichtig:" & vbCrLf & _
                     "Das Programm verwendet zur Übersetzung Teile aus dem Google Übersetzer." & vbCrLf & _
                     "Dazu benötigt es eine funktionierende Internetverbindung. Stellen Sie sicher" & vbCrLf & _
                     "das ihr System mit dem Internet verbunden ist."
     With Me.Timer1
        .Interval = 1000
        .Enabled = True
    End With
End Sub

Private Sub Timer1_Timer()
    On Error Resume Next
    IsConnectedWithINET = modPingApi.Ping("173.194.113.159")
    Me.Timer1.Enabled = False
End Sub
----------------------------
Private Sub Command1_Click()
    Call Unload(Me)
End Sub

Private Sub Form_Load()
    Me.Caption = "Hilfe"
End Sub
------------------------------
Private Sub Command1_Click()
    Call Unload(Me)
End Sub

Private Sub Form_Load()
    Me.Caption = "Über"
End Sub
------------------------------
Public 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

Public Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long
Public Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long

Public Const MF_BYPOSITION = &H400&

Public Function LoadFont(FontDescription As String, Path As String)
    Dim ComplettePath As String

    If Right(Path, 1) = "\" Then
        ComplettePath = Path & FontDescription
    Else
        ComplettePath = Path & "\" & FontDescription
        '
        If modFileHandle.FileExist(ComplettePath) = False Then Exit Function
        '
        LoadFont = AddFontResource(ComplettePath)
    End If
End Function

Public Function RemoveFont(FontDescription As String, Path As String)
  Dim ComplettePath As String
 
  If Right(Path, 1) = "\" Then
    ComplettePath = Path & FontDescription
  Else
    ComplettePath = Path & "\" & FontDescription
    '
    If modFileHandle.FileExist(ComplettePath) = False Then Exit Function
    '
    RemoveFont = RemoveFontResource(ComplettePath)
  End If
End Function
----------------------------
Public Const FeminineNames As String = "femininearabicnames.txt"
Public Const MasculineNames As String = "masculinearabicnames.txt"
Public Const Fontname As String = "Script 12 Pitch BT"

Public Const SplittChar As String = "|"

Public Function GetAppPath() As String
    Dim AppPath As String
    AppPath = App.Path
   
    If Right$(AppPath, 1) <> "\" Then
        AppPath = AppPath & "\"
        GetAppPath = AppPath
    Else
        GetAppPath = AppPath
    End If
End Function

Public Function FileExist(ByVal Path As String) As Boolean
    Dim fno As Long
   
    On Error Resume Next
    If Right$(Path, 1) = "\" Then
        Path = Left$(Path, Len(Path) - 1)
    End If
    fno = FreeFile
    Open Path For Input As fno
        FileExist = IIf(Err, False, True)
    Close fno
    Err = 0
End Function
-----------------------------------
Private Declare Function GetRTTAndHopCount Lib "iphlpapi.dll" (ByVal lDestIPAddr As Long, ByRef lHopCount As Long, ByVal lMaxHops As Long, ByRef lRTT As Long) As Long
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal cp As String) As Long

Public IsConnectedWithINET As Boolean

Public Function Ping(IP As String) As Boolean
    Const SUCCESS = 1
    Dim MaxHops As Long
    MaxHops = 20
    Dim Result As Long, HopCount As Long, RTT As Long
    Result = inet_addr(IP)
    Ping = (GetRTTAndHopCount(Result, HopCount, MaxHops, RTT) = SUCCESS)
End Function
-----------------------------------------
Public Function UseGoogleTranslatorToTranslateTextFromLanguageToLanguage( _
                ByVal OriginalTextToTranslate As String, _
                ByVal TranslateLanguageFromID As String, _
                ByVal TranslateLanguageToID As String, _
                ByRef Translated As String, _
                Optional ByVal UniCode As Long, _
                Optional ByVal TimeOut As Integer = 3, _
                Optional ByVal MyError As Boolean = False) As Boolean
    Dim IE As Object
    Dim dt As Date
    Const GOOGLE_URI As String = "http://translate.google.com"
    On Error GoTo ErrHandle
    If Len(OriginalTextToTranslate) > 0 And Not TranslateLanguageFromID = TranslateLanguageToID Then
        Set IE = CreateObject("InternetExplorer.Application")
        IE.Navigate GOOGLE_URI & "/?sl=" & TranslateLanguageFromID & "&tl=" & TranslateLanguageToID & "#" & TranslateLanguageToID & "|" & TranslateLanguageFromID & "|" & OriginalTextToTranslate
        dt = Now() + TimeValue("00:00:" & TimeOut)
        On Error Resume Next
        Do
            Translated = IE.Document.getElementById("result_box").innerText
            If Now() >= dt Then Exit Do
        Loop While Translated = ""
        On Error GoTo ErrHandle
        If Len(Translated) > 0 And Not Translated = OriginalTextToTranslate Then
            If UniCode <> 0 Then
            Translated = StrConv(Translated, vbUnicode, UniCode)
        End If
            UseGoogleTranslatorToTranslateTextFromLanguageToLanguage = True
        End If
    End If
    On Error Resume Next
    If Not IE Is Nothing Then
        IE.Quit
        Set IE = Nothing
        Debug.Print "Internet Explorer was destroyed"
    End If
   
ExitProcess:
  On Error Resume Next
  IE.Quit
  Set IE = Nothing
  Exit Function

ErrHandle:
  If Not MyError Then
    MsgBox Err.Number & vbCrLf & Err.Description, vbCritical, "Fehler..."
  End If
  Resume ExitProcess
End Function