![]() |
|
|
|||||||
| Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
![]() |
|
|
Опции темы | Поиск в этой теме | Опции просмотра |
|
#1
|
|||
|
|||
|
Товарищи, очень нужна ваша помощь!
описание форм не выкладываю... Откликнувшимся заранее огромное спасибо!!! //..........frmSettings.frm.............. Код:
Attribute VB_Name = "frmSettings"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub cmdOk_Click()
PortName = txtPort
Koefin = Val(txtKin)
Koefout = Val(txtKout)
PathStprokat = txtPathStPr
PathBase = txtpathDonix
If Len(PortName) = 0 Then PortName = "Com1"
If Koefin <= 0 Then Koefin = 1
If Koefout <= 0 Then Koefout = 1
If Len(PathStprokat) = 0 Then PathStprokat = "\\helios\ves_oc\inb\"
If Len(PathBase) = 0 Then PathBase = "\\helios\donix\"
Open App.path & "\Slb.ini" For Output As #1
Print #1, PortName
Print #1, Koefin
Print #1, Koefout
Print #1, PathStprokat
Print #1, PathBase
Close #1
Unload Me
End Sub
Private Sub Form_Activate()
txtPort = PortName
txtKin = Koefin
txtKout = Koefout
txtPathStPr = PathStprokat
txtpathDonix = PathBase
End SubПоследний раз редактировалось Admin, 23.12.2010 в 20:41. |
|
#2
|
|||
|
|||
|
//......................frmMain.frm................. .......
Код:
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 |
|
#3
|
|||
|
|||
|
//........................frpPrintItog.frm.......... ...........
Код:
Attribute VB_Name = "frmPrintItog"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim cSopr As SoprInfo
Private Declare Function MoveFile Lib "kernel32" Alias "MoveFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String) As Long
Private Sub Form_Load()
cSopr.Npl = 0
End Sub
Private Sub mnu_open_Click()
Dim i%, j%, k%
Dim s$
Dim SumVes As Single
On Error GoTo Cansel
If txt(1).Text <> "" Then
dlg1.CancelError = True 'установим, чтобы возникала ошибка при щелчке по кнопке Cansel
dlg1.InitDir = App.path & "\Norma\"
dlg1.Filter = "Файлы данных (*.bin)|*.bin"
dlg1.Flags = cdlOFNFileMustExist & cdlOFNHideReadOnly
dlg1.DialogTitle = "Загрузить файл"
dlg1.ShowOpen
Mnu_Open.Enabled = False
Mnu_Print.Enabled = True
Mnu_Trans.Enabled = True
LoadSost dlg1.FileName, cSost
cSost.Sopr = cSopr
Label6.Caption = "Дата взвешивания цех: " & Format(cSost.Ves_in(1).DATA, "dd.mm.yyyy")
Label7.Caption = "Время взвешивания в цех: " & Format(cSost.Ves_in(1).DATA, "hh:NN:ss")
Label8.Caption = "Дата взвешивания из цеха: " & Format(cSost.Ves_out(1).DATA, "dd.mm.yyyy")
Label2.Caption = "Время взвешивания из цеха: " & Format(cSost.Ves_out(1).DATA, "hh:NN:ss")
For j = 1 To cSost.Sopr.Npl
SumVes = 0
For i = cSost.Sopr.Pl(j).N_osi To cSost.Sopr.Pl(j).N_osi + cSost.Sopr.Pl(j).KolTel * 6 - 1
SumVes = SumVes + cSost.Ves_in(i).Ves - cSost.Ves_out(i).Ves
Next i
cSost.Sopr.Pl(j).Ves = SumVes
txt(-1 + 6 * j) = Format(SumVes, "000.0")
Next j
s = Mid$(dlg1.FileName, InStrRev(dlg1.FileName, "\") + 1, Len(dlg1.FileName) - InStrRev(dlg1.FileName, "\") - 4)
Open dlg1.FileName For Binary As #1
Put #1, , cSost
Close #1
Open App.path & "\ASUTP\" & Format(Now, "ddmmyyhhNNss") & ".bin" For Binary As #1
Put #1, , cSost
Close #1
MoveFile dlg1.FileName, App.path & "\Печать\" & s & ".bin"
MoveFile App.path & "\Norma\" & s & ".xls", App.path & "\Печать\" & s & ".xls"
End If
Exit Sub
Cansel:
If Err.Number = cdlCancel Or Err.Number = 0 Then
Exit Sub
Else
MsgBox Err.Description
End If
End Sub
Private Sub mnu_exit_Click()
Unload frmDonixEgy
Unload Me
End Sub
Private Sub mnuBD_Click()
If conState Then
frmDonixEgy.Show vbModal
Else
Exit Sub
End If
End Sub
Private Sub mnu_zapis_Click()
Dim ans As Long, i As Integer, j As Integer
On Error GoTo Cansel
txtCover2.Visible = False
If Len(txtCover2.Text) > 0 Then txtCover2.Text = ""
While Len(Operator) = 0
Operator = InputBox("ВВЕДИТЕ ВАШУ ФАМИЛИЮ", "Ф.И.О. ОПЕРАТОРА", Operator)
Wend
Label4.Caption = " Ф.И.О. оператора: " & Operator
While cSopr.Npl < 1 Or cSopr.Npl > 3
cSopr.Npl = Val(InputBox("ВВЕДИТЕ КОЛИЧЕСТВО ПЛАВОК ", "КОЛИЧЕСТВО ПЛАВОК", 2))
Wend
If Not conState Then
ans = 0
While ans <> 2
cSopr.Pl(1).Npl = InputBox("ВВЕДИТЕ НОМЕР ПЕРВОЙ ПЛАВКИ (7 знаков)", " НОМЕР ПЛАВКИ")
If Len(cSopr.Pl(1).Npl) <> 7 Then ans = MsgBox("НЕПРАВИЛЬНЫЙ НОМЕР ПЛАВКИ", 53, "ОШИБКА") Else ans = 2
Wend
If cSopr.Npl > 1 Then
ans = 0
While ans <> 2
cSopr.Pl(2).Npl = InputBox("ВВЕДИТЕ НОМЕР ВТОРОЙ ПЛАВКИ (7 знаков)", " НОМЕР ПЛАВКИ")
If Len(cSopr.Pl(2).Npl) <> 7 Then ans = MsgBox("НЕПРАВИЛЬНЫЙ НОМЕР ПЛАВКИ", 53, "ОШИБКА") Else ans = 2
Wend
End If
If cSopr.Npl > 2 Then
ans = 0
While ans <> 2
cSopr.Pl(3).Npl = InputBox("ВВЕДИТЕ НОМЕР ТРЕТЬЕЙ ПЛАВКИ (7 знаков)", " НОМЕР ПЛАВКИ")
If Len(cSopr.Pl(3).Npl) <> 7 Then ans = MsgBox("НЕПРАВИЛЬНЫЙ НОМЕР ПЛАВКИ", 53, "ОШИБКА") Else ans = 2
Wend
End If
End If
cSopr.Pl(1).KolTel = Val(InputBox("ВВЕДИТЕ ЧИСЛО ТЕЛЕЖЕК" & Chr(13) & "В ПЕРВОМ СОСТАВЕ", " ЧИСЛО ТЕЛЕЖЕК", 5))
If cSopr.Npl > 1 Then cSopr.Pl(2).KolTel = Val(InputBox("ВВЕДИТЕ ЧИСЛО ТЕЛЕЖЕК" & Chr(13) & "ВО ВТОРОМ СОСТАВЕ", " ЧИСЛО ТЕЛЕЖЕК", 5))
If cSopr.Npl > 2 Then cSopr.Pl(3).KolTel = Val(InputBox("ВВЕДИТЕ ЧИСЛО ТЕЛЕЖЕК" & Chr(13) & "В ТРЕТЬЕМ СОСТАВЕ", " ЧИСЛО ТЕЛЕЖЕК", 5))
cSopr.Pl(1).N_osi = 9
cSopr.Pl(2).N_osi = cSopr.Pl(1).N_osi + cSopr.Pl(1).KolTel * 6
cSopr.Pl(3).N_osi = cSopr.Pl(2).N_osi + cSopr.Pl(2).KolTel * 6
For i = 0 To 6
vLine(i).Y2 = hLine(1 + cSopr.Npl).Y1
Next i
For j = 1 To cSopr.Npl
For i = 0 To 5
txt((j - 1) * 6 + i).Visible = True
Next i
hLine(1 + j).Visible = True
Next j
If conState Then
For j = 1 To cSopr.Npl
MsgBox "Введите сопроводительные данные по " & j & " плавке", 48, "СООБЩЕНИЕ "
frmDonixEgy.Show vbModal
cPl.KolTel = cSopr.Pl(j).KolTel
cPl.N_osi = cSopr.Pl(j).N_osi
cSopr.Pl(j) = cPl
txt((j - 1) * 6 + 0).Text = cSopr.Pl(j).NST
txt((j - 1) * 6 + 1).Text = cSopr.Pl(j).Npl
txt((j - 1) * 6 + 2).Text = cSopr.Pl(j).MST
txt((j - 1) * 6 + 3).Text = cSopr.Pl(j).TSLT
txt((j - 1) * 6 + 4).Text = cSopr.Pl(j).KSLT
Next j
Else
For j = 1 To cSopr.Npl
txt((j - 1) * 6 + 1).Text = cSopr.Pl(j).Npl
Next j
MsgBox "БАЗА НЕДОСТУПНА ", 48, "СОБЩЕНИЕ "
MsgBox "ВВЕДИТЕ САМОСТОЯТЕЛЬНО" & Chr(13) & "сопроводительные данные по плавкам", 48, "НАПОМИНАНИЕ "
End If
Mnu_Open.Enabled = True
Exit Sub
Cansel:
If Err.Number = 0 Then Exit Sub
MsgBox Err.Description & Chr(13) & "11.Пригласите наладчиков", 16, "ОШИБКА " & Err.Number
End Sub
Private Sub Mnu_Print_Click()
CmdCancel.Visible = False
Me.PrintForm
CmdCancel.Visible = True
End Sub
Private Sub Mnu_Trans_Click()
Dim i%
Dim s$
On Error GoTo Mnu_TransErr
txtCover2 = ""
For i = 1 To cSost.Sopr.Npl
If Len(txt((i - 1) * 6 + 5)) = 0 Then
MsgBox "Введите вес плавки", 48, "СООБЩЕНИЕ "
Exit Sub
End If
If txt((i - 1) * 6 + 1) <> "" And txt((i - 1) * 6 + 1) <> "0000000" Then
txtCover2 = txtCover2 & txt((i - 1) * 6 + 1) & " " & _
Format(cSost.Ves_in(cSost.Sopr.Pl(i).N_osi).DATA, "dd/mm/yyyy") & " " & _
Format(cSost.Ves_in(cSost.Sopr.Pl(i).N_osi).DATA, "hh:mm") & " " & _
Format(cSost.Sopr.Pl(i).Ves, "000.0") & vbCrLf
End If
Next i
txtCover1.Visible = True
txtCover2.Visible = True
DoEvents
Open PathStprokat & "\" & Format(Now, "ddmmhhmm") & ".txt" For Output As #1
Print #1, txtCover2
Close #1
Open App.path & "\ASUTP\" & Format(Now, "ddmmhhmm") & ".txt" For Output As #1
Print #1, txtCover2
Close #1
Mnu_Trans.Enabled = False
Mnu_Open.Enabled = False
Exit Sub
Mnu_TransErr:
If Err.Number = 0 Then Exit Sub
If Err.Number = 75 Or Err.Number = 52 Then
MsgBox Err.Description & Chr(13) & " БАЗА СТАЛЬ-ПРОКАТ НЕДОСТУПНА", 16, "ОШИБКА " & Err.Number
Else
MsgBox Err.Description & Chr(13) & "12.Пригласите наладчиков", 16, "ОШИБКА " & Err.Number
End If
End Sub
Private Sub cmdCancel_Click()
Unload frmDonixEgy
Unload frmPrintItog
End Sub
Private Sub txt_DblClick(Index As Integer)
Dim j%
j = 1 + Index \ 6
cPl.KolTel = cSost.Sopr.Pl(j).KolTel
cPl.N_osi = cSost.Sopr.Pl(j).N_osi
cSost.Sopr.Pl(j) = cPl
txt((j - 1) * 6 + 0).Text = cSost.Sopr.Pl(j).NST
txt((j - 1) * 6 + 1).Text = cSost.Sopr.Pl(j).Npl
txt((j - 1) * 6 + 2).Text = cSost.Sopr.Pl(j).MST
txt((j - 1) * 6 + 3).Text = cSost.Sopr.Pl(j).TSLT
txt((j - 1) * 6 + 4).Text = cSost.Sopr.Pl(j).KSLT
End SubПоследний раз редактировалось Admin, 23.12.2010 в 21:00. |
|
#4
|
||||
|
||||
|
напиши мне в ICQ 587483571 или Skype Anton7773332
Может чем и смогу помочь ![]() |
|
#5
|
|||
|
|||
|
Админы, удаляйте тему!
![]() |