module1.bas

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

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

'设置窗体位置API函数
Declare Function SetWindowPos Lib "user32" _
  (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
  ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
  ByVal cy As Long, ByVal wFlags As Long) As Long

Global Const SWP_NOMOVE = 2
Global Const SWP_NOSIZE = 1
Global Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Global Const HWND_TOPMOST = -1
Global Const HWND_NOTOPMOST = -2

' =========================
Public RTChatRemoteIP As String
Public RTChatRemoteNick As String
Public RTCListen As Boolean
Public FileSendRemoteIP As String
Public FileSendRemoteNick As String
Public KeySection As String
Public KeyKey As String
Public KeyValue As String
Public RemoteNick As String
Public gFileNum As Long
Public RTChatTemp As String

Public MyPersonalInfo As MyPersonalData

'用户信息结构
Public Type MyPersonalData
    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

'写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

'================
'读INI文件
'================
Public Sub LoadINI()

Dim lngResult As Long
Dim strFileName
Dim strResult As String * 50
strFileName = App.Path & "\Settings.ini"      'ini文件名
'读INI文件
lngResult = GetPrivateProfileString(KeySection, _
KeyKey, strFileName, strResult, Len(strResult), _
strFileName)
If lngResult = 0 Then

Call MsgBox("读INI文件时出错，请检查相关设置", vbExclamation)
Else
KeyValue = Trim(strResult)
End If

End Sub

'==============
'写INI文件函数
'==============
Public Sub SaveINI()

Dim lngResult As Long
Dim strFileName
strFileName = App.Path & "\Settings.ini"
lngResult = WritePrivateProfileString(KeySection, _
KeyKey, KeyValue, strFileName)
If lngResult = 0 Then

Call MsgBox("写INI文件时出错，请检查相关设置", vbExclamation)
End If

End Sub

'I don't actually use this function(the reason for it being turned into comments), I was just bored and wanted to see if I could make one, the reason I didn't delete is it may give someone an idea on how Replace() works

'Public Function MyReplace(Source As String, Find As String, Replace As String) As String
'Dim FirstHalf As String
'Dim SecondHalf As String
'Dim TempBegin As Integer
'TempBegin = 0
'Do While InStr(TempBegin + 1, Source, Find) > 0
'    TempBegin = InStr(TempBegin + 1, Source, Find)
'    FirstHalf = Mid(Source, 1, TempBegin - 1)
'    SecondHalf = Mid(Source, TempBegin + Len(Find), Len(Source) - TempBegin)
'    Source = FirstHalf & Replace
'    Source = Source & SecondHalf
'Loop
'MyReplace = Source
'End Function