frmmain.frm

本系统是一个报表分析查询系统

VERSION 5.00
Object = "{4932CEF1-2CAA-11D2-A165-0060081C43D9}#2.0#0"; "Actbar2.OCX"
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "金软报表服务器"
   ClientHeight    =   4425
   ClientLeft      =   45
   ClientTop       =   450
   ClientWidth     =   7110
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   4425
   ScaleWidth      =   7110
   StartUpPosition =   2  '屏幕中心
   Begin MSWinsockLib.Winsock frmLink 
      Index           =   0
      Left            =   3360
      Top             =   2040
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.TextBox frmMsgInfo 
      Appearance      =   0  'Flat
      Height          =   2295
      Left            =   360
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   2
      Top             =   960
      Width           =   6255
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 SBar 
      Height          =   375
      Left            =   840
      TabIndex        =   1
      Top             =   3480
      Width           =   4695
      _LayoutVersion  =   1
      _ExtentX        =   8281
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "frmMain.frx":27A2
   End
   Begin ActiveBar2LibraryCtl.ActiveBar2 TBar 
      Height          =   375
      Left            =   480
      TabIndex        =   0
      Top             =   240
      Width           =   4695
      _LayoutVersion  =   1
      _ExtentX        =   8281
      _ExtentY        =   661
      _DataPath       =   ""
      Bands           =   "frmMain.frx":296A
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private ImgPath As String

'//窗体初始化
Private Sub formInit()
 '//参数初始化
 ImgPath = App.Path & "\ResLib\"
 With Me
  .Width = Screen.Width * 0.95
  .Height = Screen.Height * 0.9
 End With
 '//
 With TBar
  .Left = 0
  .Top = 0
  .Width = Me.ScaleWidth
  .Height = 720
 End With
 '//
 With SBar
  .Left = 0
  .Width = Me.ScaleWidth
  .Height = 350
  .Top = Me.ScaleHeight - .Height
  .Picture = LoadPicture(ImgPath & "SBarBack.Gif")
 End With
With frmMsgInfo
  .Left = 0
  .Top = TBar.Top + TBar.Height
  .Width = Me.ScaleWidth
  .Height = SBar.Top - .Top
 End With
End Sub

'//初始化工具栏
Private Sub LoadTBar()
 TBar.UserDefinedCustomization = True
 '//
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//
 With TBar
  .Picture = LoadPicture(ImgPath & "TBarBk.jpg")
 End With
 '//
 Set Band = TBar.Bands.Add("TTBar")
 With Band
  .Caption = "TTBar"
  .Type = ddBTNormal
  .DockingArea = ddDATop
  .GrabHandleStyle = ddGSIE
  .MouseTracking = ddTSColor
 End With
 '//
 Set Tool = Band.Tools.Add(1, "TRef")
 With Tool
  .Caption = "刷新"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "SatusRefresh.Ico"), &HFF8080
  .ToolTipText = "刷新服务器状态"
 End With
 
 Set Tool = Band.Tools.Add(2, "TStop")
 With Tool
  .Caption = "关闭"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "StopServer.Ico"), &HC0C0C0
  .ToolTipText = "关闭服务器"
 End With
 Set Tool = Band.Tools.Add(3, "SplitTwo")
 With Tool
  .ControlType = ddTTSeparator
 End With
 '//
 Set Tool = Band.Tools.Add(2, "TEdit")
 With Tool
  .Caption = "关于"
  .Category = "TTBar"
  .ControlType = ddTTButton
  .Style = ddSIconText
  .CaptionPosition = ddCPBelow
  .SetPicture 0, LoadPicture(ImgPath & "About.Ico"), &HC0C0C0
  .ToolTipText = "关于开发商"
 End With
 '//
 TBar.RecalcLayout
 TBar.Refresh
End Sub

