源程序清单
身份验证
Private Declare Function SQLDataSources Lib "ODBC32.DLL" (ByVal henv&, ByVal fDirection%, ByVal szDSN$, ByVal cbDSNMax%, pcbDSN%, ByVal szDescription$, ByVal cbDescriptionMax%, pcbDescription%) As Integer
Private Declare Function SQLAllocEnv% Lib "ODBC32.DLL" (env&)
Const SQL_SUCCESS As Long = 0
Const SQL_FETCH_NEXT As Long = 1
Dim sSql As String
Dim strConn As String
Private Sub btnCancel_Click()
gbPassed = False
Unload Me
End Sub
'根据用户名和口令从表operator中验证合法性
Private Sub btnOK_Click()
Dim Cnn As New ADODB.Connection
Dim cmd As New ADODB.Command
Dim rcs As New ADODB.Recordset
Dim sDbErr As String
Dim i As Integer
On Error GoTo ConflictHandler
'测试版开关
If TestVersion = "TRUE" Then
gsTestBegin = GetIniS(gsAppName, "TestBegin", vbNullString)
If TestEnd Then MsgBox "试用版已到期！", vbCritical, "提示": End
End If
' MsgBar "正在验证权限", True
'验证加密狗
'If (Version = "SINGLE") And (TestVersion = "FALSE") Then
'If (VBReadKey(37) <> 37) Then
' MsgBox "请合法使用加密狗！", vbOKOnly, "警告！"
' Screen.MousePointer = vbDefault
' Exit Sub
'End If
'End If
'=======SA用户:如果有创建的数据库,可以进行设置,如果未创建数据库,先进行创建,再设置
'=======普通拥护:如果设置了工作站点,可以进行工作
gsDSN = cboDSNList.Text
gsConnTimeOut = txtTimeOut.Text
gsOperator = txtUser.Text
gsOperatorPassWord = txtPws.Text
gsCnnMastdbStr = sFormConnectStr(gsDSN, gsOperator, gsOperatorPassWord, MasterDatabase)
'验证站点信息初始化情况
If LCase(gsOperator) = "sa" Then
gsUserName = txtUser.Text
gsPassWord = txtPws.Text
gsConnectStr = sFormConnectStr(gsDSN, gsUserName, gsPassWord, SrvDatabaseName)
'"正在检验数据库", True
sSql = "SELECT name FROM sysdatabases WHERE name='" + SrvDatabaseName + "'"
GetRequestData gsCnnMastdbStr, sSql, rcs
If rcs.EOF Then
hadCreDB = False: gbPassed = True
Else
hadCreDB = True: gbPassed = True
End If
Else '普通用户
'列出系统DSN
On Error Resume Next
Dim sLastSta$, sLastUser$
GetDSNsAndDrivers cboDSNList
txtTimeOut.Text = gsConnTimeOut
txtUser.Text = gsOperator
If gsDSN <> "" Then
cboDSNList.Enabled = False
cboDSNList.Text = gsDSN
Else
cboDSNList.Enabled = True
cboDSNList.ListIndex = -1
End If
'cboSta.Text = gsStationID & " " & gsStation
If err.Number <> 0 Then
'cboSta.ListIndex = -1
cboDSNList.Enabled = True
MsgBox err.Number & err.Description
err.Number = 0
'ShowError ""
End If
End Sub
Private Sub txtPws_Change()
gsPassWord = Trim(txtPws.Text)
End Sub
Private Sub txtUser_Change()
' Dim sLastStaID$
' On Error Resume Next
' gsUserName = Trim(txtUser.Text)
' sLastStaID = GetIniS(gsAppName, "StationID", "")
' If LCase(txtUser.Text) = "sa" Then
' Label6.Visible = True
' cboDb.Visible = True
' Label5.Visible = False
' cboSta.Visible = False
' Else
' Label6.Visible = False
' cboDb.Visible = False
' Label5.Visible = True
' cboSta.Visible = True
' If sLastStaID = "" Then
' cboSta.ListIndex = -1
' Else
' cboSta.Text = sLastStaID & " " & GetIniS(gsAppName, "Station", "")
' End If
' End If
End Sub
订户管理
Option Explicit
Dim SQL_Subscibe$, SQL_Subbill$, SQL_SubBack$, SQL_Checks As String, sTitle$
Public bRefreshData As Boolean
Sub RefreshData()
Dim sSql$, sSql1$, sValid$, sLike$
Dim rs As New ADODB.Recordset, sStaID$
MsgBar "正在查找数据", True
sSql = "": sSql1 = "": sValid = ""
GrdSubInf.Clear
GrdSubInf.Rows = 2
If Check5.Value = 1 Then sValid = " status='有效'" Else sValid = " status<>'有效'"
sSql = "select subid,suber,address,tel,logsta,sendsta,nextstation,postroute,papername,firstdate,stopdate,copies,amount,invoice,enlister,isfirst from subscibe WHERE " & sValid ' WCJ UPDATE:加入logsta字段
If UCase(cboOp.Text) = "LIKE" Then sLike = "%" Else sLike = ""
If Check1.Value = 1 Then sSql1 = sSql1 & " AND convert(char(10),logdate,20) BETWEEN '" & Format(dt11.Value, "yyyy-mm-dd") & "' AND '" & Format(dt12.Value, "yyyy-mm-dd") & "'"
If Check2.Value = 1 Then sSql1 = sSql1 & " AND firstdate>= '" & Format(dt21.Value, "yyyy-mm-dd") & "' AND stopdate<= '" & Format(dt22.Value, "yyyy-mm-dd") & "'"
If Check3.Value = 1 Then sSql1 = sSql1 & " AND convert(char(10),editdate,20) BETWEEN '" & Format(dt31.Value, "yyyy-mm-dd") & "' AND '" & Format(dt32.Value, "yyyy-mm-dd") & "'"
If Check4.Value = 1 Then sSql1 = sSql1 & " AND " & cboHide.List(cboItem.ListIndex) & " " & cboOp.Text & " '" & sLike & txtValue.Text & sLike & "' "
If Check6.Value = 1 Then sSql1 = sSql1 & " AND paydate BETWEEN '" & Format(dt41.Value, "yyyy-mm-dd") & "' AND '" & Format(dt42.Value, "yyyy-mm-dd") & "'"
If Check7.Value = 1 Then sSql1 = sSql1 & " and nextstation='" & Trim(Combo1.Text) & "'"
sSql = sSql & sSql1
GetRequestData gsConnectStr, sSql, rs
If Not rs.EOF Then
Set GrdSubInf.DataSource = rs
rs.MoveLast
lblPrompt.Caption = "共" & rs.RecordCount & "条"
Else
lblPrompt.Caption = ""
End If
rs.Close
FormatGrid1 GrdSubInf, sTitle, 1000
MsgBar "", False
End Sub
Private Sub btnrefresh_Click()
On Error GoTo errSQL
MsgBar "正在刷新", True
RefreshData
MsgBar "", False
Exit Sub
errSQL:
ShowError "查询条件有误！"
End Sub
MsgBar "正在初始化数据", True
sTitle = " |<订阅号|<订户名|<地址|<电话|<登录站|<投递站|<投递点|<投递路段|<报刊名称|<订阅开始|<订阅结束|<份数|>金额|<订阅卡(票)|<征订人|<性质"
InitcboItem
'发行点设置
setNextstation
dt11.Value = Date: dt12.Value = Date
dt21.Value = Date: dt22.Value = CDate(DatePart("yyyy", Date) & "-12-31")
dt31.Value = Date: dt32.Value = Date
dt41.Value = Date: dt42.Value = Date
Check5.Value = 1
Check1.Value = 1
MsgBar "", False
Exit Sub
errinit:
ShowError "初始化错误"
End Sub
Private Sub Form_Resize()
On Error Resume Next
fram.Top = Toolbar1.Height
fram.Width = Me.Width - 250
GrdSubInf.Top = fram.Top + fram.Height
GrdSubInf.Width = Me.Width - 250
GrdSubInf.Height = Me.Height - GrdSubInf.Top - 500
FormatGrid1 GrdSubInf, sTitle, 1000
End Sub
Private Sub InitcboItem()
'wcj UPDATE END
'初始化cboItem和cbohide中的内容，cbohide中为实际在数据库中要查找的字段
cboItem.AddItem "订阅号"
cboItem.AddItem "订户名称"
cboItem.AddItem "订户地址"
cboItem.AddItem "订户报刊"
cboItem.AddItem "发行点"
cboItem.AddItem "投递路段"
cboItem.AddItem "行业性质"
cboItem.AddItem "订阅性质"
cboItem.AddItem "卡(票)号"
cboItem.AddItem "征订人"
cboItem.AddItem "备注"
cboItem.AddItem "电话号码"
cboHide.AddItem "subid"
cboHide.AddItem "suber"
cboHide.AddItem "address"
cboHide.AddItem "papername"
cboHide.AddItem "nextstation"
cboHide.AddItem "postroute"
cboHide.AddItem "vocation"
cboHide.AddItem "forfree"
cboHide.AddItem "invoice"
cboHide.AddItem "enlister"
cboHide.AddItem "note"
cboHide.AddItem "tel"
cboItem.ListIndex = 1
cboOp.ListIndex = 0
'txtValue.Text = Format(Date, "yyyy-MM-dd")
End Sub
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim sSubID$, sFdate$, sEDate$, sPaper$, sSql$, j%
On Error GoTo tErr
bRefreshData = False
For j = 1 To GrdSubInf.Cols - 1
Select Case Trim(GrdSubInf.TextMatrix(0, j))
Case "订阅号": sSubID = Trim(GrdSubInf.TextMatrix(GrdSubInf.Row, j))
Case "订阅开始": sFdate = Trim(Grd
