modpub.bas

短信平台管理系统是一个短信收发的平台,用户可以找一些代理的短信平台(IP),在系统里修改一些设置就可以进行短信的收发,有短信服务器的IP,服务器端口.系统还有一些常用用户的设置,包括客户资料,客户分类

Attribute VB_Name = "modPub"
Global Const strMark = "√"
Const flexLeftTop = 0
Const flexLeftCenter = 1   '左边中间对齐（对于字符串来说，这是缺省时的情况）
Const flexLeftBottom = 2   '左边底端对齐
Const flexCenterTop = 3    '居中顶端对齐
Const flexCenterCenter = 4     '居中中间对齐
Const flexCenterBottom = 5 ' 居中底端对齐
Const flexRightTop = 6     '右边顶端对齐
Const flexRightCenter = 7  '右边中间对齐（对于数字来说，这是缺省时的情况）
Const flexRightBottom = 8  '右边底端对齐
Const flexGeneral = 9


Const dbgCenter = 2
Const dbgGeneral = 3
Const dbgLeft = 0
Const dbgRight = 1

Const fmtBoolean = 5
Const fmtCustom = 1
Const fmtGeneral = 0

Public Const Mformat = "##,###.00"
Const inrateformat = "###.00"
Public Const Dateformat = "yyyy-mm-dd hh:mm:ss"
Public Const Booleanformat = "\ ;\√"



Function TransA(flex As Long) As Long
    Select Case flex
        Case flexLeftTop, flexLeftCenter, flexLeftBottom
            TransA = dbgLeft
        Case flexCenterTop, flexCenterCenter, flexCenterBottom
            TransA = dbgCenter
        
        Case flexRightTop, flexRightCenter, flexRightBottom
            TransA = dbgRight
        Case flexGeneral
            TransA = dbgGeneral
        
    End Select
End Function



Public Function FillViewStruct(sps As spListHeaders, cnnString As String, Aview As String) As Boolean
    Dim rsVS As New Recordset
    Dim rsV As New Recordset
    Dim i As Long
    On Error GoTo ErrorHandle
    rsVS.ActiveConnection = cnnString
    rsV.ActiveConnection = cnnString
    rsVS.Open "select * from viewdef where ViewNo='" & Aview & "'"
    rsV.Open "select * from viewitems where ViewNo='" & Aview & "' order by pos"
    If rsVS.EOF And rsVS.BOF Then
        FillViewStruct = False
        Exit Function
    End If
    With sps
        .isTwoS = rsVS("isTwoS")
        .other = rsVS("other")
        .vName = rsVS("viewName")
        .ViewNo = rsVS("ViewNo")
        .ReadOnly = rsVS("readonly")
        For i = 1 To .Count
            .Remove 1
        Next
    End With
    With rsV
        While Not rsV.EOF
            sps.Add !caption, !keyword, !Width, !FormatStr, !ReadOnly, !DataType, _
                !DataWidth, !RefType, !PointNum, , !Other1, !Other2, !POS, !HAlignment, _
                !TAlignment, !CanSet, !ColMerge, !Visible, !DispTrue, !DispFalse, !DispNull, !CanFilter, !condValue1, NullToString(!CondValue2), !FormatType
            rsV.MoveNext
        Wend
    End With
    
    
    releObject rsVS
    releObject rsV
    FillViewStruct = True
    Exit Function
ErrorHandle:
    releObject rsVS
    releObject rsV
    FillViewStruct = False

End Function

Public Function SaveViewStruct(sps As spListHeaders, cnnString As String, Aview As String) As Boolean
    Dim rsVS As New Recordset
    Dim rsV As New Recordset
    Dim i As Long
    Dim newmode As Boolean

    With rsVS
        .ActiveConnection = cnnString
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
    End With
    With rsV
        .ActiveConnection = cnnString
        .CursorLocation = adUseClient
        .CursorType = adOpenStatic
        .LockType = adLockOptimistic
    End With
    
    rsVS.Open "select * from viewdef where ViewNo='" & Aview & "'"
    rsV.Open "select * from viewitems where ViewNo='" & Aview & "'"
    
    If rsVS.EOF And rsVS.BOF Then
        newmode = True
    End If
    With sps
        If newmode Then rsVS.AddNew
        rsVS("isTwoS") = .isTwoS
        rsVS("other") = .other
        rsVS("viewName") = .vName
        rsVS("viewno") = .ViewNo
        rsVS("readonly") = .ReadOnly
        rsVS.Update
    End With
    
    With rsV
        For i = 1 To sps.Count
            If Not newmode Then
                .MoveFirst
                
                .Find "keyword= '" & sps(i).key & "'"
            Else
                .AddNew
            End If
                !FormatStr = sps(i).FormatStr
                !keyword = sps(i).key
                !caption = sps(i).caption
                !Width = sps(i).Width
                !DataType = sps(i).DataType
                !ReadOnly = sps(i).ReadOnly
                !PointNum = sps(i).PointNum
                !DataWidth = sps(i).DataWidth
                !RefType = sps(i).RefType
                !Other1 = sps(i).Other1
                !Other2 = sps(i).Other2
                !POS = sps(i).POS
                !HAlignment = sps(i).HAlignment
                !TAlignment = sps(i).TAlignment
                !CanSet = sps(i).CanSet
                !ColMerge = sps(i).ColMerge
                !Visible = sps(i).Visible
                !DispTrue = sps(i).DispTrue
                !DispFalse = sps(i).DispFalse
                !DispNull = sps(i).DispNull
                !CanFilter = sps(i).CanFilter
                !condValue1 = sps(i).condValue1
                !condValue1 = sps(i).CondValue2
                !ViewNo = Aview
                !FormatType = sps(i).FormatType
                .Update
        Next
    End With

    releObject rsVS
    releObject rsV
    SaveViewStruct = True
    Exit Function
