www.pudn.com > kelon.rar > Form1.frm


VERSION 5.00
Begin VB.Form fInput
Caption = "固定数据录入 V1.01"
ClientHeight = 5940
ClientLeft = 60
ClientTop = 345
ClientWidth = 7905
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Icon = "Form1.frx":0000
LinkTopic = "Form1"
ScaleHeight = 5940
ScaleWidth = 7905
StartUpPosition = 3 'Windows Default
Begin VB.CommandButton comSave
Caption = "保存"
Enabled = 0 'False
Height = 360
Left = 5115
TabIndex = 1
Top = 825
Width = 1410
End
Begin VB.CommandButton comEnd
Caption = "关闭"
Height = 360
Left = 5115
TabIndex = 2
Top = 1245
Width = 1410
End
Begin VB.PictureBox Picture1
Appearance = 0 'Flat
AutoRedraw = -1 'True
BackColor = &amt;H00C0C000&amt;
BorderStyle = 0 'None
ForeColor = &amt;H80000008&amt;
Height = 675
Left = -75
ScaleHeight = 675
ScaleWidth = 7935
TabIndex = 0
Top = 15
Width = 7935
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "基础数据补录"
BeginProperty Font
Name = "宋体"
Size = 26.25
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 525
Left = 1215
TabIndex = 5
Top = 60
Width = 3150
End
End
Begin VB.TextBox Text1
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Index = 0
Left = 1335
TabIndex = 3
Top = 840
Width = 3555
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Ocean"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
ForeColor = &amt;H00000000&amt;
Height = 210
Index = 0
Left = 150
TabIndex = 4
Top = 930
Width = 525
End
End
Attribute VB_Name = "fInput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Private Const LocFileName = "\res\lz_kl_show.ini"
'位置: 20,21,22,23,24,25,26
Dim nrs As New ADODB.Recordset

Dim UID As Long
Dim fieldcount As Long
Dim fielditem() As Long
Dim isstart As Boolean
Dim pNoAutoChang As Boolean

Private Sub initCover()
'得到当前的角色
UID = mod01.pGetString(MOd02.iniFn, "input", "currloc")
'得到能录入的项目
Dim ls As String
Dim arry As Variant
Dim I As Long
ls = mod01.pGetString(MOd02.iniFn, "input", "loc" + Format(UID, "00"))
arry = Split(ls, ",")
fieldcount = UBound(arry)
ReDim fielditem(fieldcount)
ReDim Maintb(fieldcount)
For I = 0 To fieldcount
fielditem(I) = Val(arry(I))
Maintb(I).label = mod01.pGetString(MOd02.iniFn, "field", "item" + Format(fielditem(I), "00"))
Maintb(I).field = mod01.pGetString(MOd02.iniFn, "field", "field" + Format(fielditem(I), "00"))
If I <> 0 Then
Load Text1(I)
Load Label1(I)
Text1(I).Top = Text1(I - 1).Top + Text1(I - 1).Height
Label1(I).Top = Label1(I - 1).Top + Text1(I - 1).Height
End If
Label1(I).Caption = Maintb(I).label
Label1(I).Tag = Maintb(I).field
Next
For I = 0 To fieldcount
Text1(I).Visible = True
Label1(I).Visible = True
Next
End Sub

Private Sub comEnd_Click()
Unload Me
End Sub



Private Sub comSave_Click()
Dim I As Long
Dim sKey As String
For I = 0 To fieldcount
If Text1(I).ForeColor = frmColor(0) Then
Text1(I).ForeColor = frmColor(1)
End If
If Label1(I).Tag = "MT02" Then sKey = Text1(I).Text
If Label1(I).Tag = "MT11" Then MtBase.MT11 = Text1(I).Text
If Label1(I).Tag = "MT12" Then MtBase.MT12 = Text1(I).Text
If Label1(I).Tag = "MT13" Then MtBase.MT13 = Text1(I).Text
If Label1(I).Tag = "MT14" Then MtBase.MT14 = Text1(I).Text
If Label1(I).Tag = "MT09" Then MtBase.MT09 = Text1(I).Text
If Label1(I).Tag = "MT10" Then MtBase.MT10 = Text1(I).Text
Next
If pSaveData(sKey) Then
MsgBox "记录已" + "保存" + ".", 48, "提示"
End If
End Sub