Private Sub LoadSBar()
 Dim Tool As ActiveBar2LibraryCtl.Tool
 Dim Band As ActiveBar2LibraryCtl.Band
 '//添加用户图标
 Set Tool = SBar.Tools.Add(1, "UserImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "User.Ico")
  .Style = ddSIcon
 End With
 '//添加用户名称
 Set Tool = SBar.Tools.Add(2, "UserName")
 With Tool
  .Height = SBar.Height
  .Alignment = ddALeftCenter
  .Caption = "冯孝刚"
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//添加主信息
 Set Tool = SBar.Tools.Add(3, "MainMsg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = "准备就绪"
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.5
 End With
 '//添加时间图形
 Set Tool = SBar.Tools.Add(4, "DateImg")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterTop
  .ControlType = ddTTButton
  .SetPicture ddITNormal, LoadPicture(ImgPath & "Timer.Ico")
  .Style = ddSIcon
 End With
 '//添加时间值
 Set Tool = SBar.Tools.Add(5, "DateVal")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .Caption = Format(Date, "YYYY-MM-DD")
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSNormal
  .Width = SBar.Width * 0.1
 End With
 '//
 Set Tool = SBar.Tools.Add(6, "Inst")
 With Tool
  .Height = SBar.Height
  .Alignment = ddACenterCenter
  .ControlType = ddTTLabel
  .CaptionPosition = ddCPStandard
  .LabelBevel = ddLBInset
  .LabelStyle = ddLSInsert
 End With
 Set Band = SBar.Bands.Add("TSBar"): Band.Type = ddBTStatusBar
 With Band.Tools
  .Insert .Count, SBar.Tools("UserImg")
  .Insert .Count, SBar.Tools("UserName")
  .Insert .Count, SBar.Tools("MainMsg")
  .Insert .Count, SBar.Tools("DateImg")
  .Insert .Count, SBar.Tools("DateVal")
  .Insert .Count, SBar.Tools("Inst")
 End With
 SBar.RecalcLayout
 SBar.Refresh
End Sub

Private Sub LoadServerInfo()
 Dim XmlFile As String
 XmlFile = App.Path & "\Server.Xml"
 Call getXmlValue(XmlFile, "System/Server/Name", SrvInfo.Name)
 Call getXmlValue(XmlFile, "System/Server/Port", SrvInfo.Port)
 Call getXmlValue(XmlFile, "System/Server/MaxLink", SrvInfo.MaxLink)
 SrvMax = 4 '//最大连接数量
 SrvCur = 0 '//没有客户端连接
 SrvStation = 1 '//服务器开启
End Sub

Private Function frmWinSock(ByRef eMsgInfo As String) As Boolean
 On Error GoTo ErrHandle
 Dim iLoop As Integer
 For iLoop = 1 To SrvMax
  Load frmLink(iLoop)
 Next
 frmLink(0).LocalPort = SrvInfo.Port
 frmLink(0).Listen
 '//
 eMsgInfo = "服务器初始化完成，最大连接数：【" & SrvMax & "】。等候连接... ..."
 SBar.Bands("TSBar").Tools("MainMsg").Caption = eMsgInfo
 SBar.Refresh
 frmWinSock = True
 Exit Function
ErrHandle:
 eMsgInfo = "初始化服务器错误" & Chr(13) & "错误描述：" & Err.Description
 frmWinSock = False
End Function

Private Sub Form_Load()
 Dim eMsgInfo As String
 Call formInit
 Call LoadTBar
 Call LoadSBar
 Call LoadServerInfo
 If frmWinSock(eMsgInfo) = False Then
  MsgBox eMsgInfo, vbCritical + vbOKOnly, MsgInfo
  End
 End If
End Sub

Private Sub frmLink_ConnectionRequest(Index As Integer, ByVal requestID As Long)
 Dim iLoop As Integer
 
 '//检测是否开启了服务器
 If SrvStation = 0 Then
  SBar.Bands("TSBar").Tools("MainMsg").Caption = "服务器已经停止"
  SBar.Refresh
  Exit Sub
 End If
 
 '//检测是否已经达到最大连接数量
 If SrvCur > SrvMax Then
  SBar.Bands("TSBar").Tools("MainMsg").Caption = "已经达到最大连接数"
  SBar.Refresh
  Exit Sub
 End If
 
 '//分配连接资源
 For iLoop = 1 To SrvMax
  If frmLink(iLoop).State = sckClosed Then
   Call frmLink(iLoop).Accept(requestID)
   SrvCur = SrvCur + 1
   '//更新服务器状态信息
   With frmMsgInfo
    .Text = .Text & Chr(13) & Chr(10) & "::本地端口：" & Str(frmLink(iLoop).LocalPort) & "  远程客户：" & frmLink(iLoop).RemoteHostIP & "  远程端口：" & Str(frmLink(iLoop).RemotePort)
   End With
   SBar.Bands("TSBar").Tools("MainMsg").Caption = "最大连接：" & SrvMax & "  当前连接：" & SrvCur
   SBar.Refresh
   Exit For
  End If
 Next
End Sub

Private Sub frmLink_DataArrival(Index As Integer, ByVal bytesTotal As Long)
 Dim myData As String
 Dim StrCmd As String
 '//接收客户端发送的数据
 frmLink(Index).GetData myData, vbString
 MsgBox myData
 '//处理数据
 myData = DecryptStr(myData) '//解密数据
 Select Case myData
  Case "Quit"
   '//客户端已经退出
   frmLink(Index).Close
   SrvCur = SrvCur - 1
   SBar.Bands("TSBar").Tools("MainMsg").Caption = "最大连接：" & SrvMax & "  当前连接：" & SrvCur
   SBar.Refresh
  Case "Validate"
   '//客户端请求服务器验证信息
   myData = EncryptStr("AllowLink")
   frmLink(Index).SendData (myData)
   SrvCur = SrvCur + 1
   SBar.Bands("TSBar").Tools("MainMsg").Caption = "最大连接：" & SrvMax & "  当前连接：" & SrvCur
   SBar.Refresh
 End Select
End Sub

Private Sub frmLink_Error(Index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
 MsgBox "服务器网络错误：" & Err.Description, vbCritical + vbOKOnly, MsgInfo
End Sub