p align="left">Print #1, "CLOSE" Close blnDial = False End If End Sub Private Sub butEdit_Click() lngIndex = lstMain.GetSelected Load frmEdit frmEdit.txtName = User(lstMain.GetSelected).strName frmEdit.txtOtchectvo = User(lstMain.GetSelected).strOtchectvo frmEdit.txtFamilia = User(lstMain.GetSelected).strFamilia frmEdit.txtAdress = User(lstMain.GetSelected).strAdress frmEdit.txtdoma = User(lstMain.GetSelected).strDoma frmEdit.txtkvartira = User(lstMain.GetSelected).strKvartira frmEdit.txtPhone = User(lstMain.GetSelected).strPhone frmEdit.txtComment = User(lstMain.GetSelected).strComment frmEdit.Show vbModal End Sub Private Sub butExit_Click() Unload Me End Sub Private Sub butOptions_Click() Load frmOptions frmOptions.Show vbModal End Sub Private Sub Command1_Click() bPoisk = True If Dir(Path & "search.dat") <> "" Then Kill (Path & "search.dat") butAdd.Visible = False butEdit.Visible = True butDelete.Visible = False butAbout.Visible = False butDial.Visible = False butOptions.Visible = False frmEdit.Show End Sub Private Sub Command2_Click() bPoisk = False butAdd.Visible = True butEdit.Visible = True butDelete.Visible = True butAbout.Visible = True ' butDial.Visible = True butOptions.Visible = True GetData End Sub Private Sub Form_DblClick() WindowState = vbMinimized End Sub Private Sub Form_Load() On Error Resume Next GetData SetWindowText hWnd, App.ProductName Dim lngTop As Long, lngLeft As Long, lngWidth As Long, lngHeight As Long lngTop = Reg.RegRead("HKCU\Book\Top") lngLeft = Reg.RegRead("HKCU\Book\Left") lngHeight = Reg.RegRead("HKCU\Book\Height") lngWidth = Reg.RegRead("HKCU\Book\Width") If lngHeight < 3510 Then lngHeight = 3510 If lngWidth < 6630 Then lngWidth = 6630 Move lngLeft, lngTop, lngWidth, lngHeight If Reg.RegRead("HKCU\Book\OnTop") = True Then SetTop hWnd, True End Sub Public Sub GetData() On Error Resume Next Dim Cnt As Long lstMain.ItemClear If bPoisk Then If Not Exist(Path & "search.dat") Then Exit Sub Open Path & "search.dat" For Input As #1 Else If Not Exist(Path & "data.dat") Then Exit Sub Open Path & "data.dat" For Input As #1 End If Open Path & "data.dat" For Input As #1 While Not EOF(1) ReDim Preserve User(Cnt) Line Input #1, User(Cnt).strName Line Input #1, User(Cnt).strOtchectvo Line Input #1, User(Cnt).strFamilia Line Input #1, User(Cnt).strAdress Line Input #1, User(Cnt).strDoma Line Input #1, User(Cnt).strKvartira Line Input #1, User(Cnt).strPhone Line Input #1, User(Cnt).strComment lstMain.ItemAdd User(Cnt).strPhone & String(6, " ") & User(Cnt).strName Cnt = Cnt + 1 Wend Close Slider.SetMax lstMain.GetMax End Sub Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) If Not Button = vbLeftButton Then Exit Sub Dim lngY As Long Dim lngX As Long Dim lngHeight As Long Dim lngWidth As Long lngY = (Y \ 13) + 1 lngX = (X \ 13) + 1 lngHeight = (lngY * 13) * Screen.TwipsPerPixelY lngWidth = (lngX * 13) * Screen.TwipsPerPixelX If lngHeight <= 3510 Then lngHeight = 3510 End If If lngWidth <= 6630 Then lngWidth = 6630 End If Height = lngHeight Width = lngWidth End Sub Private Sub Form_Resize() PosControls lstMain.SetValue Slider.Value Cls Line (ScaleWidth - 14, ScaleHeight)-(ScaleWidth, ScaleHeight - 14), vbWhite Line (ScaleWidth - 13, ScaleHeight)-(ScaleWidth, ScaleHeight - 13), vb3DShadow Line (ScaleWidth - 12, ScaleHeight)-(ScaleWidth, ScaleHeight - 12), vb3DShadow Line (ScaleWidth - 10, ScaleHeight)-(ScaleWidth, ScaleHeight - 10), vbWhite Line (ScaleWidth - 9, ScaleHeight)-(ScaleWidth, ScaleHeight - 9), vb3DShadow Line (ScaleWidth - 8, ScaleHeight)-(ScaleWidth, ScaleHeight - 8), vb3DShadow Line (ScaleWidth - 6, ScaleHeight)-(ScaleWidth, ScaleHeight - 6), vbWhite Line (ScaleWidth - 5, ScaleHeight)-(ScaleWidth, ScaleHeight - 5), vb3DShadow Line (ScaleWidth - 4, ScaleHeight)-(ScaleWidth, ScaleHeight - 4), vb3DShadow Line (lstMain.Left - 1, lstMain.Top - 1)-(lstMain.Left + lstMain.Width + 1, lstMain.Top - 1), vb3DShadow Line -(lstMain.Left + lstMain.Width + 1, lstMain.Top + lstMain.Height + 1), vb3DLight Line -(lstMain.Left - 1, lstMain.Top + lstMain.Height + 1), vb3DLight Line -(lstMain.Left - 1, lstMain.Top - 1), vb3DShadow End Sub Private Sub Form_Unload(Cancel As Integer) ' SaveData If blnDial Then butDial_Click On Error Resume Next Reg.RegWrite "HKCU\Book\Top", Top Reg.RegWrite "HKCU\Book\Left", Left Reg.RegWrite "HKCU\Book\Height", Height Reg.RegWrite "HKCU\Book\Width", Width Set Reg = Nothing End Sub Private Sub lstMain_Click(Button As Integer) If Not Button = vbRightButton Then Exit Sub PopupMenu mnuMain End Sub Private Sub mnuAdd_Click() butAdd_Click End Sub Private Sub mnuDelete_Click() butDelete_Click End Sub Private Sub mnuDial_Click() butDial_Click End Sub Private Sub mnuEdit_Click() butEdit_Click End Sub Private Sub mnuMain_Click() If bPoisk Then mnuAdd.Enabled = False mnuDelete.Enabled = False mnuEdit.Enabled = False Else mnuAdd.Enabled = True mnuDelete.Enabled = True mnuEdit.Enabled = True End If End Sub Private Sub Slider_Change() lstMain.SetValue Slider.Value End Sub Private Sub PosControls() lstMain.Height = ScaleHeight - lstMain.Top Slider.Height = lstMain.Height Slider.SetMax lstMain.GetMax Panel.Left = ScaleWidth - Panel.Width - 11 butExit.Left = Panel.Left Slider.Left = Panel.Left - Slider.Width - 8 lstMain.Width = Slider.Left - lstMain.Left - 8 butExit.Top = lstMain.Height End Sub FrmEdit Option Explicit Private Sub butCancel_Click() Unload Me End Sub Private Sub butOk_Click() Dim sLine As String, sInfo As String, bInform As Boolean, arrRecord(7) As String Dim iCount As Integer, iCountLine As Integer, iFileNum As Integer If bPoisk Then If Dir(Path & "data.dat") <> "" Then iCount = 1: iCountLine = 0: bInform = False Open Path & "data.dat" For Input As #1 'Считываем иформацию из файла и проверяем ее на совпадение Do While Not EOF(1) Line Input #1, sInfo Select Case iCount 'Имя Case 1 If InStr(Trim(txtName.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Очество Case 2 If InStr(Trim(txtOtchectvo.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Фамилия Case 3 If InStr(Trim(txtFamilia.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Адрес Case 4 If InStr(Trim(txtAdress.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Дом Case 5 If InStr(Trim(txtdoma.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Квартира Case 6 If InStr(Trim(txtkvartira.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Телефон Case 7 If InStr(Trim(txtPhone.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If 'Комментарий Case 8 If InStr(Trim(txtComment.Text), sInfo) <> 0 Then bInform = True iCount = 0 Else iCount = iCount + 1 End If End Select 'Если есть хоть одно совпадение, то записываем всю инфу в файл "search.dat" arrRecord(iCountLine) = sInfo iCountLine = iCountLine + 1 If iCountLine = 8 Then If bInform Then iFileNum = FreeFile Open Path & "search.dat" For Append As #iFileNum For iCountLine = 0 To UBound(arrRecord) Print #iFileNum, arrRecord(iCountLine) Next Close #iFileNum End If Erase arrRecord bInform = False iCountLine = 0 iCount = 1 End If Loop Close 'Показываем результат поиска frmMain.GetData ' bPoisk = False Else MsgBox "Данные не найдены.", vbExclamation Unload Me Exit Sub End If Else With User(lngIndex) .strName = txtName .strOtchectvo = txtOtchectvo .strFamilia = txtFamilia .strAdress = txtAdress .strDoma = txtdoma .strKvartira = txtkvartira .strPhone = txtPhone .strComment = txtComment End With frmMain.SaveData frmMain.GetData End If Unload Me End Sub Private Sub txtPhone_KeyPress(KeyAscii As Integer) If Not IsNumeric(Chr(KeyAscii)) And Not KeyAscii = 8 Then KeyAscii = 0 End Sub Private Sub Form_Load() If Reg.RegRead("HKCU\Book\OnTop") = True Then SetTop hWnd, True End Sub FrmOptions Option Explicit Private Sub butCancel_Click() Unload Me End Sub Private Sub butOk_Click() Reg.RegWrite "HKCU\Book\Port", txtPort Reg.RegWrite "HKCU\Book\OnTop", chkOnTop.Value If optDialMode(0).Value = True Then Reg.RegWrite "HKCU\Book\DialMode", 0 Else Reg.RegWrite "HKCU\Book\DialMode", 1 End If If chkOnTop.Value = 1 Then SetTop frmMain.hWnd, True Else SetTop frmMain.hWnd, False End If Unload Me End Sub Private Sub Form_Load() On Error Resume Next txtPort = Reg.RegRead("HKCU\Book\Port") chkOnTop.Value = Reg.RegRead("HKCU\Book\OnTop") optDialMode(Reg.RegRead("HKCU\Book\DialMode")).Value = True If Reg.RegRead("HKCU\Book\OnTop") = True Then SetTop hWnd, True End Sub Private Sub Form_Unload(Cancel As Integer) If Not IsNumeric(txtPort) Then MsgBox "Поле номера порта модема должно быть цифровым" Cancel = True End If End Sub Private Sub txtPort_KeyPress(KeyAscii As Integer) If Not IsNumeric(Chr(KeyAscii)) And Not KeyAscii = 8 Then KeyAscii = 0 End Sub FrmAbout Option Explicit Private Sub butOk_Click() Unload Me End Sub ModMain Option Explicit Public Declare Function DrawEdge Lib "user32" (ByVal hdc As Long, qrc As Rect, ByVal edge As Long, ByVal grfFlags As Long) As Long Public Declare Function SystemParametersInfoA Lib "user32" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As Any, ByVal fuWinIni As Long) As Long Public Declare Function GetClientRect Lib "user32" (ByVal hWnd As Long, lpRect As Rect) As Long Public Declare Function SetWindowText Lib "user32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long Public 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 Public Type Rect Left As Long Top As Long Right As Long Bottom As Long End Type Public Type UserInfo strName As String strOtchectvo As String strFamilia As String strAdress As String strDoma As String strKvartira As String strPhone As String strComment As String End Type Public User() As UserInfo Public lngIndex As Long Public Reg As Object Public blnDial As Boolean Public Const Square As Long = &H1 Or &H2 Or &H4 Or &H8 'Для поиска Public bPoisk As Boolean Sub Main() Set Reg = CreateObject("WSCRIPT.SHELL") If App.PrevInstance = True Then MsgBox "Программа уже запущенна..." Else Load frmMain frmMain.Show End If End Sub Public Sub SetTop(hWnd As Long, Top As Boolean) Select Case Top Case True SetWindowPos hWnd, -1, 0, 0, 0, 0, 1 Or 2 Or 16 Case False SetWindowPos hWnd, -2, 0, 0, 0, 0, 1 Or 2 Or 16 End Select End Sub Public Function Path() As String If Right(App.Path, 1) = "\" Then Path = App.Path Else Path = App.Path & "\" End Function Public Function Exist(strFileName As String) As Boolean If Dir(strFileName) = vbNullString Then Exist = False Else Exist = True End Function Использованные источники и литература 1. Программа помощи VB 2. Материалы сайта http://azbukavb.narod.ru/ 3. Материалы сайта http://void.ru 4. Материалы сайта www.FileArea.co.il
Страницы: 1, 2
|