📄
字号:
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 TreeView_Collapse(ByVal Node As MSComctlLib.Node)
If Node.Index <> 1 And Node.Key <> "T" Then
Node.Image = "Cl"
End If
End Sub
Private Sub TreeView_Expand(ByVal Node As MSComctlLib.Node)
If Node.Index <> 1 And Node.Key <> "T" Then
Node.Image = "O"
End If
End Sub
Private Sub TreeView_NodeClick(ByVal Node As MSComctlLib.Node)
Dim code_row As Integer
With CzxsGrid
code_row = .FindRow(Trim(Mid(TreeView.SelectedItem.Key, 2)), , Sydz("001", GridStr(), Szzls))
If code_row <> -1 Then
.Select code_row, 0
End If
End With
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
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 '其他类型
If Index = 0 Then
Dim i As Integer, LevelLeng As Integer, tf As Boolean
For i = 1 To Len(CodScheme)
LevelLeng = LevelLeng + Val(Mid(CodScheme, i, 1))
If Len(Trim(LrText(0))) = LevelLeng Then
tf = True: Exit For
Else
tf = False
End If
Next i
'--------------
If tf = False Then
Tsxx = "非法编码方式! "
Call Xtxxts(Tsxx, 0, 1)
LrText(Index).SetFocus
Exit Function
End If
'---------------
If Len(Trim(LrText(0))) <> Val(Mid(CodScheme, 1, 1)) Then
With CzxsGrid
ParentCode = Mid(Trim(LrText(0)), 1, LevelLeng - Val(Mid(CodScheme, i, 1)))
code_row = .FindRow(ParentCode, , Sydz("001", GridStr(), Szzls))
If code_row = -1 Then
ParentCode = ""
Tsxx = "没有上级编码! "
Call Xtxxts(Tsxx, 0, 1)
LrText(Index).SetFocus
Exit Function
End If
End With
End If
CodeLevel = i
End If
End Select
'如果有效则加锁,用户不改变内容则不再进行有效性判断
TextValiJudgeLock(Index) = True
'调用文本框事后处理程序
Call Wbklrwbcl(Index)
'有效性判断通过则返回True
TextYxxpd = True
End Function
Sub Add_Tree() '添加树项
Dim aDo_Sort As New Recordset
TreeView.Nodes.Clear
TreeView.Nodes.Add , 4, "T", "部门", "T"
Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select a.*,mj=(select count(*) from Gy_Department where Gy_Department.ParentCode=a.deptCode) from Gy_Department a order by a.deptCode")
With aDo_Sort
Do While Not .EOF
If Trim("" & aDo_Sort!ParentCode) = "" Then
If !mj < 1 Then
Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("deptcode")), "(" & Trim(.Fields("deptcode")) & ")" & Trim(.Fields("deptname")), "C")
Else
Set nodX = TreeView.Nodes.Add("T", 4, "T" & Trim(.Fields("deptcode")), "(" & Trim(.Fields("deptcode")) & ")" & Trim(.Fields("deptname")), "Cl")
End If
nodX.EnsureVisible
Else
If !mj < 1 Then
Set nodX = TreeView.Nodes.Add("T" & Trim(!ParentCode), 4, "T" & Trim(.Fields("deptcode")), "(" & Trim(.Fields("deptcode")) & ")" & Trim(.Fields("deptname")), "C")
Else
Set nodX = TreeView.Nodes.Add("T" & Trim(!ParentCode), 4, "T" & Trim(.Fields("deptcode")), "(" & Trim(.Fields("deptcode")) & ")" & Trim(.Fields("deptname")), "Cl")
End If
End If
.MoveNext
Loop
End With
End Sub
'编码方案
Sub Text_CodScheme()
Dim aDo_Sort As New Recordset
Dim i As Integer, h As Integer
Set aDo_Sort = Cw_DataEnvi.DataConnect.Execute("select * from Gy_CodeScheme where ItemCode='" & Trim(CodSchemeIndex) & "'")
CodScheme = Trim(aDo_Sort!codescheme)
aDo_Sort.Close
'-------------
StTab.Tab = 1
Lbl_codescheme.Caption = ""
For i = 1 To Len(CodScheme)
For h = 1 To Val(Mid(CodScheme, i, 1))
Lbl_codescheme = Lbl_codescheme & "*"
Next
Lbl_codescheme = Lbl_codescheme & " "
Next i
Lbl_codescheme = Trim(Lbl_codescheme)
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -