module1.bas

类似QQ的即时聊天系统,支持用户注册,源码分为客户端和服务器端。

Attribute VB_Name = "Module1"
'=====================
'INI文件处理模块
'======================

Global Const MaxUsers As Integer = 100    '全局常量，最大用户数
Public UserInfo(MaxUsers) As UserStatisticalData
Public SavedUserInfo As SavedUserStatisticalData
Public UserPersonalInfo As UserPersonalData
Public Buddy As String * 21
Public Ignore As String * 21

Public Temp As String
Public Const vbOrange = &H80FF&

'写INI文件API函数
Declare Function WritePrivateProfileString _
Lib "kernel32" Alias "WritePrivateProfileStringA" _
(ByVal lpApplicationname As String, ByVal _
lpKeyName As Any, ByVal lsString As Any, _
ByVal lplFilename As String) As Long

'读INI文件API函数
Declare Function GetPrivateProfileString Lib _
"kernel32" Alias "GetPrivateProfileStringA" _
(ByVal lpApplicationname As String, ByVal _
lpKeyName As String, ByVal lpDefault As _
String, ByVal lpReturnedString As String, _
ByVal nSize As Long, ByVal lpFileName As _
String) As Long

'用户信息结构
Public Type UserStatisticalData
     UserID As String
     UserName As String
     UserIP As String
     Nickname As String
     Password As String
     
     
     InRoom As String
     
     NickColor As Variant
     
     InUse As Boolean
     Status As String
End Type

Public Type SavedUserStatisticalData
     UserID As String * 21
     UserName As String * 21
     LastUserIP As String * 16
     Nickname As String * 21
     Password As String * 21
End Type

Public Type UserPersonalData
    Sex As String * 7
    Country As String * 21
    BirthDay As String * 11
    Age As String * 4
    Webpage As String * 101
    About As String * 451
End Type

Public Type BuddyProperties
    UserID As String * 21
    UserName As String * 21
End Type

'===============
'用户状态改变函数
'==============
Public Function TranslateStatus(StatusText As String) As String

    If StatusText = "Online" Then
    
       TranslateStatus = StatusText

    ElseIf StatusText = "Away" Then
    
       TranslateStatus = StatusText
    
    ElseIf StatusText = "DND" Then
    
       TranslateStatus = StatusText
    
    ElseIf UserInfo(u).Status = "Invisible" Then

       TranslateStatus = "Offline"
    
    ElseIf UserInfo(u).Status = "WT" Then

       TranslateStatus = "Webtour"
    
    ElseIf UserInfo(u).Status = "WTHost" Then

       TranslateStatus = "WebtourHost"
    
    Else

       '未知
       TranslateStatus = "Offline"
    
    End If

End Function

'===========
'保存INI文件函数
'===========
Public Function LoadINI(INIFileName As String, KeySection As String, KeyKey As String) As String

Dim lngResult As Long
Dim strFileName
Dim strResult As String * 501
strFileName = App.Path & "\" & INIFileName & ".ini" 'Declare your ini file !
lngResult = GetPrivateProfileString(KeySection, _
KeyKey, strFileName, strResult, Len(strResult), _
strFileName)
If lngResult = 0 Then
'An error has occurred
Call MsgBox("An error has occurred while calling the API function", vbExclamation)
Else
LoadINI = Trim(strResult)
End If

End Function

'================
'读INI文件
'================
Public Function SaveINI(INIFileName As String, KeySection As String, KeyKey As String, KeyValue As String)

Dim lngResult As Long
Dim strFileName
strFileName = App.Path & "\" & INIFileName & ".ini" 'Declare your ini file !
lngResult = WritePrivateProfileString(KeySection, _
KeyKey, KeyValue, strFileName)
If lngResult = 0 Then
'An error has occurred
Call MsgBox("An error has occurred while calling the API function", vbExclamation)
End If

End Function