modulemod.bas

一个VB写的UDP协议的C/S模式的服务程序

Attribute VB_Name = "ModMain"
Option Explicit
Public CleanAfterClose As Long

Public cnn As New ADODB.Connection
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

Public Type NOTIFYICONDATA
    cbSize As Long                   '结构的长度
    hwnd As Long                     '消息接收窗口的句柄
    uID As Long                      '图标的标识
    uFlags As Long                   '设置参数
    uCallbackMessage As Long         '回调消息的值
    hicon As Long                    '图标句柄
    szTip As String * 64             '提示字符串
End Type

Public Const NIM_ADD = 0             '添加图标
Public Const NIM_MODIFY = 1          '修改图标
Public Const NIM_DELETE = 2          '删除图标

Public Const NIF_MESSAGE = 1         '当有鼠标事件发生时产生消息
Public Const NIF_ICON = 2            '
Public Const NIF_TIP = 4             '图标有提示字符串

Public Const WM_LBUTTONDBLCLK = &H203
Public Const WM_LBUTTONUP = &H202

Public Const WM_LBUTTONDOWN = &H201
Public Const WM_USER = &H400
Public Const WM_NOTIFYICON = WM_USER + &H100

Public Const GWL_WNDPROC = (-4)

Global lproc As Long
Global dbPath As String
Global iClearInterval As Long

Function Icon_Del(ihwnd As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim l As Long
  ano.hwnd = ihwnd
  ano.uID = 0
  ano.cbSize = Len(ano)
  Icon_Del = Shell_NotifyIcon(NIM_DELETE, ano)
End Function
Function Icon_Add(ihwnd As Long, hicon As Long) As Long
  Dim ano As NOTIFYICONDATA
  Dim astr As String
  astr = frmmain.Caption
  ano.szTip = astr + Chr$(0)
  ano.hwnd = ihwnd
  ano.uID = 0
  ano.uFlags = NIF_ICON Or NIF_TIP Or NIF_MESSAGE
  ano.hicon = hicon
  ano.cbSize = Len(ano)
  ano.uCallbackMessage = WM_NOTIFYICON
  Icon_Add = Shell_NotifyIcon(NIM_ADD, ano)
End Function

Function DialogProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
  Select Case uMsg
    Case WM_NOTIFYICON
      Select Case lParam
        Case WM_LBUTTONUP
            SetWindowLong frmmain.hwnd, GWL_WNDPROC, lproc
            frmmain.Show
            Icon_Del hwnd
        Case Else
      End Select
    Case Else
      DialogProc = False
  End Select
  DialogProc = True
End Function

Sub Main()

    If App.PrevInstance Then End
    On Error GoTo err
    Dim i As Long
    Dim iniPath As String
    iniPath = App.Path & "\syn.ini"
    Dim Temp As String

'********************  压缩数据库  *************************
    Dim strCompact1 As String, strCompact2 As String, strCompact3 As String
    
    strCompact1 = readini("parameters", "strCompact1", iniPath)
    strCompact1 = StrimNulls(strCompact1)
    
    strCompact2 = readini("parameters", "strCompact2", iniPath)
    strCompact2 = StrimNulls(strCompact2)

    strCompact3 = readini("parameters", "strCompact3", iniPath)
    strCompact3 = StrimNulls(strCompact3)

    If Len(strCompact1) > 0 Then
        InitializeDB strCompact1
    End If
    If Len(strCompact2) > 0 Then
        InitializeDB strCompact2
    End If
    If Len(strCompact3) > 0 Then
        InitializeDB strCompact3
    End If
     
 '***********************************************************
    iClearInterval = 0
    Temp = readini("parameters", "iClearInterval", iniPath)
    If Temp = "" Then
        iClearInterval = 10000
    Else
        iClearInterval = Val(Temp) * 1000
    End If
    
    dbPath = readini("parameters", "dbPath", iniPath)
    dbPath = StrimNulls(dbPath)

    If dbPath = "" Then
        dbPath = App.Path & "\数据库\数据库.mdb"
    End If
    
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Persist Security Info=False;Data Source=" & _
             dbPath & ";Jet OLEDB:Database Password=fjzyq1980"
    
    Dim rs As New ADODB.Recordset
    rs.Open "select * from systemset where setname='CleanAfterClose'", cnn, adOpenDynamic, adLockOptimistic
    If rs.EOF Then
        CleanAfterClose = 0
    Else
        CleanAfterClose = Val("0" & rs!setnum)
    End If
    
    If rs.State = adStateOpen Then rs.Close
    rs.Open "select * from systemset where setname='FreshInterval'", cnn, adOpenDynamic, adLockOptimistic
    
    Dim FreshInterval As Long
    If rs.EOF Then
        FreshInterval = 10000
    Else
        FreshInterval = Val("0" & rs!setnum) * 1000
    End If
    
    Load frmmain
    frmmain.Timer1.Enabled = True
    frmmain.Timer1.Interval = IIf(FreshInterval > 65000, 65000, FreshInterval)
    frmmain.Timer2.Enabled = True
    frmmain.Timer2.Interval = IIf(iClearInterval > 65000, 65000, iClearInterval)
    Exit Sub
err:
    MsgBox err.Description, vbCritical
    End

End Sub

Public Function readini(appname, KeyName As String, FileName As String) As String
    Dim inireturn As String
    inireturn = String$(255, Chr(0))
    readini = Left$(inireturn, GetPrivateProfileString(appname, ByVal KeyName, "", inireturn, Len(inireturn), FileName))
End Function

Private Sub InitializeDB(ByVal dbPath As String)

    Dim oldName As String, newName As String
    On Error GoTo errexit
    
    oldName = dbPath
    newName = App.Path & "\temp.mdb"
    DBEngine.CompactDatabase oldName, newName, dbLangGeneral, 0, ";pwd=fjzyq1980;"
    Kill oldName
    Name newName As oldName
    
    Exit Sub
errexit:
    Beep
End Sub

Public Function StrimNulls(ByVal str As String)
    Dim i As Long
    For i = 1 To Len(str)
        If Asc(Mid$(str, i, 1)) = 0 Then
            str = Left$(str, i - 1)
            Exit For
        End If
    Next
    StrimNulls = str
End Function