module1.bas

民间标会的会员管理用的软件。是为一个顾客定做的！

Attribute VB_Name = "MD"
 Declare Sub InitCommonControls Lib "comctl32.dll" ()

Public DataFile As String


Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function ReleaseCapture Lib "user32" () As Long
Public Const WM_SYSCOMMAND = &H112
Public Const SC_MOVE = &HF010





Function GetPWD(ByVal Tmp As String) As String '密码的ASCII加密
Dim Pwd    As String
Dim PWDLen As Integer
Dim TMP2   As Integer
Dim i      As Integer


If Tmp <> "" Then
    PWDLen = Len(Tmp)
    For i = 1 To PWDLen
        TMP2 = Asc(Mid(Tmp, i, 1))
        TMP2 = TMP2 Xor &HF0
        Pwd = Pwd & Format(TMP2, "000")
    Next
End If


GetPWD = Pwd
End Function




'返回日期对应的月份编号(从0到15)
Function GetMonthNo(ByVal Dt As Date) As Byte

Dim Mt As Integer


Mt = Month(Dt)
Mt = Mt + (Mt - 1) \ 3
If Month(Dt) Mod 3 = 0 Then
    If Day(Dt) > 15 Then Mt = Mt + 1
End If
GetMonthNo = Mt - 1


End Function


Public Function GetMoney(ByVal M_Client As Long, Optional ByVal iYear As Integer, Optional ByVal iMonth As Integer) As Long '算出会员实际该交的金额
Dim Tmp As Variant
Dim SQL As String


If iYear = 0 And iMonth = 0 Then
        SQL = "SELECT TOP 1 应缴金额 From 买会表"
        SQL = SQL & " WHERE 客户编号=" & M_Client
Else
    Dim bgDate As Date
    bgDate = GetDate(iYear, iMonth)
    SQL = "SELECT TOP 1 应缴金额 From 买会表"
    SQL = SQL & " WHERE 客户编号=" & M_Client
    SQL = SQL & " AND 日期<=#" & bgDate & "#"
    'sql=sql & " AND "
End If


SQL = SQL & " Order by 日期 DESC"


Tmp = GetValue(SQL)

If Not IsNull(Tmp) Then
   GetMoney = CLng(Tmp)
Else
   GetMoney = 0
End If

End Function



Function BackupData(ByVal FileName As String) As Boolean '备份数据库文件到磁盘

'On Error Resume Next

Err.Clear

FileCopy DataFile, FileName

If Err.Number <> 0 Then
 BackupData = False
Else
 BackupData = True
End If
Err.Clear
End Function

'欠费查询用
Function GetBeginDate() As Date
Dim Y As Integer
Dim M As Integer
Dim D As Integer


Y = Year(Now) - 5

If Month(Now) Mod 3 = 0 Then
    If Day(Now) < 16 Then
        M = Month(Now)
        D = 16
        GetBeginDate = CDate(Y & "-" & M & "-" & D)
        Exit Function
    End If
End If

M = IIf(Month(Now) < 12, Month(Now) + 1, 1)
Y = IIf(M = 1, Y + 1, Y)
D = 1

GetBeginDate = CDate(Y & "-" & M & "-" & D)



End Function

'第一个字段做关键字（Listview控件里显示记录集）

Public Sub RSToListView2(Rs As ADODB.Recordset, LV As ListView)
Dim C As Integer, i As Integer, j As Integer
LV.View = lvwReport '设置详细资料方式

C = Rs.Fields.Count

LV.ListItems.Clear
LV.ColumnHeaders.Clear

'添加表头
For i = 1 To C - 1
    LV.ColumnHeaders.Add , , Rs.Fields(i).Name
Next i
i = 0
'添加字段
Do While Not Rs.EOF
    LV.ListItems.Add , "KEY" & Rs.Fields(0).Value, Rs.Fields(1).Value '添加第一个字段,关键字
    i = i + 1
    '添加其余字段
    For j = 2 To C - 1
        If IsNull(Rs.Fields(j).Value) Then
            LV.ListItems(i).SubItems(j - 1) = ""
        Else
            LV.ListItems(i).SubItems(j - 1) = Rs.Fields(j).Value
        End If
    Next j
    Rs.MoveNext
Loop
End Sub

'完全输出方式，没有关键字（Listview控件里显示记录集）
Public Sub RSToListView(Rs As ADODB.Recordset, LV As ListView)
Dim C As Integer, i As Integer, j As Integer
LV.View = lvwReport '设置详细资料方式
C = Rs.Fields.Count
LV.ListItems.Clear
LV.ColumnHeaders.Clear

'添加表头
For i = 0 To C - 1
    LV.ColumnHeaders.Add , , Rs.Fields(i).Name
Next i

'添加字段
i = 1
Do While Not Rs.EOF
    LV.ListItems.Add , , Rs.Fields(0).Value '添加第一个字段
    '添加其余字段
    For j = 1 To C - 1
        If IsNull(Rs.Fields(j).Value) Then
            LV.ListItems(i).SubItems(j) = ""
        Else
            LV.ListItems(i).SubItems(j) = Rs.Fields(j).Value
        End If
    Next j
    i = i + 1
    Rs.MoveNext
Loop
End Sub

Sub MoveObj(ByVal lnghWnd As Long)

ReleaseCapture
SendMessage lnghWnd, WM_SYSCOMMAND, SC_MOVE + 2, 0

End Sub


Function GetDate(ByVal lYear As Long, ByVal MonthNo As Integer) As Date

Dim MM As Integer

'MonthNo = MonthNo + 1

MM = MonthNo - MonthNo \ 4

Dim DD As String
If (MonthNo + 1) Mod 4 = 0 Then
    DD = 15
Else
    DD = GetLastDay(lYear, MM)
End If
GetDate = CDate(lYear & "-" & MM & "-" & DD)
End Function

'取得一个月份的最后一天
Function GetLastDay(ByVal lYear As Long, ByVal iMonth As Integer) As Integer

Dim DD As String

Select Case iMonth

Case 1
    DD = 31
Case 2
   DD = IIf(lYear Mod 4 = 0, 29, 28)
Case 3 To 7
  DD = iMonth Mod 2 + 30
Case 8 To 12
  DD = 31 - iMonth Mod 2
End Select
GetLastDay = CStr(DD)

End Function


Public Sub DeleteTm() '删除冗余的同名

 Dim Tmid As Long
 Dim i      As Long
 Dim Rs     As Recordset
 Dim SQL    As String
 
 SQL = "SELECT 同名编号,COUNT(*) FROM 成员表 Group by 同名编号"
 
 Set Rs = GetRecord(SQL)
 Do While Not Rs.EOF
    If Rs.Fields(1).Value = 1 Then
        Tmid = Rs.Fields(0).Value
        SQL = "DELETE FROM 同名表 WHERE 同名编号=" & Tmid
        ExecSQL SQL
    End If
    Rs.MoveNext
 Loop
 
End Sub