|
| |
Visual-Basic Einsteiger| Re: Startmenü | |  | | Autor: alert | | Datum: 14.07.02 18:46 |
| Hi Dieter,
hier einmal der Quellcode des Projektes.
Gruß, Alert
'Startmenü!
'1 Textbox = txtEingabe
'1 Timer = Timer1
'1 Listbox = ListEinlesen
'1 Listbox = ListAusgabe
'1 Checkbox = chkGrossKlein
'1 CommonDialogControl = Dialog
Option Explicit
'Deklaration für Rahmen um die Form legen!
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Const GWL_EXSTYLE = (-20)
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'Deklaration zum starten von Anwendungen!
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const SW_SHOWNORMAL = 1
'Deklaration zum suchen in der Listbox!
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Const LB_ERR = (-1)
Private Sub Form_Paint()
'Funktion für Rahmen um die Form legen!
Dim fx As Long
fx = GetWindowLong(Me.hwnd, GWL_EXSTYLE)
SetWindowLong Me.hwnd, GWL_EXSTYLE, fx Or &H200
SetWindowPos Me.hwnd, 0&, 0&, 0&, 0&, 0&, &H23
End Sub
Private Sub Form_Load()
Laden 'Ruft Laden im "Sub Laden()" auf.
Übertragen 'Ruft Übertragen im "Sub Übertragen()" auf.
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Beenden 'Ruft Beenden im "Sub Beenden()" auf.
End Sub
Private Sub Laden()
Dim F As Byte
Dim Daten
On Error GoTo c 'Fehlerbehandlung.
SetAttr App.Path & "Daten.mru", vbNormal 'Schreibschutz deaktivieren.
F = FreeFile
Open App.Path & "Daten.mru" For Input As #F 'Öffnen der Datei "Daten.mru".
While Not EOF(1)
Line Input #F, Daten
frmAnwendung.ListEinlesen.AddItem Daten
Wend
Close 1
Exit Sub
c:
MsgBox "Dateien wurden nicht gefunden, es werden beim Beenden jedoch neue Dateien erstellt!", 48, "Bitte wenden Sie sich an den Hersteller."
End Sub
Private Sub Suchen()
'Datei auswählen.
Dim F As Integer
On Error Resume Next
With Dialog
.CancelError = True
.DialogTitle = "Wählen Sie eine Anwendung aus!"
.Filter = "Anwendung (*.exe)|*exe"
.ShowOpen
If .FileName <> "" Then
F = FreeFile
txtEingabe.Text = Dialog.FileName
Hinzufügen 'Ruft Hinzufügen im "Sub Hinzufügen()" auf.
End If
End With
End Sub
Private Sub Löschen()
On Error Resume Next
Dim I As Integer
With ListEinlesen
I = 0
Do Until I > .ListCount - 1
If .Selected(I) Then
.RemoveItem I
Else
I = I + 1
End If
Loop
End With
Übertragen 'Ruft Übertragen im "Sub Übertragen()" auf.
End Sub
Private Sub Speichern()
'Speichert die Einträge im gleichen Verzeichnis in die Datei: Daten.mru
Dim F As Integer
Dim I As Integer
On Error Resume Next
F = FreeFile
Open App.Path & "Daten.mru" For Output As #F
For I = 0 To frmAnwendung.ListEinlesen.ListCount - 1
Print #F, CStr(frmAnwendung.ListEinlesen.List(I))
Next I
Close #F
SetAttr App.Path & "Daten.mru", vbReadOnly ' Schreibschutz aktivieren.
End Sub
Private Sub Übertragen()
'Übertragen von ListEinlesen.List und abschneiden des Pfades
' sowie der Dateiendung nach ListAusgabe.List.
Dim I As Integer
Dim lPos As Long
Dim sFile As String
ListAusgabe.Clear
With ListEinlesen
For I = 0 To .ListCount - 1
sFile = .List(I)
' Pfad abschneiden
lPos = InStrRev(sFile, "\")
If lPos > 0 Then sFile = Mid$(sFile, lPos + 1)
'Extension abschneiden
lPos = InStrRev(sFile, ".")
If lPos > 0 Then sFile = Left$(sFile, lPos - 1)
'und ab in die ListAusgabe.List Box
ListAusgabe.AddItem sFile
Next I
End With
End Sub
Private Sub Hinzufügen()
'Hinzufügen eines neuen Eintrags.
Dim strText As String
strText = Trim(txtEingabe.Text)
If EintragVorhanden(ListEinlesen, strText) Then
txtEingabe.Text = "Der Eintrag ist bereits vorhanden!"
Else
ListEinlesen.AddItem strText
txtEingabe.Text = "Der Eintrag wurde zur Liste hinzugefügt!"
End If
Übertragen 'Ruft Übertragen im "Sub Übertragen()" auf.
End Sub
Private Function EintragVorhanden(ListEinlesen As Control, _
eintrag As String) As Boolean
'Prüfen ob der Eintrag bereits in der Liste vorhanden ist.
Dim I As Integer
EintragVorhanden = False
If chkGrossKlein.Value = 0 Then
For I = 0 To ListEinlesen.ListCount - 1
If UCase(ListEinlesen.List(I)) = UCase(eintrag) Then
EintragVorhanden = True
ListEinlesen.ListIndex = I
Exit For
End If
Next I
Else
For I = 0 To ListEinlesen.ListCount - 1
If ListEinlesen.List(I) = eintrag Then
EintragVorhanden = True
ListEinlesen.ListIndex = I
Exit For
End If
Next I
End If
End Function
Private Function ListFindText(lstListBox As ListBox, strFindText As String, Optional ByVal intFromIndex As Long = -1, Optional ByVal blnSelect As Boolean = True) As Long
'Funktion für die Suche in einer Listbox!
Dim lngMsg As Long
Dim lngIndex As Long
Dim blnExact As Boolean
Const LB_FINDSTRING = &H18F
Const LB_SELECTSTRING = &H18C
Const LB_FINDSTRINGEXACT = &H1A2
Select Case blnExact
Case False
Select Case blnSelect
Case True
lngMsg = LB_SELECTSTRING
Case False
lngMsg = LB_FINDSTRING
End Select
ListFindText = SendMessageStr(lstListBox.hwnd, lngMsg, intFromIndex, strFindText)
Case True
With lstListBox
lngIndex = SendMessageStr(.hwnd, LB_FINDSTRINGEXACT, intFromIndex, strFindText)
If blnSelect Then
.ListIndex = lngIndex
End If
End With
ListFindText = lngIndex
End Select
End Function
Private Sub Beenden()
Speichern 'Ruft Speichern im "Sub Speichern()" auf.
Unload Me
End 'Ende
End Sub
Private Sub ChangeColor(X As Control)
X.Enabled = True
X.BackColor = &HC0FFFF
X.SetFocus
End Sub
Sub txtEingabe_GotFocus()
txtEingabe.SelStart = 0
txtEingabe.SelLength = Len(txtEingabe.Text)
Call ChangeColor(txtEingabe)
End Sub
Sub txtEingabe_LostFocus()
txtEingabe.SelLength = Len(txtEingabe.Text)
txtEingabe.BackColor = &H80000005
End Sub
Private Sub ListAusgabe_DblClick()
On Error GoTo Fehler
Call ShellExecute(Me.hwnd, "Open", ListEinlesen.Text, "", "", 1)
Exit Sub
Fehler:
'Wenn ein Fehler auftritt, kommt diese Fehlermeldung:
MsgBox "Bitte wählen Sie eine Anwendung aus", vbInformation, "Fehler"
End Sub
Private Sub Timer1_Timer()
Dim iFirstIndexListAusgabe As Integer
Static sListEinlesenPreview As Integer
Static sListAusgabePreview As Integer
iFirstIndexListAusgabe = ListAusgabe.TopIndex
If iFirstIndexListAusgabe <> sListAusgabePreview Then
ListEinlesen.TopIndex = iFirstIndexListAusgabe
sListAusgabePreview = iFirstIndexListAusgabe
End If
If ListAusgabe.ListIndex <> ListEinlesen.ListIndex Then
ListEinlesen.ListIndex = ListAusgabe.ListIndex
End If
End Sub
'mnuMenü!
Private Sub mnuSuchen_Click()
Suchen 'Ruft Suchen im "Sub Suchen()" auf.
End Sub
Private Sub mnuLöschen_Click()
Löschen 'Ruft Löschen im "Sub Löschen()" auf.
End Sub
Private Sub mnuBeenden_Click()
Beenden 'Ruft Beenden im "Sub Beenden()" auf.
End Sub
Private Sub mnuReadme_Click()
ShellExecute Me.hwnd, "Open", App.Path & IIf(Right$(App.Path, 1) <> "\", "\", "") & "Readme.txt", _
vbNullString, App.Path, vbNormalFocus
End Sub
'mnuMenü!
Private Sub txtSuchen_Change()
'Aufruf für die Suche in einer Listbox!
'Name der Listbox und der Textbox sind anzupassen.
Call ListFindText(ListAusgabe, txtSuchen.Text, -1, True)
End Sub | |
 | Sie sind nicht angemeldet!
Um auf diesen Beitrag zu antworten oder neue Beiträge schreiben zu können, müssen Sie sich zunächst anmelden.
 Einloggen | Neu registrieren |
 |
|
sevAniGif (VB/VBA) 
Anzeigen von animierten GIF-Dateien
Ab sofort lassen sich auch unter VB6 und VBA (Access ab Version 2000) animierte GIF-Grafiken anzeigen und abspielen, die entweder lokal auf dem System oder auf einem Webserver gespeichert sind. Weitere InfosTipp des Monats  Oktober 2025
Matthias KozlowskiUmlaute konvertierenErsetzt die Umlaute in einer Zeichenkette durch die entsprechenden Doppelbuchstaben (aus ä wird ae, usw.) Access-Tools Vol.1 
Über 400 MByte Inhalt
Mehr als 250 Access-Beispiele, 25 Add-Ins und ActiveX-Komponenten, 16 VB-Projekt inkl. Source, mehr als 320 Tipps & Tricks für Access und VB
Nur 24,95 EURWeitere Infos
|
Sie sind aktuell nicht angemeldet.
