|
|
Регистрация | << Правила форума >> | FAQ | Пользователи | Календарь | Поиск | Сообщения за сегодня | Все разделы прочитаны |
|
Опции темы | Поиск в этой теме | Опции просмотра |
#1
|
|||
|
|||
Помогите перевести код с VB на Delphi
Товарищи, очень нужна ваша помощь!
описание форм не выкладываю... Откликнувшимся заранее огромное спасибо!!! //..........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
|
||||
|
||||
Я немного знаком с VB
напиши мне в ICQ 587483571 или Skype Anton7773332
Может чем и смогу помочь Я новичок в программировании |
#5
|
|||
|
|||
Админы, удаляйте тему!
|