Private Sub Form_Activate()
Text1(0).SetFocus
End Sub

Private Sub Form_Load()
If App.PrevInstance Then
If App.Title = Me.Caption Then
' MsgBox ("注意：程序已经运行，不能再次装载。"), vbExclamation
End
End If
End If
isstart = True
Call GetIniFileName
Call OpenODBC(Cn_Des, "ConnectionString001") '打开数据库

Call pubGetColor(0)
Call initCover
isstart = False
Call SetobjLoc(Me, 20 + UID)
End Sub

Private Sub Form_Terminate()
On Error Resume Next
Cn_Des.Close
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call SaveobjLoc(Me, 20 + UID)
End Sub

Private Sub Text1_Change(Index As Integer)
If isstart Then Exit Sub
If pNoAutoChang Then Exit Sub
Text1(Index).ForeColor = frmColor(0)
End Sub

Private Sub Text1_GotFocus(Index As Integer)
Text1(Index).BackColor = frmColor(2)
End Sub

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
If KeyAscii = 13 Then
If Index = fieldcount Then
comEnd.SetFocus
Else
SendKeys "{tab}"
End If
End If
End Sub

Private Sub Text1_LostFocus(Index As Integer)
Text1(Index).BackColor = frmColor(3)
If Text1(Index).Tag = Text1(Index).Text Then
Else
Text1(Index).ToolTipText = "该项上一次值为: " &amt; Text1(Index).Tag
Text1(Index).Tag = Text1(Index).Text
End If
'查询记录
If Label1(Index).Tag = "MT02" Then
Call pShowData(Index)
End If
End Sub

Private Sub pShowData(ByVal Index As Long)
Dim bgetdata As Boolean: bgetdata = False
Dim sSql As String
Dim I As Long
'存在, 则取数, 不存在, 提醒
sSql = pGetString(iniFn, "SQLstring", "Select00")
sSql = "SELECT " &amt; sSql
sSql = Replace(sSql, "@1@", Text1(Index).Text)
If Text1(Index).Text = "" Then Exit Sub
nrs.Open sSql, Cn_Des, , , adCmdText
On Error GoTo err
With MtBase
.MT02 = nrs.Fields(0).Value
.MT11 = nrs.Fields(1).Value
.MT12 = nrs.Fields(2).Value
.MT13 = nrs.Fields(3).Value
.MT14 = nrs.Fields(4).Value
.MT09 = nrs.Fields(5).Value
.MT10 = nrs.Fields(6).Value
bgetdata = True
On Error GoTo 0
err:
nrs.Close
'显示数据
pNoAutoChang = True
If bgetdata Then
For I = 0 To fieldcount
If Label1(I).Tag = "MT02" Then Text1(I).Text = .MT02
If Label1(I).Tag = "MT11" Then Text1(I).Text = .MT11
If Label1(I).Tag = "MT12" Then Text1(I).Text = .MT12
If Label1(I).Tag = "MT13" Then Text1(I).Text = .MT13
If Label1(I).Tag = "MT14" Then Text1(I).Text = .MT14
If Label1(I).Tag = "MT09" Then Text1(I).Text = .MT09
If Label1(I).Tag = "MT10" Then Text1(I).Text = .MT10
Next
End If
pNoAutoChang = False
End With
comSave.Enabled = bgetdata
End Sub
Private Function pSaveData(ByVal m02 As String) As Boolean
Dim sSql As String
sSql = pGetString(iniFn, "SQLstring", "update00")
sSql = "update " &amt; sSql
On Error GoTo err
pSaveData = False
With MtBase
sSql = Replace(sSql, "@1@", .MT02)
sSql = Replace(sSql, "@2@", .MT11)
sSql = Replace(sSql, "@3@", .MT12)
sSql = Replace(sSql, "@4@", .MT13)
sSql = Replace(sSql, "@5@", .MT14)
sSql = Replace(sSql, "@6@", .MT09)
sSql = Replace(sSql, "@7@", .MT10)
pSaveData = True
Call Cn_Des.Execute(sSql)
End With
On Error GoTo 0
err:
End Function