企业管理

开发平台：

Visual Basic

：源码内容

Do While .CellTop < .FixedRows * .RowHeight(0) And .TopRow <> Toprowte
Toprowte = .TopRow
.TopRow = .TopRow - 1
Loop
End With
End Sub
Private Sub Xldql() '显露当前列
Dim Leftcolte As Long
With Grid_Layout
If .Col >= Qslz Then
If .LeftCol > .Col Then
.LeftCol = .Col
End If
Leftcolte = 0
Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
Leftcolte = .LeftCol
.LeftCol = .LeftCol + 1
Loop
End If
End With
End Sub
Private Sub Xldql2() '显露当前列
Dim Leftcolte As Long
With Grid_Datum
If .Col >= Qslz Then
If .LeftCol > .Col Then
.LeftCol = .Col
End If
Leftcolte = 0
Do While .CellLeft + .CellWidth > .Width And .LeftCol <> Leftcolte
Leftcolte = .LeftCol
.LeftCol = .LeftCol + 1
Loop
End If
End With
End Sub
Private Function sjzdyxxpd(Dqpdwgh As Long, Dqpdwgl As Long) '录入数据字段有效性判断,同时进行字段录入事后处理
Dim Str_Text As String '临时有效性判断字段内容
Dim Coljsq As Long '临时列计数器
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Dim RecMate As New Recordset
Dim Temp_Str As String
Dim Temp_Int As Integer
With Grid_Layout
'非录入状态有效性为合法
If Yxxpdlock1 Or .Row < .FixedRows Then
sjzdyxxpd = True
Exit Function
End If
Str_Text = Trim(.TextMatrix(Dqpdwgh, Dqpdwgl))
Select Case GridStr1(Dqpdwgl, 1)
'以下为自定义部分[
Case "001" '附属物编码
If Str_Text <> "" Then
Sqlstr = "SELECT Cask_Wrappage.WrappageName,Cask_Wrappage.WrappageCode," & _
"Gy_UnitSet.UnitName FROM Cask_Wrappage LEFT OUTER JOIN Gy_UnitSet ON " & _
"Cask_Wrappage.UnitCode =Gy_UnitSet.UnitCode where WrappageCode='" & Trim(Str_Text) & "' or WrappageName='" & Trim(Str_Text) & "'"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If RecTemp.EOF Then
Tsxx = "此附属物不存在!"
Dqpdwgl = Sydz("001", GridStr1(), Szzls)
GoTo Lrcwcl
End If
Temp_Int = 0
For i = .FixedRows To .Rows - 1
If .TextMatrix(i, Sydz("001", GridStr1(), Szzls)) <> "" Then
If Trim(.TextMatrix(i, Sydz("001", GridStr1(), Szzls))) = Str_Text Then
Temp_Int = Temp_Int + 1
If Temp_Int > 1 Then
Tsxx = "此附属物已存在!"
GoTo Lrcwcl
End If
End If
End If
Next i
If Str_Text = Trim(LrText(0).Text) Then
Tsxx = "此包装物不能又是该包装物的附属物!"
GoTo Lrcwcl
End If
.TextMatrix(Dqpdwgh, Sydz("001", GridStr1(), Szzls)) = Trim("" & RecTemp!WrappageCode) '附属物编码
.TextMatrix(Dqpdwgh, Sydz("002", GridStr1(), Szzls)) = Trim("" & RecTemp!WrappageName) '附属物名称
.TextMatrix(Dqpdwgh, Sydz("003", GridStr1(), Szzls)) = Trim("" & RecTemp!UnitName) '计量单位
Else
.TextMatrix(Dqpdwgh, Sydz("002", GridStr1(), Szzls)) = "" '附属物名称
.TextMatrix(Dqpdwgh, Sydz("003", GridStr1(), Szzls)) = "" '计量单位
End If
Case "004" '单价
If InStr(1, Str_Text, ".") = 0 Then
If Len(Str_Text) > 12 Then
Tsxx = "单价录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
Else
If InStr(1, Str_Text, ".") > 13 Then
Tsxx = "单价录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
End If
Case "005" '数量
If InStr(1, Str_Text, ".") = 0 Then
If Len(Str_Text) > 12 Then
Tsxx = "数量录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
Else
If InStr(1, Str_Text, ".") > 13 Then
Tsxx = "数量录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
End If
'2.放置字段事后处理程序
'以上为自定义部分]
End Select
'字段录入正确后为零字段清空
Call Qkwlzd(Dqpdwgh, Dqpdwgl)
sjzdyxxpd = True
Yxxpdlock1 = True
Exit Function
End With
Lrcwcl: '录入错误处理
With Grid_Layout
Call Xtxxts(Tsxx, 0, 1)
changelock1 = True
.Select Dqpdwgh, Dqpdwgl
changelock1 = False
Call xswbk
sjzdyxxpd = False
Exit Function
End With
End Function
Private Function sjzdyxxpd2(Dqpdwgh As Long, Dqpdwgl As Long) '录入数据字段有效性判断,同时进行字段录入事后处理
Dim Str_Text As String '临时有效性判断字段内容
Dim Coljsq As Long '临时列计数器
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Dim RecMate As New Recordset
Dim Temp_Str As String
Dim Temp_Int As Integer
With Grid_Datum
'非录入状态有效性为合法
If Yxxpdlock2 Or .Row < .FixedRows Then
sjzdyxxpd2 = True
Exit Function
End If
Str_Text = Trim(.TextMatrix(Dqpdwgh, Dqpdwgl))
Select Case GridStr2(Dqpdwgl, 1)
'以下为自定义部分[
Case "001" '包装物编码
If Trim(Str_Text) = "" Then
.TextMatrix(Dqpdwgh, Sydz("002", GridStr2(), Szzls)) = "" '物料名称
.TextMatrix(Dqpdwgh, Sydz("003", GridStr2(), Szzls)) = "" '规格型号
.TextMatrix(Dqpdwgh, Sydz("004", GridStr2(), Szzls)) = "" '计量单位
Else
Sqlstr = "SELECT Gy_Material.MNumber,Gy_Material.MName,Gy_Material.Model,Gy_UnitSet.UnitName,Gy_Material.StopFlag " & _
"FROM Gy_Material LEFT OUTER JOIN Gy_UnitSet ON Gy_Material.PrimaryUnit = " & _
"Gy_UnitSet.UnitCode where StopFlag<>1 and (Gy_Material.MNumber='" & Trim(Str_Text) & "' or Gy_Material.MNumber='" & Trim(Str_Text) & "')"
Set RecTemp = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Not RecTemp.EOF Then
.TextMatrix(Dqpdwgh, Sydz("001", GridStr2(), Szzls)) = Trim("" & RecTemp!MNumber) '物料编号
.TextMatrix(Dqpdwgh, Sydz("002", GridStr2(), Szzls)) = Trim("" & RecTemp!MName) '物料名称
.TextMatrix(Dqpdwgh, Sydz("003", GridStr2(), Szzls)) = Trim("" & RecTemp!model) '规格型号
.TextMatrix(Dqpdwgh, Sydz("004", GridStr2(), Szzls)) = Trim("" & RecTemp!UnitName) '计量单位
Else
Tsxx = "此物料不存在或已停用!"
Dqpdwgl = Sydz("001", GridStr1(), Szzls)
GoTo Lrcwcl
End If
Temp_Int = 0
If Str_Text <> "" Then
For i = .FixedRows To .Rows - 1
If .TextMatrix(i, Sydz("001", GridStr1(), Szzls)) <> "" Then
If Trim(.TextMatrix(i, Sydz("001", GridStr1(), Szzls))) = Str_Text Then
Temp_Int = Temp_Int + 1
If Temp_Int > 1 Then
Tsxx = "此编码已存在!"
GoTo Lrcwcl
End If
End If
End If
Next i
End If
End If
Case "005" '单价
If InStr(1, Str_Text, ".") = 0 Then
If Len(Str_Text) > 12 Then
Tsxx = "单价录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
Else
If InStr(1, Str_Text, ".") > 13 Then
Tsxx = "单价录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
End If
Case "006" '数量
If InStr(1, Str_Text, ".") = 0 Then
If Len(Str_Text) > 12 Then
Tsxx = "数量录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
Else
If InStr(1, Str_Text, ".") > 13 Then
Tsxx = "数量录入数值超长，请重新输入!"
GoTo Lrcwcl
End If
End If
'2.放置字段事后处理程序
'以上为自定义部分]
End Select
'字段录入正确后为零字段清空
Call Qkwlzd2(Dqpdwgh, Dqpdwgl)
sjzdyxxpd2 = True
Yxxpdlock2 = True
Exit Function
End With
Lrcwcl: '录入错误处理
With Grid_Datum
Call Xtxxts(Tsxx, 0, 1)
changelock2 = True
.Select Dqpdwgh, Dqpdwgl
changelock2 = False
Call xswbk2
sjzdyxxpd2 = False
Exit Function
End With
End Function
Private Sub Qkwlzd(sjh As Long, Sjl As Long) '清空为零字段
If Not GridBoolean1(Sjl, 5) Then
Exit Sub
End If
With Grid_Layout
If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
.TextMatrix(sjh, Sjl) = ""
End If
End With
End Sub
Private Sub Qkwlzd2(sjh As Long, Sjl As Long) '清空为零字段
If Not GridBoolean2(Sjl, 5) Then
Exit Sub
End If
With Grid_Datum
If Val(Trim(.TextMatrix(sjh, Sjl))) = 0 Then
.TextMatrix(sjh, Sjl) = ""
End If
End With
End Sub
Private Function pdhwk(sjh As Long) '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
With Grid_Layout
For Coljsq = Qslz To .Cols - 1
If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean1(Coljsq, 1) Then
pdhwk = False
Exit Function
End If
Next Coljsq
pdhwk = True
End With
End Function
Private Function pdhwk2(sjh As Long) '判断网格行是否为空行(所有录入字段均为空*非录入字段除外)
With Grid_Datum
For Coljsq = Qslz To .Cols - 1
If Len(Trim(.TextMatrix(sjh, Coljsq))) <> 0 And GridBoolean2(Coljsq, 1) Then
pdhwk2 = False
Exit Function
End If
Next Coljsq
pdhwk2 = True
End With
End Function
Private Function Sjhzyxxpd(ByVal Yxxpdh As Long) As Boolean '录入数据行有效性判断,同时进行行处理
Dim Lrywlz As Long
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Dim Bln_AssVali As Boolean '辅助核算错误
With Grid_Layout
'判断行为空和无效数据行则清除当前行
If .Rows <= .FixedRows Then Exit Function ' 如果没有记录，则退出
If .TextMatrix(Yxxpdh, 0) <> "*" Then
Sjhzyxxpd = True
Exit Function
Else
If pdhwk(Yxxpdh) And Yxxpdh + 1 <= .Rows - 1 Then
If .TextMatrix(Yxxpdh + 1, 0) <> "*" Then
changelock1 = True
.RemoveItem Yxxpdh
If .Rows < Pmbcsjhs1 + .FixedRows + Fzxwghs1 + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
changelock1 = False
Sjhzyxxpd = True
Exit Function
End If
End If
End If
'行没有发生变化则不进行有效性判断
If Hyxxpdlock1 Then
Sjhzyxxpd = True
Exit Function
End If
'以下为自定义部分[
'1.放置行有效性判断程序
'首先进行为空判断(固定不变)
For Jsqte = Qslz To .Cols - 1
If (GridInt1(Jsqte, 5) = 1 And Len(Trim(.TextMatrix(Yxxpdh, Jsqte))) = 0) Or (GridInt1(Jsqte, 5) = 2 And Val(Trim(.TextMatrix(Yxxpdh, Jsqte))) = 0) Then
If Not .ColHidden(Jsqte) Then
Tsxx = GridStr1(Jsqte, 2)
Lrywlz = Jsqte
SSTab1.Tab = 1
GoTo Lrcwcl
Exit For
End If
End If
Next Jsqte
'2.[自定义判断(补丁)
'2.放置行处理程序
'以上为自定义部分]
End With
Sjhzyxxpd = True
Hyxxpdlock1 = True
Exit Function
Lrcwcl: '录入错误处理
With Grid_Layout
Call Xtxxts(Tsxx, 0, 1)
changelock1 = True
.Select Yxxpdh, Lrywlz
changelock1 = False
Call xswbk
Sjhzyxxpd = False
Exit Function
End With
End Function
Private Function Sjhzyxxpd2(ByVal Yxxpdh As Long) As Boolean '录入数据行有效性判断,同时进行行处理
Dim Lrywlz As Long
Dim RecTemp As New ADODB.Recordset '临时使用动态集
Dim Bln_AssVali As Boolean '辅助核算错误
With Grid_Datum
'判断行为空和无效数据行则清除当前行
If .Rows <= .FixedRows Then Exit Function ' 如果没有记录，则退出
If .TextMatrix(Yxxpdh, 0) <> "*" Then
Sjhzyxxpd2 = True
Exit Function
Else
If pdhwk2(Yxxpdh) And Yxxpdh + 1 <= .Rows - 1 Then
If .TextMatrix(Yxxpdh + 1, 0) <> "*" Then
changelock2 = True
.RemoveItem Yxxpdh
If .Rows < Pmbcsjhs2 + .FixedRows + Fzxwghs2 + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
changelock2 = False
Sjhzyxxpd2 = True
Exit Function
End If
End If
End If
'行没有发生变化则不进行有效性判断
If Hyxxpdlock2 Then
Sjhzyxxpd2 = True
Exit Function
End If
'以下为自定义部分[
'1.放置行有效性判断程序
'首先进行为空判断(固定不变)
For Jsqte = Qslz To .Cols - 1
If (GridInt2(Jsqte, 5) = 1 And Len(Trim(.TextMatrix(Yxxpdh, Jsqte))) = 0) Or (GridInt2(Jsqte, 5) = 2 And Val(Trim(.TextMatrix(Yxxpdh, Jsqte))) = 0) Then
If Not .ColHidden(Jsqte) Then
Tsxx = GridStr2(Jsqte, 2)
Lrywlz = Jsqte
SSTab1.Tab = 2
GoTo Lrcwcl
Exit For
End If
End If
Next Jsqte
'2.[自定义判断(补丁)
'2.放置行处理程序
'以上为自定义部分]
End With
Sjhzyxxpd2 = True
Hyxxpdlock2 = True
Exit Function
Lrcwcl: '录入错误处理
With Grid_Datum
Call Xtxxts(Tsxx, 0, 1)
changelock2 = True
.Select Yxxpdh, Lrywlz
changelock2 = False
Call xswbk2
Sjhzyxxpd2 = False
Exit Function
End With
End Function
Private Sub Grid_Layout_DblClick()
With Grid_Layout
Call xswbk
End With
End Sub
Private Sub Grid_Datum_DblClick()
With Grid_Datum
Call xswbk2
End With
End Sub
Private Sub Grid_Layout_EnterCell() '显示当前数据行相关信息
With Grid_Layout
If .Row >= .FixedRows Then
Lab_Row = Trim(Str(.Row - .FixedRows + 1))
End If
End With
End Sub
Private Sub Grid_Datum_EnterCell() '显示当前数据行相关信息
With Grid_Datum
If .Row >= .FixedRows Then
Lab_Row = Trim(Str(.Row - .FixedRows + 1))
End If
End With
End Sub
Private Sub Grid_Layout_GotFocus() '网格得到焦点
'网格得到焦点,如果当前选择行为非数据行
'则调整当前焦点至有效数据行
With Grid_Layout
If .Row < .FixedRows And .Rows > .FixedRows Then
changelock1 = True
.Select .FixedRows, .Col
changelock1 = False
End If
If .Col < Qslz Then
changelock1 = True
.Select .Row, Qslz
changelock1 = False
End If
End With
End Sub
Private Sub Grid_Datum_GotFocus() '网格得到焦点
'网格得到焦点,如果当前选择行为非数据行
'则调整当前焦点至有效数据行
GridInteger = 1
With Grid_Datum
If .Row < .FixedRows And .Rows > .FixedRows Then
changelock2 = True
.Select .FixedRows, .Col
changelock2 = False
End If
If .Col < Qslz Then
changelock2 = True
.Select .Row, Qslz
changelock2 = False
End If
End With
End Sub
Private Sub Grid_Layout_KeyDown(KeyCode As Integer, Shift As Integer) '网格录入增行，删行快捷键
'如果单据操作状态为浏览状态则不能显示录入载体
Select Case KeyCode
Case vbKeyDelete '删行
Call Scdqfl
Case vbKeyInsert '增行
Call zjlrfl
End Select
End Sub
Private Sub Grid_Datum_KeyDown(KeyCode As Integer, Shift As Integer) '网格录入增行，删行快捷键
'如果单据操作状态为浏览状态则不能显示录入载体
Select Case KeyCode
Case vbKeyDelete '删行
Call Scdqfl2
Case vbKeyInsert '增行
Call zjlrfl2
End Select
End Sub
Private Sub zjlrfl() '增加录入分录
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
With Grid_Layout
If Not (Ydtext.Visible Or YdCombo.Visible) Then
If Not Fun_Drfrmyxxpd Then
Exit Sub
End If
Else
Exit Sub
End If
If .Row < .FixedRows Then
Exit Sub
End If
.AddItem "", .Row
.RowHeight(.Row) = Sjhgd1
If .Row <> .Rows - 1 Then
If .TextMatrix(.Row + 1, 0) = "*" Then
.TextMatrix(.Row, 0) = "*"
Else
.RemoveItem .Rows - 1
End If
End If
Call Xldqh
Call Xldql
Hyxxpdlock1 = False
End With
End Sub
Private Sub zjlrfl2() '增加录入分录
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
With Grid_Datum
If Not (Ydtext2.Visible Or YdCombo2.Visible) Then
If Not Fun_Drfrmyxxpd2 Then
Exit Sub
End If
Else
Exit Sub
End If
If .Row < .FixedRows Then
Exit Sub
End If
.AddItem "", .Row
.RowHeight(.Row) = Sjhgd2
If .Row <> .Rows - 1 Then
If .TextMatrix(.Row + 1, 0) = "*" Then
.TextMatrix(.Row, 0) = "*"
Else
.RemoveItem .Rows - 1
End If
End If
Call Xldqh2
Call Xldql2
Hyxxpdlock2 = False
End With
End Sub
Private Sub Scdqfl() '删除当前分录
Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
With Grid_Layout
Scqwghz = .Row
Scqwglz = .Col
If .TextMatrix(.Row, 0) = "*" Then
'判断是否为录入状态
If Ydtext.Visible Or YdCombo.Visible Then
Sflrzt = True
Validate = True
Call Lrsjhx
Validate = False
End If
Call Xldqh
changelock1 = True
.Select .Row, 0
changelock1 = False
If Shsfts1 Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
Tsxx = "请确认是否删除当前记录?"
yhAnswer = Xtxxts(Tsxx, 2, 2)
If yhAnswer = 2 Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
changelock1 = True
.Select Scqwghz, Scqwglz
changelock1 = False
'如为录入状态,则恢复录入
If Sflrzt Then
Call xswbk
End If
Exit Sub
End If
End If
.RemoveItem .Row
If .Rows < Pmbcsjhs1 + .FixedRows + Fzxwghs1 + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
changelock1 = True
.Select .Row, Scqwglz
changelock1 = False
'[[ 自定义
']]自定义
' Call Cshhjwg
Grid_Layout.LeftCol = Qslz
End If
End With
End Sub
Private Sub Scdqfl2() '删除当前分录
Dim Answer As Integer, Scqwghz As Long, Scqwglz As Long, Hjlzte As Long, Sflrzt As Boolean
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
With Grid_Datum
Scqwghz = .Row
Scqwglz = .Col
If .TextMatrix(.Row, 0) = "*" Then
'判断是否为录入状态
If Ydtext2.Visible Or YdCombo2.Visible Then
Sflrzt = True
Validate = True
Call Lrsjhx2
Validate = False
End If
Call Xldqh2
changelock2 = True
.Select .Row, 0
changelock2 = False
If Shsfts2 Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = QBColor(12)
Tsxx = "请确认是否删除当前记录?"
yhAnswer = Xtxxts(Tsxx, 2, 2)
If yhAnswer = 2 Then
.Cell(flexcpBackColor, .Row, Qslz, .Row, .Cols - 1) = &H80000005
changelock2 = True
.Select Scqwghz, Scqwglz
changelock2 = False
'如为录入状态,则恢复录入
If Sflrzt Then
Call xswbk2
End If
Exit Sub
End If
End If
.RemoveItem .Row
If .Rows < Pmbcsjhs2 + .FixedRows + Fzxwghs2 + 1 Then
.AddItem ""
.RowHeight(.Rows - 1) = Sjhgd
End If
changelock2 = True
.Select .Row, Scqwglz
changelock2 = False
'[[ 自定义
']]自定义
' Call Cshhjwg
Grid_Datum.LeftCol = Qslz
End If
End With
End Sub
Private Sub Grid_Layout_KeyPress(KeyAscii As Integer) '网格接受键盘录入
Dim Str_ChangeTe As String '临时交换内容
Dim Coljsq As Long '临时列计数器
Dim Int_SaveKey As Integer '保存KeyAscii值
On Error Resume Next
'如果单据操作状态为浏览状态则不能显示录入载体
Int_SaveKey = KeyAscii
With Grid_Layout
'屏蔽回车键
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean1(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Exit Sub
End If
'接受用户录入
Select Case KeyAscii
Case 0 To 32
'显示录入载体
Call xswbk
Case Else
'防止非编辑字段SendKeys()出现死循环
If Not GridBoolean1(.Col, 1) Or .Row < .FixedRows Or .ColHidden(.Col) Then
Exit Sub
End If
If GridBoolean1(.Col, 3) Then
'列表框录入
Call xswbk
Else
Ydtext.Text = ""
Call InputFieldLimit(Ydtext, GridInt1(Grid_Layout.Col, 1), KeyAscii)
If KeyAscii = 0 Then
Exit Sub
End If
'写有效行数据标志
Call Xyxhbz(.Row)
Call xswbk
Ydtext.Text = ""
Valilock1 = True
SendKeys Chr(KeyAscii), True
DoEvents
Valilock1 = False
End If
End Select
End With
End Sub
Private Sub Grid_Datum_KeyPress(KeyAscii As Integer) '网格接受键盘录入
Dim Str_ChangeTe As String '临时交换内容
Dim Coljsq As Long '临时列计数器
Dim Int_SaveKey As Integer '保存KeyAscii值
On Error Resume Next
'如果单据操作状态为浏览状态则不能显示录入载体
Int_SaveKey = KeyAscii
With Grid_Datum
'屏蔽回车键
If KeyAscii = vbKeyReturn Then
KeyAscii = 0
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean2(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Exit Sub
End If
'接受用户录入
Select Case KeyAscii
Case 0 To 32
'显示录入载体
Call xswbk2
Case Else
'防止非编辑字段SendKeys()出现死循环
If Not GridBoolean2(.Col, 1) Or .Row < .FixedRows Or .ColHidden(.Col) Then
Exit Sub
End If
If GridBoolean2(.Col, 3) Then
'列表框录入
Call xswbk2
Else
Ydtext2.Text = ""
Call InputFieldLimit(Ydtext2, GridInt2(Grid_Datum.Col, 1), KeyAscii)
If KeyAscii = 0 Then
Exit Sub
End If
'写有效行数据标志
Call Xyxhbz2(.Row)
Call xswbk2
Ydtext2.Text = ""
Valilock2 = True
SendKeys Chr(KeyAscii), True
DoEvents
Valilock2 = False
End If
End Select
End With
End Sub
Private Sub Lrzdbz() '录入字段帮助
If Not Ydcommand.Visible Then
Exit Sub
End If
Valilock1 = True
With Grid_Layout
'处理通用部分
changelock1 = True '调入另外窗体必须加锁
S1 = .TextMatrix(.Row, 4)
S2 = LrText(1).Tag
Call Drbmhelp(GridInt1(.Col, 6), GridStr1(.Col, 3), Trim(Ydtext.Text))
changelock1 = False
If Len(Xtfhcs) <> 0 Then
If GridInt1(.Col, 7) = 0 Then
Ydtext.Text = Xtfhcs
Else
Ydtext.Text = Xtfhcsfz
End If
End If
' End If
'[>>处理完毕
Valilock1 = False
If Ydtext.Visible Then
Ydtext.SetFocus
End If
End With
End Sub
Private Sub Lrzdbz2() '录入字段帮助
If Not Ydcommand22.Visible Then
Exit Sub
End If
Valilock2 = True
With Grid_Datum
'处理通用部分
changelock2 = True '调入另外窗体必须加锁
S1 = .TextMatrix(.Row, 4)
S2 = LrText(1).Tag
Call Drbmhelp(GridInt2(.Col, 6), GridStr2(.Col, 3), Trim(Ydtext2.Text))
changelock2 = False
If Len(Xtfhcs) <> 0 Then
If GridInt2(.Col, 7) = 0 Then
Ydtext2.Text = Xtfhcs
Else
Ydtext2.Text = Xtfhcsfz
End If
End If
' End If
'[>>处理完毕
Valilock2 = False
If Ydtext2.Visible Then
Ydtext2.SetFocus
End If
End With
End Sub
Private Sub Grid_Layout_LeaveCell() '离开单元格
If changelock1 Then
Exit Sub
End If
'记录刚刚离开网格单元的行列值
Dqlkwgh1 = Grid_Layout.Row
Dqlkwgl1 = Grid_Layout.Col
'判断是否需要录入数据回写
If Not (Ydtext.Visible Or YdCombo.Visible) Then
Exit Sub
End If
Call Lrsjhx
End Sub
Private Sub Grid_Datum_LeaveCell() '离开单元格
If changelock2 Then
Exit Sub
End If
'记录刚刚离开网格单元的行列值
Dqlkwgh2 = Grid_Datum.Row
Dqlkwgl2 = Grid_Datum.Col
'判断是否需要录入数据回写
If Not (Ydtext2.Visible Or YdCombo2.Visible) Then
Exit Sub
End If
Call Lrsjhx2
End Sub
Private Sub Grid_Layout_LostFocus() '录入网格失去焦点
'用以屏蔽调用其它窗体时发生网格失去焦点事件
If changelock1 Then
Exit Sub
End If
'引发网格RowcolChange事件
With Grid_Layout
If Not (Ydtext.Visible Or YdCombo.Visible) Then
.Select 0, 0
End If
End With
End Sub
Private Sub Grid_Datum_LostFocus() '录入网格失去焦点
'用以屏蔽调用其它窗体时发生网格失去焦点事件
If changelock2 Then
Exit Sub
End If
'引发网格RowcolChange事件
With Grid_Datum
If Not (Ydtext2.Visible Or YdCombo2.Visible) Then
.Select 0, 0
End If
End With
End Sub
Private Sub Grid_Layout_RowColChange() '网格录入行列发生变化时,进行有效性判断
Valilock1 = True '屏蔽文本框失去焦点进行有效性判断
With Grid_Layout
If changelock1 Then
Exit Sub
End If
If Not sjzdyxxpd(Dqlrwgh1, Dqlrwgl1) Then
Exit Sub
End If
If .Row <> Dqlkwgh1 Then
If Not Sjhzyxxpd(Dqlkwgh1) Then
Exit Sub
End If
End If
End With
Call fhyxh
Call Xldql
End Sub
Private Sub Grid_Datum_RowColChange() '网格录入行列发生变化时,进行有效性判断
Valilock2 = True '屏蔽文本框失去焦点进行有效性判断
With Grid_Datum
If changelock2 Then
Exit Sub
End If
If Not sjzdyxxpd2(Dqlrwgh2, Dqlrwgl2) Then
Exit Sub
End If
If .Row <> Dqlkwgh2 Then
If Not Sjhzyxxpd2(Dqlkwgh2) Then
Exit Sub
End If
End If
End With
Call fhyxh2
Call Xldql2
End Sub
Private Sub fhyxh() '返回录入数据有效行,同时让得到焦点网格可见
With Grid_Layout
If .Row >= .FixedRows Then
If .TextMatrix(.Row, 0) <> "*" Then
For Rowjsq = .FixedRows To .Rows - 1
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
End If
Next Rowjsq
If Rowjsq <= .Rows - 1 Then
changelock1 = True
.Select Rowjsq, .Col
changelock1 = False
Else
changelock1 = True
.Select .Rows - 1, .Col
changelock1 = False
End If
End If
Call Xldqh
End If
End With
End Sub
Private Sub fhyxh2() '返回录入数据有效行,同时让得到焦点网格可见
With Grid_Datum
If .Row >= .FixedRows Then
If .TextMatrix(.Row, 0) <> "*" Then
For Rowjsq = .FixedRows To .Rows - 1
If .TextMatrix(Rowjsq, 0) <> "*" Then
Exit For
End If
Next Rowjsq
If Rowjsq <= .Rows - 1 Then
changelock2 = True
.Select Rowjsq, .Col
changelock2 = False
Else
changelock2 = True
.Select .Rows - 1, .Col
changelock2 = False
End If
End If
Call Xldqh2
End If
End With
End Sub
Private Sub Grid_Layout_Scroll() '限制用户在录入过程中滚动鼠标
If Gdtlock1 Then
Exit Sub
End If
With Grid_Layout
If Ydtext.Visible Or YdCombo.Visible Then
Gdtlock1 = True
.TopRow = Dqtoprow1
.LeftCol = Dqleftcol1
Gdtlock1 = False
Exit Sub
End If
' HjGrid.LeftCol = .LeftCol
End With
End Sub
Private Sub Grid_Datum_Scroll() '限制用户在录入过程中滚动鼠标
If Gdtlock2 Then
Exit Sub
End If
With Grid_Datum
If Ydtext2.Visible Or YdCombo2.Visible Then
Gdtlock2 = True
.TopRow = Dqtoprow2
.LeftCol = Dqleftcol2
Gdtlock2 = False
Exit Sub
End If
' HjGrid.LeftCol = .LeftCol
End With
End Sub
Private Sub Ydcommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Call Lrzdbz
End Sub
Private Sub Ydcommand22_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Call Lrzdbz2
End Sub
Private Sub Ydcommand2_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '按钮提供帮助
Call Text_Help(Ydcommand2.Tag)
End Sub
Private Sub ydtext_KeyDown(KeyCode As Integer, Shift As Integer)
Dim Rowjsq As Long, Coljsq As Long
With Grid_Layout
Select Case KeyCode
Case vbKeyF2
Call Lrzdbz
Case vbKeyEscape 'ESC 键放弃录入
Valilock1 = True
Call Ycwbk
.SetFocus
Case vbKeyReturn '回车键 =13
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean1(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Case vbKeyUp '上箭头 =38
KeyCode = 0
.SetFocus
Call Lrsjhx
If .Row > .FixedRows Then
.Row = .Row - 1
End If
Case vbKeyDown '下箭头 =40
KeyCode = 0
.SetFocus
Call Lrsjhx
If .Row < .Rows - 1 Then
.Row = .Row + 1
End If
Case vbKeyLeft '左箭头 =37
If .Col - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean1(Qslz, 1)) Then
GoTo jzzx
End If
End If
If Ydtext.SelStart = 0 And .Col > Qslz Then
KeyCode = 0
.SetFocus
Call Lrsjhx
Coljsq = .Col - 1
Do While Coljsq > Qslz
If Coljsq - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean1(Qslz, 1)) Then
GoTo jzzx
End If
End If
If .ColHidden(Coljsq) Or (Not GridBoolean1(Coljsq, 1)) Then
Coljsq = Coljsq - 1
Else
Exit Do
End If
Loop
.Select .Row, Coljsq
End If
jzzx:
Case vbKeyRight '右箭头 =39
wblong = Len(Ydtext.Text)
If (Ydtext.SelStart = wblong Or Ydtext.SelLength = wblong) Then
KeyCode = 0
.SetFocus
Call Lrsjhx
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean1(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
End If
Case Else
End Select
End With
End Sub
Private Sub ydtext2_KeyDown(KeyCode As Integer, Shift As Integer)
Dim Rowjsq As Long, Coljsq As Long
With Grid_Datum
Select Case KeyCode
Case vbKeyF2
Call Lrzdbz2
Case vbKeyEscape 'ESC 键放弃录入
Valilock2 = True
Call Ycwbk2
.SetFocus
Case vbKeyReturn '回车键 =13
KeyCode = 0
.SetFocus
Call Lrsjhx2
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean2(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
Case vbKeyUp '上箭头 =38
KeyCode = 0
.SetFocus
Call Lrsjhx2
If .Row > .FixedRows Then
.Row = .Row - 1
End If
Case vbKeyDown '下箭头 =40
KeyCode = 0
.SetFocus
Call Lrsjhx2
If .Row < .Rows - 1 Then
.Row = .Row + 1
End If
Case vbKeyLeft '左箭头 =37
If .Col - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean2(Qslz, 1)) Then
GoTo jzzx
End If
End If
If Ydtext2.SelStart = 0 And .Col > Qslz Then
KeyCode = 0
.SetFocus
Call Lrsjhx2
Coljsq = .Col - 1
Do While Coljsq > Qslz
If Coljsq - 1 = Qslz Then
If .ColHidden(Qslz) Or (Not GridBoolean2(Qslz, 1)) Then
GoTo jzzx
End If
End If
If .ColHidden(Coljsq) Or (Not GridBoolean2(Coljsq, 1)) Then
Coljsq = Coljsq - 1
Else
Exit Do
End If
Loop
.Select .Row, Coljsq
End If
jzzx:
Case vbKeyRight '右箭头 =39
wblong = Len(Ydtext2.Text)
If (Ydtext2.SelStart = wblong Or Ydtext2.SelLength = wblong) Then
KeyCode = 0
.SetFocus
Call Lrsjhx2
Rowjsq = .Row
Coljsq = .Col + 1
If Coljsq > .Cols - 1 Then
If Rowjsq < .Rows - 1 Then
Rowjsq = Rowjsq + 1
End If
Coljsq = Qslz
End If
Do While Rowjsq <= .Rows - 1
If .ColHidden(Coljsq) Or (Not GridBoolean2(Coljsq, 1)) Then
Coljsq = Coljsq + 1
If Coljsq > .Cols - 1 Then
Rowjsq = Rowjsq + 1
Coljsq = Qslz
End If
Else
Exit Do
End If
Loop
.Select Rowjsq, Coljsq
End If
Case Else
End Select
End With
End Sub
Private Sub ydtext_KeyPress(KeyAscii As Integer) '录入字符事中控制
Call InputFieldLimit(Ydtext, GridInt1(Grid_Layout.Col, 1), KeyAscii)
If KeyAscii <> 0 Then
Call Xyxhbz(Dqlrwgh1)
End If
End Sub
Private Sub ydtext2_KeyPress(KeyAscii As Integer) '录入字符事中控制
Call InputFieldLimit(Ydtext2, GridInt2(Grid_Datum.Col, 1), KeyAscii)
If KeyAscii <> 0 Then
Call Xyxhbz2(Dqlrwgh2)
End If
End Sub
Private Sub ydtext_LostFocus() '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
With Grid_Layout
If Not Valilock1 Then
Call Lrsjhx
If Not sjzdyxxpd(Dqlrwgh1, Dqlrwgl1) Then
Exit Sub
End If
If Not Sjhzyxxpd(Dqlrwgh1) Then
Exit Sub
End If
End If
End With
End Sub
Private Sub ydtext2_LostFocus() '如果由于选中网格之外的控件而发生有效性判断(选中网格会先发生Rowcolchange事件置Valiock为TRUE)
With Grid_Datum
If Not Valilock2 Then
Call Lrsjhx2
If Not sjzdyxxpd2(Dqlrwgh2, Dqlrwgl2) Then
Exit Sub
End If
If Not Sjhzyxxpd2(Dqlrwgh2) Then
Exit Sub
End If
End If
End With
End Sub
Private Function Fun_Drfrmyxxpd() As Boolean '调入其它窗体或功能产生的有效性判断(包括数据回写)
Fun_Drfrmyxxpd = True
With Grid_Layout
'如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
If Ydtext.Visible Or YdCombo.Visible Then
Call Lrsjhx
If Not sjzdyxxpd(Dqlrwgh1, Dqlrwgl1) Then
Fun_Drfrmyxxpd = False
Exit Function
End If
End If
'进行行有效性判断
If Not Sjhzyxxpd(.Row) Then
Fun_Drfrmyxxpd = False
Exit Function
End If
End With
End Function
Private Function Fun_Drfrmyxxpd2() As Boolean '调入其它窗体或功能产生的有效性判断(包括数据回写)
Fun_Drfrmyxxpd2 = True
With Grid_Datum
'如果当前网格处于编辑状态,则先进行数据回写再进行有效性判断
If Ydtext2.Visible Or YdCombo2.Visible Then
Call Lrsjhx2
If Not sjzdyxxpd2(Dqlrwgh2, Dqlrwgl2) Then
Fun_Drfrmyxxpd2 = False
Exit Function
End If
End If
'进行行有效性判断
If Not Sjhzyxxpd2(.Row) Then
Fun_Drfrmyxxpd2 = False
Exit Function
End If
End With
End Function
'*******************以上区域为编写自定义过程区域**********************
'*******************************以下为基本处理程序(固定不变)*******************************************'
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer) '支持热键操作
If Shift = 2 Then
Select Case UCase(Chr(KeyCode))
Case "P" 'Ctrl+P 打印
If SzToolbar.Buttons("dy").Visible And SzToolbar.Buttons("dy").Enabled Then
Call bbyl(False)
End If
Case "A" 'Ctrl+A 增加
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
If SzToolbar.Buttons("zj").Visible And SzToolbar.Buttons("zj").Enabled Then
Call Toolbjzt
Lrzt = 1
Call Cshlrxx(Lrzt)
LrText(0).Enabled = True
LrText(0).SetFocus
End If
Case "D" 'Ctrl+D 删除
If SzToolbar.Buttons("sc").Visible And SzToolbar.Buttons("sc").Enabled Then
Call Scdqjl
End If
End Select
End If
End Sub
Private Sub SzToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "ymsz" '页面设置
Dyymctbl.Show 1
Case "yl" '预览
Call bbyl(True)
Case "dy" '打印
Call bbyl(False)
Case "zj" '增加
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
Exit Sub
End If
Call Toolbjzt
Lrzt = 1
Call Cshlrxx(Lrzt)
LrText(0).Enabled = True
LrText(0).SetFocus
Case "zh" '增行
If SSTab1.Tab = 1 Then
Call zjlrfl
ElseIf SSTab1.Tab = 2 Then
Call zjlrfl2
End If
Case "sh" '删行
If SSTab1.Tab = 1 Then
Call Scdqfl
ElseIf SSTab1.Tab = 2 Then
Call Scdqfl2
End If
Case "xg" '修改
Call Xgdqjl
Case "sc" '删除
Call Scdqjl
Case "sx" '刷新
Call Cxnrtcwg
Case "bz" '帮助
Call F1bz
Case "fh" '退出
Unload Me
End Select
End Sub
Private Sub CzxsGrid_DblClick() '修改当前编码记录
Call Xgdqjl
End Sub
Private Sub Xgdqjl() '修改当前编码记录
'判断用户是否有此功能执行权限,如有则写上机日志(进入)
If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
BcCommand.Enabled = False
End If
If CzxsGrid.Row < CzxsGrid.FixedRows Then
Exit Sub
End If
Call Toolbjzt
Lrzt = 2
If Cshlrxx(Lrzt) Then
LrText(1).SetFocus
LrText(0).Enabled = False
End If
End Sub
Private Sub Toolbjzt() 'Toolbar包装物(编辑包装物)
StTab.TabEnabled(1) = True
StTab.Tab = 1
Frame1.Enabled = True
StTab.TabEnabled(0) = False
CzxsGrid.Enabled = False
With SzToolbar
.Buttons("ymsz").Enabled = False
.Buttons("dy").Enabled = False
.Buttons("yl").Enabled = False
.Buttons("zj").Enabled = False
.Buttons("xg").Enabled = False
.Buttons("sc").Enabled = False
.Buttons("sx").Enabled = False
.Buttons("zh").Enabled = True
.Buttons("sh").Enabled = True
End With
End Sub
Private Sub Toolfbjzt() 'Toolbar包装物(非编辑包装物)
StTab.TabEnabled(0) = True
StTab.Tab = 0
CzxsGrid.Enabled = True
Frame1.Enabled = False
StTab.TabEnabled(1) = False
Lrzt = 0
With SzToolbar
.Buttons("ymsz").Enabled = True
.Buttons("dy").Enabled = True
.Buttons("yl").Enabled = True
.Buttons("zj").Enabled = True
.Buttons("xg").Enabled = True
.Buttons("sc").Enabled = True
.Buttons("sx").Enabled = True
.Buttons("zh").Enabled = False
.Buttons("sh").Enabled = False
End With
End Sub
Private Sub BcCommand_Click() '保存
If Not Fun_Drfrmyxxpd Then
SSTab1.Tab = 1
Exit Sub
End If
If Not Fun_Drfrmyxxpd2 Then
SSTab1.Tab = 2
Exit Sub
End If
If Not Bclrsj Then
Exit Sub
End If
If Lrzt = 2 Then
Call Toolfbjzt
End If
End Sub
Private Sub QxCommand_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) '取消
'避免执行Click程序
Bln_Cancel = True
Call Ycwbk
Call Ycwbk2
Call Cancel
End Sub
Private Sub QxCommand_Click() '取消
If Bln_Cancel Then
Bln_Cancel = False
Exit Sub
End If
Call Cancel
End Sub
Private Sub Cancel() '取消
'文本框加锁
For Jsqte = 0 To Max_Text_Index
TextValiJudgeLock(Jsqte) = True
Next Jsqte
Call Toolfbjzt
End Sub
Private Sub CzxsGrid_BeforeMoveColumn(ByVal Col As Long, Position As Long) '网格列发生移动时自动交换网格索引信息
Call FnBln_RefreshArray(Col, Position, GridStr(), GridInf())
End Sub
Private Sub GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button) '表格格式设置(通用)
Select Case Button.Key
Case "bcgs" '保存表格格式
Call Bcwggs(CzxsGrid, GridCode, GridStr())
Case "hfmrgs" '恢复默认格式
Call Hfmrgs(CzxsGrid, GridCode, GridStr())
Case "szxsxm" '设置显示项目
Call Szxsxm(CzxsGrid, GridCode)
End Select
End Sub
Private Sub bbyl(bbylte As Boolean) '报表打印预览
Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
Bbxbtgs = 1 '报表小标题行数
Bbbwhgs = 0 '报表表尾行数
ReDim Bbxbt(1 To Bbxbtgs)
ReDim bbxbtzzxs(1 To Bbxbtgs)
If Bbbwhgs <> 0 Then
ReDim Bbbwh(1 To Bbbwhgs)
ReDim Bbbwhzzxs(1 To Bbbwhgs)
End If
Bbzbt = ReportTitle
Bbxbt(1) = " "
bbxbtzzxs(1) = 0 '报表行组织形式(0-居左 1-居中 2-居右)
Call Scyxsjb(CzxsGrid) '生成报表数据
Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
If Not bbylte Then
Unload DY_Tybbyldy
End If
End Sub
'************以下为文本框录入处理程序(固定不变部分)*************'
Private Sub Wbklrwbcl(Index As Integer) '文本框录入事后处理程序
'以下为依据实际情况自定义部分[
'在此填写文本框录入事后处理程序
']以上为依据实际情况自定义部分
End Sub
Private Sub LrText_Change(Index As Integer)
'屏蔽程序改变控制
If TextChangeLock Then
Exit Sub
End If
TextValiJudgeLock(Index) = False '打开有效性判断锁
'限制字段录入长度
TextChangeLock = True '加锁(防止执行Lrtext_Change)
Call TextChangeLimit(LrText(Index), Textint(Index, 1)) '去掉无效字符
Select Case Textint(Index, 1)
Case 8, 11 '金额型
Call Sjgskz(LrText(Index), Xtjezws - Xtjexsws - 1, Xtjexsws)
Case 9, 12 '数量型
Call Sjgskz(LrText(Index), Xtslzws - Xtslxsws - 1, Xtslxsws)
Case 10 '单价型
Call Sjgskz(LrText(Index), Xtdjzws - Xtdjxsws - 1, Xtdjxsws)
Case Else '其他小数类型控制
If Textint(Index, 6) <> 0 Or Textint(Index, 7) <> 0 Then
Call Sjgskz(LrText(Index), Textint(Index, 6), Textint(Index, 7))
End If
End Select
TextChangeLock = False '解锁
End Sub
Private Sub LrText_GotFocus(Index As Integer) '文本框得到焦点,显示相应信息
Call TextShow(Index)
CurTextIndex = Index
LrText(Index).SelStart = Len(LrText(Index))
End Sub
Private Sub LrText_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer) '字段按F2键提供帮助
Select Case KeyCode
Case vbKeyF2
Call Text_Help(Index)
End Select
End Sub
Private Sub LrText_KeyPress(Index As Integer, KeyAscii As Integer) '文本框录入事中控制
Call InputFieldLimit(LrText(Index), Textint(Index, 1), KeyAscii)
End Sub
Private Sub LrText_LostFocus(Index As Integer) '文本框失去焦点
'显示相应信息但不能进行有效性判断
End Sub
Private Sub Ydcommand1_MouseDown(Index As Integer, Button As Integer, Shift As Integer, x As Single, y As Single) '按钮提供帮助
Call Text_Help(Index)
End Sub
Private Sub Text_Help(Index As Integer) '录入字段帮助
If Not Textboolean(Index, 1) Then
Exit Sub
End If
'调用帮助
Call Drbmhelp(Textint(Index, 2), Textstr(Index, 4), Trim(LrText(Index).Text))
'根据设置选择显示编码和名称,并进行存储
If Len(Xtfhcs) <> 0 Then
If Textint(Index, 3) = 1 Then
LrText(Index).Text = Xtfhcsfz
LrText(Index).Tag = Xtfhcs
Else
LrText(Index).Text = Xtfhcs
LrText(Index).Tag = Xtfhcsfz
End If
End If
LrText(Index).SetFocus
End Sub
Private Sub TextShow(Index As Integer) '文本框得到焦点,显示相应信息
'填写文本框得到焦点,进行相应信息处理程序
End Sub
Private Sub Wbkcsh() '录入文本框初始化
Dim Jsqte As Integer
'最大录入文本框索引值
Max_Text_Index = Textvar(1)
ReDim TextValiJudgeLock(Max_Text_Index)
For Jsqte = 0 To Max_Text_Index
If Len(Trim(Textstr(Jsqte, 1))) <> 0 Then
If Textboolean(Jsqte, 1) Then
If Jsqte <> 0 And Not Textboolean(Jsqte, 3) Then
Load Ydcommand1(Jsqte)
End If
Ydcommand1(Jsqte).Visible = True
Ydcommand1(Jsqte).Move LrText(Jsqte).Left + LrText(Jsqte).Width, LrText(Jsqte).Top
End If
TextChangeLock = True
LrText(Jsqte).Text = ""
LrText(Jsqte).Tag = ""
If Textint(Jsqte, 5) <> 0 Then
LrText(Jsqte).MaxLength = Textint(Jsqte, 5)
End If
TextChangeLock = False
End If
TextValiJudgeLock(Jsqte) = True
Next Jsqte
End Sub
Private Function TextYxxpd(Index As Integer) As Boolean '文本框有效性判断
Dim Sqlstr As String
Dim Findrec As ADODB.Recordset
'文本框内容未曾改变不进行有效性判断
If TextValiJudgeLock(Index) Then
TextYxxpd = True
Exit Function
End If
'文本框内容为空认为有效,并清空其Tag值
If Trim(LrText(Index)) = "" Then
LrText(Index).Tag = ""
Call Wbklrwbcl(Index)
TextValiJudgeLock(Index) = True
TextYxxpd = True
Exit Function
End If
'可在此加入不做有效性判断的理由
Select Case Textint(Index, 4)
Case 1 '编码型
Sqlstr = Trim(Textstr(Index, 5))
Sqlstr = Replace(Sqlstr, "@", "'" + Trim(LrText(Index).Text) + "'")
Set Findrec = Cw_DataEnvi.DataConnect.Execute(Sqlstr)
If Findrec.EOF Then
SSTab1.Tab = 0
Call Xtxxts(Trim(Textstr(Index, 6)), 0, 1)
LrText(Index).SetFocus
Exit Function
Else
Select Case Textint(Index, 3)
Case 0
If Len(Trim(Textstr(Index, 2))) <> 0 Then
LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
End If
If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
End If
Case 1
If Len(Trim(Textstr(Index, 3) & "")) <> 0 Then
LrText(Index).Text = Trim(Findrec.Fields(Trim(Textstr(Index, 3))))
End If
If Len(Trim(Textstr(Index, 2))) <> 0 Then
LrText(Index).Tag = Trim(Findrec.Fields(Trim(Textstr(Index, 2))))
End If
End Select
End If
Case 2 '日期型
If IsDate(LrText(Index).Text) Then
LrText(Index).Text = Format(LrText(Index).Text, "yyyy-mm-dd")
If Val(Mid(LrText(Index), 1, 4)) < 1900 Then
LrText(Index).Text = "1900" + Mid(LrText(Index), 5, 6)
End If
Else
Tsxx = "非法公历日期!(格式:" + Format(Date, "yyyy-mm-dd") + ")"
Call Xtxxts(Tsxx, 0, 1)
LrText(Index).SetFocus
Exit Function
End If
Case 3 '其他类型
End Select
'如果有效则加锁,用户不改变内容则不再进行有效性判断
TextValiJudgeLock(Index) = True
'调用文本框事后处理程序
Call Wbklrwbcl(Index)
'有效性判断通过则返回True
TextYxxpd = True
End Function