Public conn As ADODB.Connection   '数据库连接
Public res As ADODB.Recordset  '记录集
Public resn As ADODB.Recordset
Public resact As ADODB.Recordset
Public theone As String '当前的关系对象姓名
Public derank As Long

Function opentable() '【功能：建立数据库连接；状态：完成】
Set conn = New ADODB.Connection
conn.CursorLocation = adUseClient
conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=relationship.mdb;"
Set res = New ADODB.Recordset
End Function
Function closetable() '【功能：关闭数据库连接；状态：完成】
conn.Close
End Function
Sub main()
Call opentable
Load Form1
If remindme = vbYes Then
Form1.Show
Else
End
End If
End Sub

Function remindme() '核心提醒程序
Dim remind, callme As String '提醒字符串
Dim interval As Integer
Dim decides As Integer '收集的信息用于【判断是否关闭程序】
'扫描生日并得出提醒信息
Set resact = New ADODB.Recordset
resact.Open "select * from peoples", conn, adOpenStatic, adLockOptimistic
    If resact.RecordCount = 0 Then
    resact.Close
    remindme = vbYes
    Exit Function
    Else
    End If
resact.MoveFirst
    Do While Not resact.EOF = True
        interval = seebirthday(resact.Fields("e-birth")) '生日间隔
            If interval < 20 And interval <> 380 Then
                remind = remind & vbCrLf & "您的 【" & resact.Fields("e-type") & "】→【" & _
                resact.Fields("e-name") & "】 将在 " & interval & "天后过生，请注意主动联系！"
            Else
            End If
        interval = seedif(resact.Fields("e-lastcontect"))
            If Val(resact.Fields("e-cinterval")) > interval Then '没有到提示期
            Else
                callme = callme & vbCrLf & "距上次您联系 【" & resact.Fields("e-name") & "】 已经过去了 " & interval & " 天了。请您及时联系，以免关系疏远。"
            End If
    resact.MoveNext
    Loop
resact.Close
'对两个信息进行处理
If Len(remind) = 0 Then
    If Len(callme) = 0 Then
    decides = vbYes
    '无提醒信息
    Else
        decides = MsgBox("【间隔提醒】" & callme & vbCrLf & vbCrLf & "打开关系管理程序吗？", vbYesNo, "自动提醒")
    End If
ElseIf Len(remind) > 0 Then
    If Len(callme) > 0 Then
        decides = MsgBox("【间隔提醒】 & 【生日提醒】" & callme & remind & vbCrLf & vbCrLf & "打开关系管理程序吗？", vbYesNo, "自动提醒")
    Else
        decides = MsgBox("【生日提醒】" & remind & vbCrLf & vbCrLf & "打开关系管理程序吗？", vbYesNo, "自动提醒")
    End If
End If
remindme = decides
End Function

Function seebirthday(ByVal birth As String)
On Error GoTo forerror
Dim days As Long
days = DateDiff("d", Mid(CStr(Date), 6, 5), Mid(birth, 6, 5))
    If days < 0 Then
    days = days + 365
    Else
    End If
seebirthday = days
Exit Function
forerror:
seebirthday = 380
End Function

Function seedif(ByVal birth As String)
Dim days As Long
days = DateDiff("d", CStr(Date), birth)
    If days < 0 Then
    days = days * (-1)
    Else
    End If
seedif = days
End Function

Function AddOpen() '【添加到开始菜单】
Dim appstring As String
Dim we
appstring = App.Path & "\" & App.EXEName & ".exe"
Set we = CreateObject("wscript.shell")
we.regwrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\" & App.EXEName, appstring
End Function