📄 frmhtk.frm
字号:
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 312
Left = -74280
TabIndex = 11
Top = 600
Width = 1776
End
Begin VB.Label Label5
BackColor = &H0080C0FF&
Caption = "截止日期"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 320
Left = -74415
TabIndex = 10
Top = 936
Visible = 0 'False
Width = 1768
End
Begin VB.Label Label3
BackColor = &H00E0E0E0&
Caption = "截止日期"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 364
Left = -71139
TabIndex = 4
Top = 702
Width = 1651
End
Begin VB.Label Label2
BackColor = &H00E0E0E0&
Caption = "起始日期"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 364
Left = -74883
TabIndex = 3
Top = 702
Width = 1183
End
Begin VB.Label Label1
BackColor = &H00E0E0E0&
Caption = "请输入合同号"
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 315
Left = -74280
TabIndex = 2
Top = 705
Width = 1935
End
End
Begin VB.Menu prin
Caption = "打印"
Begin VB.Menu mnuManual
Caption = "页面控制"
Begin VB.Menu mnuPageUp
Caption = "上页"
End
Begin VB.Menu mnuPageDown
Caption = "下页"
End
Begin VB.Menu mnuZoom
Caption = "显示比例"
End
Begin VB.Menu mnuPaperSize
Caption = "选择纸张"
End
Begin VB.Menu mnuOrientation
Caption = "纸张方向"
End
End
Begin VB.Menu mnuPreview
Caption = "预览"
End
Begin VB.Menu mnuPrint
Caption = "打印"
End
Begin VB.Menu mnunull
Caption = "-"
End
Begin VB.Menu mnuExit
Caption = "关闭"
End
End
Begin VB.Menu hlp
Caption = "帮助"
Begin VB.Menu about
Caption = "关于"
End
Begin VB.Menu neirong
Caption = "内容"
End
End
Begin VB.Menu quit
Caption = "退出"
Begin VB.Menu exit
Caption = "退出"
End
End
End
Attribute VB_Name = "frmhtk"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit 'CODE Manger By BcodeXRose
Dim listindex1
Dim listindex2
Private Const MARGIN_SIZE = 60 ' 单位为缇
' 列拖拽变量
Dim sj, drq
Private m_bDragOK As Boolean
Private m_iDragCol As Integer
Private xdn As Integer, ydn As Integer
Dim sj1, sj2 As String
Dim le%, istr%
Dim ljsj
Dim ljfz
Dim headle
Dim i, j
'##################################################################
'## 过程名称：Command2_Click
'## 参数： 无
'##################################################################
Private Sub Command2_Click()
datPrimaryRS.RecordSource = "select hth as 票号,htl as 合同量,yfl as 已发量,wfl as 欠存量,hwm as 货物名,fhr as 发货人,fhdw as 发货单位,dj as 单价,je as 金额,sj as 发货时间,ysfs as 运输方式,jsfs as 结算方式,bz as 备注 from htk where wfl" & Trim(Me.Combo1.Text) & Val(Me.Text3.Text) & " and ysfs not like '%船%' and je>0 order by sj"
datPrimaryRS.refresh
Call js
End Sub
'##################################################################
'## 过程名称：DTPicker2_Change
'## 参数： 无
'##################################################################
Private Sub DTPicker2_Change()
datPrimaryRS.RecordSource = "select hth as 票号,htl as 合同量,yfl as 已发量,wfl as 欠存量,hwm as 货物名,fhr as 发货人,fhdw as 发货单位,dj as 单价,je as 金额,sj as 发货时间,ysfs as 运输方式,jsfs as 结算方式,bz as 备注 from htk where ysfs not like '%船%' and sj>='" & Format(DTPicker1.Value, "yyyy-mm-dd") & "' and sj <= '" & Format(DTPicker2.Value, "yyyy-mm-dd") & "'and je>0 order by sj"
datPrimaryRS.refresh
'DataGrid1.refresh
Call js
End Sub
'##################################################################
'## 过程名称：DTPicker2_Click
'## 参数： 无
'##################################################################
Private Sub DTPicker2_Click()
datPrimaryRS.RecordSource = "select hth as 票号,htl as 合同量,yfl as 已发量,wfl as 欠存量,hwm as 货物名,fhr as 发货人,fhdw as 发货单位,dj as 单价,je as 金额,sj as 发货时间,ysfs as 运输方式,jsfs as 结算方式,bz as 备注 from htk where ysfs not like '%船%' and sj>='" & Format(DTPicker1.Value, "yyyy-mm-dd") & "' and sj <= '" & Format(DTPicker2.Value, "yyyy-mm-dd") & "'and je>0 order by sj"
datPrimaryRS.refresh
Call js
End Sub
Private Sub exit_Click()
Unload Me
End Sub
'##################################################################
'## 过程名称：Form_Load
'## 参数： 无
'##################################################################
Private Sub Form_Load()
' Me.datPrimaryRS.refresh
Me.DTPicker1.Value = Now - 30
Me.DTPicker2.Value = Now
Dim llen
Dim ii
' llen = Me.datPrimaryRS.Recordset.RecordCount
' With Me.MSHFlexGrid1
' .Row = 0
'.ColWidth(0) = 800
' .ColWidth(1) = 1000
' For ii = 2 To llen
' .ColWidth(ii) = 1000
' Next ii
' End With
Me.datPrimaryRS.ConnectionString = connetstr
End Sub
'##################################################################
'## 过程名称：Form_Resize
'## 参数： 无
'##################################################################
Private Sub Form_Resize()
On Error Resume Next
'当窗体调整时会调整网格
SSTab1.Width = Me.Width - SSTab1.Left * 2
'DataGrid1.DefColWidth = 1000
Me.MSHFlexGrid1.Width = SSTab1.Width
Me.CurtPrinter1.Width = Me.Width - 100
End Sub
'##################################################################
'## 过程名称：Form_Unload
'## 参数：Cancel 为Integer型
'##################################################################
Private Sub Form_Unload(Cancel As Integer)
'Screen.MousePointer = vbDefault
End Sub
Private Sub datPrimaryRS_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
'错误处理程序代码置于此处
'想要忽略错误，注释掉下一行
'想要捕获它们，在此添加代码以处理它们
MsgBox "Data error event hit err:" & Description
End Sub
Private Sub datPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'为这个 recordset 显示当前记录位置
datPrimaryRS.Caption = "Record: " & CStr(datPrimaryRS.Recordset.AbsolutePosition)
End Sub
Private Sub datPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
'验证代码置于此处
'下列动作发生时该事件被调用
Dim bCancel As Boolean
Select Case adReason
Case adRsnAddNew
Case adRsnClose
Case adRsnDelete
Case adRsnFirstChange
Case adRsnMove
Case adRsnRequery
Case adRsnResynch
Case adRsnUndoAddNew
Case adRsnUndoDelete
Case adRsnUndoUpdate
Case adRsnUpdate
End Select
If bCancel Then adStatus = adStatusCancel
End Sub
'##################################################################
'## 过程名称：cmdAdd_Click
'## 参数： 无
'##################################################################
Private Sub cmdAdd_Click()
On Error GoTo AddErr
datPrimaryRS.Recordset.MoveLast
SendKeys "{down}"
Exit Sub
AddErr:
MsgBox Err.Description
End Sub
'##################################################################
'## 过程名称：cmdDelete_Click
'## 参数： 无
'##################################################################
Private Sub cmdDelete_Click()
On Error GoTo DeleteErr
With datPrimaryRS.Recordset
.delete
.MoveNext
If .EOF Then .MoveLast
End With
Exit Sub
DeleteErr:
MsgBox Err.Description
End Sub
'##################################################################
'## 过程名称：cmdRefresh_Click
'## 参数： 无
'##################################################################
Private Sub cmdRefresh_Click()
'只有多用户应用程序需要
On Error GoTo RefreshErr
datPrimaryRS.refresh
Exit Sub
RefreshErr:
MsgBox Err.Description
End Sub
'##################################################################
'## 过程名称：cmdUpdate_Click
'## 参数： 无
'##################################################################
Private Sub cmdUpdate_Click()
On Error GoTo UpdateErr
datPrimaryRS.Recordset.UpdateBatch adAffectAll
Exit Sub
UpdateErr:
MsgBox Err.Description
End Sub
'##################################################################
'## 过程名称：cmdClose_Click
'## 参数： 无
'##################################################################
Private Sub cmdClose_Click()
Unload Me
End Sub
'##################################################################
'## 过程名称：Text1_Change
'## 参数： 无
'##################################################################
Private Sub Text1_Change()
Dim dar As String
dar = Text1.Text
datPrimaryRS.RecordSource = "select hth as 票号,htl as 合同量,yfl as 已发量,wfl as 欠存量,hwm as 货物名,fhr as 发货人,fhdw as 发货单位,dj as 单价,je as 金额,sj as 发货时间,ysfs as 运输方式,jsfs as 结算方式,bz as 备注 from htk where hth like '%" & dar & "%'and je>0 order by sj"
datPrimaryRS.refresh
'DataGrid1.refresh
Call js
End Sub
'##################################################################
'## 过程名称：Text2_Change
'## 参数： 无
'##################################################################
Private Sub Text2_Change()
datPrimaryRS.RecordSource = "select hth as 票号,htl as 合同量,yfl as 已发量,wfl as 欠存量,hwm as 货物名,fhr as 发货人,fhdw as 发货单位,dj as 单价,je as 金额,sj as 发货时间,ysfs as 运输方式,jsfs as 结算方式,bz as 备注 from htk where fhr like '%" & Trim(Text2.Text) & "%' and je>0 order by sj"
datPrimaryRS.refresh
End Sub
'##################################################################
'## 过程名称：js
'## 参数： 无
'##################################################################
Private Sub js()
On Error Resume Next
Dim cols1
Dim rows1
Dim je, i, jryl
Dim ljje
Dim yfl, wfl, htl
Dim pjje
Dim ljjryl
Dim ljhtl
Dim ljyfl
Dim ljwfl
ljhtl = 0
ljjryl = 0
ljyfl = 0
ljwfl = 0
'clos1 = datPrimaryRS.Recordset.Fields.Count
rows1 = Me.datPrimaryRS.Recordset.RecordCount
With Me.MSHFlexGrid1
.Rows = rows1 + 2
For i = 0 To rows1
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -