Я автор:
Файл frmMain.frm:
Код:
VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{C1A8AF28-1257-101B-8FB0-0020AF039CA3}#1.1#0"; "MCI32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain
BackColor = &H00FF0000&
BorderStyle = 1 'Fixed Single
Caption = "Русско-Казахский Словарь 1.0"
ClientHeight = 6180
ClientLeft = 45
ClientTop = 330
ClientWidth = 9270
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 6180
ScaleWidth = 9270
StartUpPosition = 2 'CenterScreen
Begin MSComDlg.CommonDialog CommonDialog1
Left = 1440
Top = 3000
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.CommandButton cmdSave
Caption = "S"
Height = 495
Left = 3840
TabIndex = 11
Top = 5520
Width = 375
End
Begin VB.CommandButton cmdAbout
Caption = "&Помощь"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 3840
TabIndex = 10
Top = 5520
Width = 5295
End
Begin VB.CommandButton cmdThema
Caption = "&Тема"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1800
TabIndex = 9
Top = 5520
Width = 1815
End
Begin VB.CommandButton cmdExit
Caption = "&Выход"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 8
Top = 5520
Width = 1575
End
Begin MCI.MMControl MMControl1
Height = 495
Left = 3840
TabIndex = 7
Top = 4920
Width = 5295
_ExtentX = 9340
_ExtentY = 873
_Version = 393216
PrevVisible = 0 'False
NextVisible = 0 'False
RecordVisible = 0 'False
EjectVisible = 0 'False
DeviceType = ""
FileName = ""
End
Begin RichTextLib.RichTextBox rtfText
Height = 4455
Left = 3840
TabIndex = 6
Top = 360
Width = 5295
_ExtentX = 9340
_ExtentY = 7858
_Version = 393217
ScrollBars = 3
TextRTF = $"frmMain.frx":0000
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.CommandButton cmdClear
Caption = "&Новый поиск"
Enabled = 0 'False
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 1800
TabIndex = 4
Top = 4920
Width = 1815
End
Begin VB.CommandButton cmdShow
Caption = "&Показать"
Default = -1 'True
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 495
Left = 120
TabIndex = 3
Top = 4920
Width = 1575
End
Begin VB.ListBox lstData
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 3960
Left = 120
Sorted = -1 'True
TabIndex = 2
Top = 840
Width = 3495
End
Begin VB.TextBox txtData
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H000000FF&
Height = 360
Left = 120
TabIndex = 0
Top = 360
Width = 3495
End
Begin VB.Label lbLabels
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Слово:"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FFFF&
Height = 300
Index = 1
Left = 3840
TabIndex = 5
Top = 0
Width = 885
End
Begin VB.Label lbLabels
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Введите искомое слово:"
BeginProperty Font
Name = "MS Sans Serif"
Size = 12
Charset = 204
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &H0000FFFF&
Height = 300
Index = 0
Left = 120
TabIndex = 1
Top = 0
Width = 3150
End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim j As Long
Dim IsChanged As Boolean
Private Sub cmdAbout_Click()
On Error GoTo errHand
CommonDialog1.HelpFile = App.Path & "\ruskaz.hlp"
CommonDialog1.HelpCommand = &HB Or cdlHelpSetContents
CommonDialog1.ShowHelp
errExit:
Exit Sub
errHand:
ErrMsg "cmdAbout_Click()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub cmdClear_Click()
On Error GoTo errHand
Me.rtfText.Text = ""
Me.txtData.Text = ""
Me.lstData.ListIndex = 0
errExit:
Exit Sub
errHand:
ErrMsg "cmdClear_Click()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub cmdExit_Click()
On Error GoTo errHand
Unload Me
errExit:
Exit Sub
errHand:
ErrMsg "cmdExit_Click()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub cmdSave_Click()
sSql = "SELECT * FROM tblWords WHERE idWord=" & Me.lstData.ItemData(Me.lstData.ListIndex)
Set rec = db.OpenRecordset(sSql)
rec.Edit
rec.Fields("Text") = Me.rtfText.TextRTF
rec.Update
End Sub
Private Sub cmdShow_Click()
On Error GoTo errHand
Call lstData_DblClick
errExit:
Exit Sub
errHand:
ErrMsg "cmdShow_Click()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub cmdThema_Click()
On Error GoTo errHand
IsChanged = False
frmThema.Show vbModal
If frmThema.pos = -1 Then Exit Sub
Me.rtfText.Text = ""
Me.lstData.Clear
Me.txtData.Text = ""
sSql = "SELECT * FROM qryThemas WHERE tblThemas.IdThema=" & frmThema.pos
If frmThema.pos = 10 Then sSql = "tblWords"
Set rec = db.OpenRecordset(sSql)
Do While Not rec.EOF
If rec.Fields("Word") = "" Then Exit Sub
Me.lstData.AddItem rec.Fields("Word")
Me.lstData.ItemData(Me.lstData.NewIndex) = rec.Fields("idWord")
rec.MoveNext
Loop
errExit:
Exit Sub
errHand:
ErrMsg "cmdThema_Click()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub Form_Load()
On Error GoTo errHand
IsChanged = False
Set rec = db.OpenRecordset("tblWords")
If rec.EOF = True Then Exit Sub
Do While Not rec.EOF
If rec.Fields("Word") = "" Then Exit Sub
Me.lstData.AddItem rec.Fields("Word")
Me.lstData.ItemData(Me.lstData.NewIndex) = rec.Fields("idWord")
rec.MoveNext
Loop
errExit:
Exit Sub
errHand:
ErrMsg "Form_Load()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub lstData_DblClick()
On Error GoTo errHand
IsChanged = False
sSql = "SELECT * FROM tblWords WHERE idWord=" & Me.lstData.ItemData(Me.lstData.ListIndex)
Set rec = db.OpenRecordset(sSql)
If rec.EOF = True Then Exit Sub
Me.rtfText.Text = ""
If rec.Fields("SoundAval") = True Then
Me.MMControl1.DeviceType = "Waveaudio"
Me.MMControl1.FileName = App.Path & "\data\" & rec.Fields("SoundFile")
Me.MMControl1.Command = "open"
End If
If IsNull(rec.Fields("Text")) = True Then Exit Sub
Me.rtfText.TextRTF = rec.Fields("Text")
errExit:
Exit Sub
errHand:
ErrMsg "lstData_DblClick()", err.Description, err.Number
GoTo errExit
End Sub
Private Sub lstData_KeyUp(KeyCode As Integer, Shift As Integer)
IsChanged = False
Me.txtData.Text = Me.lstData.List(Me.lstData.ListIndex)
End Sub
Private Sub lstData_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
On Error GoTo errHand
IsChanged = False
Me.txtData.Text = Me.lstData.List(lstData.ListIndex)
Me.cmdClear.Enabled = True
errExit:
Exit Sub
errHand:
ErrMsg "lstData_MouseUp(...)", err.Description, err.Number
GoTo errExit
End Sub
Private Sub rtfText_Click()
'
If rtfText.SelUnderline = True And rtfText.SelColor = RGB(0, 0, 255) Then
End If
End Sub
Private Sub txtData_Change()
On Error GoTo errHand
Dim j As Long, errc As Integer
errc = 1
If IsChanged = False Then Exit Sub
errc = 2
If Me.txtData.Text = "" Then
Set rec = db.OpenRecordset("tblWords")
If rec.EOF = True Then Exit Sub
Do While Not rec.EOF
If rec.Fields("Word") = "" Then Exit Sub
Me.lstData.AddItem rec.Fields("Word")
Me.lstData.ItemData(Me.lstData.NewIndex) = rec.Fields("idWord")
rec.MoveNext
Loop
Me.lstData.ListIndex = 0:
Exit Sub
End If
errc = 3
'''''For j = Me.lstData.ListCount - 1 To (Me.lstData.ListCount - 1) / 2 Step -1
''''' If InStr(1, LCase(Me.lstData.List(j)), LCase(Me.txtData.Text), vbBinaryCompare) <> 0 Then Me.lstData.ListIndex = j: Exit Sub
''''' DoEvents
'''''errc = 4
'''''Next j
'''''For j = (Me.lstData.ListCount - 1) / 2 To 0 Step -1
''''' If InStr(1, LCase(Me.lstData.List(j)), LCase(Me.txtData.Text), vbBinaryCompare) <> 0 Then Me.lstData.ListIndex = j
''''' DoEvents
'''''errc = 55
'''''Next j
Me.lstData.Clear
sSql = "SELECT * FROM tblWords WHERE Word LIKE '" & Me.txtData.Text & "*'"
Set rec = db.OpenRecordset(sSql)
If rec.EOF = True Then Exit Sub
Do While Not rec.EOF
If rec.Fields("Word") = "" Then Exit Sub
Me.lstData.AddItem rec.Fields("Word")
Me.lstData.ItemData(Me.lstData.NewIndex) = rec.Fields("idWord")
rec.MoveNext
Loop
errc = 5
errExit:
Exit Sub
errHand:
ErrMsg "txtData_Change()" & errc, err.Description, err.Number
GoTo errExit
End Sub
Private Sub txtData_KeyUp(KeyCode As Integer, Shift As Integer)
IsChanged = True
End Sub