ErrorHandle:
    releObject rsVS
    releObject rsV
    SaveViewStruct = False
End Function





Public Sub FillDataGridStruct(sps As spListHeaders, clsX As Columns)
    Dim i As Long
    Dim f As StdDataFormat
    clsX.Remove 0
    For i = 1 To sps.Count - 1
        clsX.Add i
    Next
    For i = 0 To sps.Count - 1
        clsX(i).caption = sps(i + 1).caption
        clsX(i).DataField = sps(i + 1).key
        clsX(i).Alignment = TransA(sps(i + 1).TAlignment)
        clsX(i).Visible = sps(i + 1).Visible
        clsX(i).Width = sps(i + 1).Width
        Set f = clsX(i).DataFormat
        f.Format = sps(i + 1).FormatStr
        f.TrueValue = sps(i + 1).DispTrue
        f.FalseValue = sps(i + 1).DispFalse
        f.NullValue = sps(i + 1).DispNull
        f.Type = sps(i + 1).FormatType
        
        clsX(i).WrapText = True
        clsX(i).AllowSizing = True
    Next
    'clsX(1).Alignment
    
End Sub

Public Sub FillMHFGridStruct(LstHs As spListHeaders, grdX As MSHFlexGrid)
    Dim i As Integer
    Dim strx As String
    
    With grdX
        .MergeCells = flexMergeRestrictColumns
        .Cols = LstHs.Count
        For i = 1 To .Cols
            .Col = i - 1
            .Row = 0
            .CellAlignment = LstHs(i).HAlignment
            .ColAlignment(i - 1) = LstHs(i).TAlignment
            '.ColWidth(i - 1) = LstHs(i).Width
            '.ColIsVisible(i - 1) = LstHs(i).Visible
            '.FormatString = LstHs(i).FormatStr
            .WordWrap = True
            .TextMatrix(0, i - 1) = LstHs(i).caption
            .MergeCol(i - 1) = LstHs(i).ColMerge


            If LstHs(i).Visible = False Then
                .ColWidth(i - 1) = 0
                '.Text = ""
            Else
                .ColWidth(i - 1) = LstHs(i).Width
                '.Text = LstHs(i).caption
            End If

            



        Next
        'grdX.Rows = 1
    End With

End Sub


Sub AddLine(LstHs As spListHeaders, grdX As MSHFlexGrid, rec As Recordset)
    Dim i As Integer
    Dim j As Integer
    Dim m As Integer
    Dim strx As String
    On Error Resume Next
    With grdX


        m = .Row
        For j = 1 To .Cols
                strx = LstHs(j).key
                If LstHs(j).FormatStr = "" Then
                    .TextMatrix(m, j - 1) = NullToString(rec(strx))
                Else
                    .TextMatrix(m, j - 1) = Format(NullToString(rec(strx)), LstHs(j).FormatStr)
                End If
                '.TextMatrix(m, j - 1) = rec(strX)
        Next
        .Rows = .Rows + 1
    End With
End Sub

'*************************************
'作用:根据列头填充列表
'引用:列表,记录集合
'*************************************

Public Sub fillList(LstHs As spListHeaders, grdX As MSHFlexGrid, rec As Recordset)
    '根据列头的关键字填充列表
    '每一列必须有关键字如单据唯一编号
    Dim i As Integer
    Dim j As Integer
    
    Dim strx As String
    On Error GoTo errh
    i = 0
    'rec.MoveFirst

    With grdX
        '.roWs = rec.RecordCount + 1
        While Not rec.EOF
            .Row = .Rows - 1
            'DoEvents
            AddLine LstHs, grdX, rec
            
            rec.MoveNext
        Wend
        If .Rows > 2 Then .Rows = .Rows - 1
    End With

errh:
End Sub








Public Function CTODATE(VARx As Variant, Tod As Date) As Date
    If IsNull(VARx) Then
        CTODATE = Tod
        Exit Function
    End If
    If VARx = "" Then
        CTODATE = Tod
    Else
        CTODATE = VARx
    End If

End Function
'