Attribute VB_Name = "FrmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private Declare Function GetCurrentProcessId Lib "kernel32" () As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, _
ByVal bInheritHandle As Long, ByVal dwProcessID As Long) As Long
Private Declare Function SetPriorityClass Lib "kernel32" (ByVal hProcess As Long, ByVal dwPriorityClass As Long) As Long
Private Declare Function GetPriorityClass Lib "kernel32" (ByVal hProcess As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
' Used by the OpenProcess API call
Private Const PROCESS_QUERY_INFORMATION As Long = &H400
Private Const PROCESS_SET_INFORMATION As Long = &H200
' Used by SetPriorityClass
Private Const NORMAL_PRIORITY_CLASS = &H20
Private Const BELOW_NORMAL_PRIORITY_CLASS = 16384
Private Const ABOVE_NORMAL_PRIORITY_CLASS = 32768
Private Const IDLE_PRIORITY_CLASS = &H40
Private Const HIGH_PRIORITY_CLASS = &H80
Private Const REALTIME_PRIORITY_CLASS = &H100
Public Enum ProcessPriorities
ppidle = IDLE_PRIORITY_CLASS
ppbelownormal = BELOW_NORMAL_PRIORITY_CLASS
ppAboveNormal = ABOVE_NORMAL_PRIORITY_CLASS
ppNormal = NORMAL_PRIORITY_CLASS
ppHigh = HIGH_PRIORITY_CLASS
ppRealtime = REALTIME_PRIORITY_CLASS
End Enum
Private Sub TestConnection()
On Error GoTo TestConnectionErr
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & PathBase & ";Extended Properties=DBase IV"
conState = True
Exit Sub
TestConnectionErr:
MsgBox "Отсутствует подключение к базе", vbCritical + vbOKOnly, "ОШИБКА"
conState = False
End Sub
Private Sub Form_Activate()
If DebugMode Then lblDeb.Visible = True: lblDeb = Sost.Ns & " " & Sost.Napr
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Static est As String
est = est & Chr(KeyAscii)
If Len(est) > 3 Then est = Right$(est, 3)
If est = "egy" Then DebugMode = True: mnuTest.Visible = True
End Sub
Private Sub Form_Load()
Dim ProcessID As Long
Dim hProc As Long
Const fdwAccess1 As Long = PROCESS_QUERY_INFORMATION Or PROCESS_SET_INFORMATION
If App.PrevInstance = True Then
MsgBox "Программа СЛЯБИНГ уже загружена. Не надо вызывать ее еще раз.", 16, "Ошибка пользователя"
End
End If
ProcessID = GetCurrentProcessId()
hProc = OpenProcess(fdwAccess1, 0&, ProcessID)
If hProc Then
SetPriorityClass hProc, ppHigh
CloseHandle hProc
End If
If Environ$("USERNAME") = "egy" Then
DebugMode = True
mnuTest.Visible = True
End If
' Загрузка настроек
If Len(Dir$(App.path & "\Slb.ini")) > 0 Then
Open App.path & "\Slb.ini" For Input As #1
Input #1, PortName
Input #1, Koefin
Input #1, Koefout
Line Input #1, PathStprokat
Line Input #1, PathBase
Close #1
Else
PortName = "Com1"
Koefin = 1
Koefout = 1
PathStprokat = "\\helios\ves_oc\inb\"
PathBase = "\\helios\donix\"
End If
If Len(Dir$(App.path & "\Data.bin")) > 0 Then
Open App.path & "\Data.bin" For Binary As #1
Get #1, , Sost
Close #1
Else
Sost.Ns = 1
Sost.Napr = 1
End If
Ns = Sost.Ns
TestConnection
If Not DebugMode Then Operator = InputBox("ВВЕДИТЕ ВАШУ ФАМИЛИЮ", "Ф.И.О. ОПЕРАТОРА") Else Operator = "EGY"
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
' Взвешивание в цех
Private Sub mnuIn_cex_Click()
Dim s As String
On Error GoTo mnuIn_cex_Err
If Ns > 200 Then
Shell App.path & "\rar.exe m -agddmmyy -ep """ & App.path & "\Архив\.rar"" """ & App.path & "\Печать\*.bin""", vbHide
Ns = 1
Sost.Ns = Ns
MsgBox "Файлы из папки - ПЕЧАТЬ сохранены в архиве", 48, "Сообщение"
End If
If Sost.Napr = 0 Then
MsgBox "Вы уже взвесили в цех!", vbInformation + vbOKOnly, "Сообщение"
Exit Sub
End If
Napr = 0
N_osi = 0
ReDim Ves(N_osi)
frmWess.Show vbModal
Exit Sub
mnuIn_cex_Err:
If Err.Number = 0 Then Exit Sub
MsgBox Err.Description & Chr(13) & "1. Пригласите наладчиков", 16, "ОШИБКА " & Err.Number
End Sub
Private Sub mnu_Oper_Click()
Operator = InputBox("ВВЕДИТЕ ВАШУ ФАМИЛИЮ", "Ф.И.О. ОПЕРАТОРА", Operator)
If Operator = "egy" Then DebugMode = True Else DebugMode = False
End Sub
Private Sub mnu_re_Click()
'frmDubl.Show vbModal
End Sub
Private Sub mnuExit_Click()
Unload Me
End Sub
Private Sub mnuHelp_Click()
Shell "notepad.exe " & App.path & "\Архив\Справка.txt", vbNormalFocus
End Sub
Private Sub mnuOut_cex_Click() ' Взвешивание из цеха
ReDim Ves_osi(150, 10) As Variant
On Error GoTo mnuOut_cex_Err
If Sost.Napr = 1 Then
MsgBox "Вы уже взвесили из цеха!", vbInformation + vbOKOnly, "Сообщение"
Exit Sub
End If
Napr = 1
N_osi = 0
ReDim Ves(N_osi)
frmWess.Show vbModal
Exit Sub
mnuOut_cex_Err:
If Err.Number = 0 Then Exit Sub
MsgBox Err.Description & Chr(13) & "2.Пригласите наладчиков", 16, "ОШИБКА " & Err.Number
End Sub
Private Sub mnuPort_Click()
If Not DebugMode Then Passw.Show vbModal Else frmSettings.Show vbModal
End Sub
Private Sub mnuPr_itog_Click()
frmPrintItog.Show vbModal
End Sub
Private Sub mnuPr_osi_Click()
frmPrintOsi.Show vbModal
End Sub
Private Sub mnunew_Click()
txtLabel.Visible = True
frmDonixEgy.Show vbModal
txtLabel.Visible = False
End Sub
Private Sub mnuTest_Click()
On Error GoTo mnuTest_Err
SaveSost App.path & "\1", Sost
' Dim cn As ADODB.Connection
' Dim rs As ADODB.Recordset
' Set cn = New ADODB.Connection
' Set rs = New ADODB.Recordset
'
' 'cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & ";Extended Properties=DBase IV"
' 'cn.Open "Provider=vfpoledb.1;Data Source=" & App.Path & ";Collating Sequence=general;"
' cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\test.xls;Extended Properties=""Excel 8.0;HDR=No"";"
'
' rs.CursorLocation = adUseClient
'
' 'cn.Execute "CREATE TABLE test1.dbf (N_SOST_IN decimal(4), N_OSI_IN decimal(3), DATA_IN date, TIME_IN char(5), BRUTTO numeric(6,2)" & _
' ",SKOR_IN numeric(3,1), N_SOST_OUT integer, N_OSI_OUT integer, DATA_OUT date, TIME_OUT char(5), TARA single" & _
' ",SKOR_OUT single, NETTO single, VAGON single, PLAVKA single, N_PLAVKI char(7), Koef_IN single" & _
' ",Koef_OUT single, NST char(5), MST char(10), TSLT char(8), KSLT char(8))"
'
' 'cn.Execute "CREATE TABLE test1 (N_SOST_IN decimal(4), N_OSI_IN decimal(3), DATA_IN date, TIME_IN char(5), BRUTTO decimal(6,2)" & _
' ",SKOR_IN decimal(3,1))"
'
'
' cn.Execute "Create Table[list4] (Name char(50), City char(50), Phone char(20), Zip decimal(5))"
'
' 'Set rs = cn.Execute("SELECT * FROM [лист1$]")
' cn.Execute ("INSERT INTO[list4$](F1, F2) VALUES (10,20)")
'' MyDBF.AddColumn "N_SOST", N_Decimal, 4
'' MyDBF.AddColumn "N_OSI", N_Decimal, 3
'' MyDBF.AddColumn "DATA_IN", D_Data_YYYYMMDD, 10
'' MyDBF.AddColumn "TIME_IN", C_String, 5
'' MyDBF.AddColumn "BRUTTO", N_Decimal, 6, 2
'' MyDBF.AddColumn "SKOR_IN", N_Decimal, 3, 1
'' MyDBF.AddColumn "N_SOST", N_Decimal, 4
'' MyDBF.AddColumn "N_OSI", N_Decimal, 3
'' MyDBF.AddColumn "DATA_OUT", D_Data_YYYYMMDD, 10
'' MyDBF.AddColumn "TIME_OUT", C_String, 5
'' MyDBF.AddColumn "TARA", N_Decimal, 6, 2
'' MyDBF.AddColumn "SKOR_OUT", N_Decimal, 3, 1
'' MyDBF.AddColumn "NETTO", N_Decimal, 6, 2
'' MyDBF.AddColumn "VAGON", N_Decimal, 6, 2
'' MyDBF.AddColumn "PLAVKA", N_Decimal, 6, 2
'' MyDBF.AddColumn "N_PLAVKI", C_String, 7
'' MyDBF.AddColumn "Koef_IN", N_Decimal, 6, 4
'' MyDBF.AddColumn "Koef_OUT", N_Decimal, 6, 4
'' MyDBF.AddColumn "NST", C_String, 5
'' MyDBF.AddColumn "MST", C_String, 10
'' MyDBF.AddColumn "TSLT", C_String, 8
'' MyDBF.AddColumn "KSLT", C_String, 8
'
' 'rs.Open "CREATE TABLE test.dbf (First_Name char(50),Last_Name char(50),Address char(50))", cn
' 'rs.Save
'
' rs.Open "SELECT * FROM [лист1$]", cn, adOpenDynamic, adLockBatchOptimistic
' rs.AddNew
' rs.Fields(1) = 10
' rs!N_SOST_IN = 10
' rs!skor_in = 10.5
' 'rs.Update
' rs.UpdateBatch adAffectAllChapters
' 'rs.Save
' rs.Close
' cn.Close
Exit Sub
mnuTest_Err:
MsgBox "Ошибка открытия базы"
End Sub