frmmain.frm

小型医院管理

VERSION 5.00
Begin VB.Form kf_frm_server 
   AutoRedraw      =   -1  'True
   BorderStyle     =   1  'Fixed Single
   Caption         =   "配置数据服务器"
   ClientHeight    =   5490
   ClientLeft      =   150
   ClientTop       =   435
   ClientWidth     =   4365
   Icon            =   "frmMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5490
   ScaleWidth      =   4365
   StartUpPosition =   2  '屏幕中心
   Begin VB.CommandButton Command1 
      Caption         =   "配置完成"
      Height          =   330
      Left            =   1440
      TabIndex        =   6
      Top             =   4995
      Width           =   1770
   End
   Begin VB.ComboBox cboDatabases 
      Appearance      =   0  'Flat
      BackColor       =   &H00FFFF00&
      Enabled         =   0   'False
      BeginProperty Font 
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   330
      Left            =   810
      Style           =   2  'Dropdown List
      TabIndex        =   5
      Top             =   4425
      Width           =   2625
   End
   Begin VB.Frame Frame1 
      Height          =   3675
      Left            =   360
      TabIndex        =   0
      Top             =   270
      Width           =   3555
      Begin VB.CommandButton cmdConnect 
         Appearance      =   0  'Flat
         Caption         =   "测试连接 "
         Default         =   -1  'True
         Height          =   375
         Left            =   945
         TabIndex        =   4
         Top             =   3060
         Width           =   1665
      End
      Begin VB.TextBox txtPassword 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFF00&
         BeginProperty Font 
            Name            =   "Courier New"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   285
         IMEMode         =   3  'DISABLE
         Left            =   660
         PasswordChar    =   "*"
         TabIndex        =   3
         Top             =   2580
         Width           =   2415
      End
      Begin VB.TextBox txtUser 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFF00&
         BeginProperty Font 
            Name            =   "Courier New"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   285
         Left            =   615
         TabIndex        =   2
         Top             =   1530
         Width           =   2415
      End
      Begin VB.TextBox txtServer 
         Appearance      =   0  'Flat
         BackColor       =   &H00FFFF00&
         BeginProperty Font 
            Name            =   "Courier New"
            Size            =   8.25
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   285
         Left            =   615
         TabIndex        =   1
         Top             =   570
         Width           =   2415
      End
      Begin VB.Label Label3 
         Caption         =   "密码"
         Height          =   255
         Left            =   600
         TabIndex        =   9
         Top             =   2160
         Width           =   1215
      End
      Begin VB.Label Label2 
         Caption         =   "用户名"
         Height          =   255
         Left            =   600
         TabIndex        =   8
         Top             =   1200
         Width           =   1095
      End
      Begin VB.Label Label1 
         Caption         =   "计算机IP地址"
         Height          =   255
         Left            =   600
         TabIndex        =   7
         Top             =   240
         Width           =   1455
      End
   End
   Begin VB.Label Label4 
      Caption         =   "数据库"
      Height          =   255
      Left            =   840
      TabIndex        =   10
      Top             =   4080
      Width           =   1335
   End
End
Attribute VB_Name = "kf_frm_server"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Dim bDBLoading As Boolean
Dim bSPLoading As Boolean
Dim bServerLoading As Boolean

Private Sub Command1_Click()

If Trim(cboDatabases.Text) = "" Then
   MsgBox "请您注册服务器信息并选择所要连接的数据库！配置完成之前必须进行测试连接，防止不必要的错误发生！", vbOKOnly, "系统提示"
Exit Sub
End If

 bServerLoading = True
    DoEvents
    Select Case True
        Case Trim(txtServer.Text) = ""
            MsgBox "服务器必须输入！", vbOKOnly, "系统警告"
            txtServer.SetFocus
            txtServer.SelStart = 0
            txtServer.SelLength = Len(txtServer)
        Case Trim(txtUser.Text) = ""
            MsgBox "请输入登录服务器用户名！", vbOKOnly, "系统警告"
        Case Trim(txtPassword.Text) = ""
            MsgBox "请您输入服务器密码！", vbOKOnly, "系统警告"
        Case Trim(cboDatabases.Text) = ""
           MsgBox "请您选择所要连接的数据库！配置完成之前必须进行测试连接，防止不必要的错误！", vbOKOnly, "系统提示"
        Case Else
        Dim aaa, bbb, ccc, ddd
        aaa = Trim(txtServer.Text)
        bbb = Trim(txtUser.Text)
              
        ccc = Trim(txtPassword.Text)
        ddd = Trim(cboDatabases.Text)
                    ConnectionString = "PROVIDER=MSDASQL;driver={SQL Server};server=" & aaa & ";uid=" & bbb & ";pwd=" & ccc & ";database=" & ddd & ";"
                 
        If GetStringValue("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database") = "Error" Then
         CreateKey "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion"
         modRegistry.DeleteRegKeyValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database"
         SetStringValue "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database", ConnectionString
        End If

        If GetStringValue("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database") = "" Then
        SetStringValue "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database", ConnectionString
        End If
        If GetStringValue("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database") <> "" Then
        modRegistry.DeleteRegKeyValue HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database"
        SetStringValue "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\MinorVersion", "database", ConnectionString
       End If
    End Select
    bServerLoading = False
    MsgBox "服务器配置成功！请您重新启动系统！", vbOKOnly, "注册成功！"
  End
End Sub

Private Sub Form_Load()
    '-- Subclass the rtb so we can scroll the line numbers
 
 
   
   
    txtServer.Text = gCurrentServer
    txtUser.Text = gCurrentUser
    txtPassword.Text = gCurrentPassword

    
   
   
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload Me
End Sub

Private Sub Form_Unload(Cancel As Integer)
    '-- kill the subclass so we don't screw up someone's machinecboSprocs
     
      
End Sub

Private Sub Form_Resize()
    On Error Resume Next
'    If frmMain.Height < 5925 Then frmMain.Height = 5925
'    If frmMain.Width < 3450 Then frmMain.Width = 3450
'    FrameParams.Width = Me.Width - 2920
'    lvSP.Width = FrameParams.Width - 240
'    lblParameters.Width = lvSP.Width
'
'    tabCode.Width = Me.Width - 240
'    DoEvents
'    Container.Width = tabCode.Width - 240
'    Container.Height = tabCode.Height - 780
'    rtbSQL.Height = Container.Height + 10
'    picLines.Height = Container.Height
'    lblSPCode.Width = Container.Width
'    rtbSQL.Width = Container.Width - picLines.Width
'    rtbVB.Height = Container.Height
'    lblVBCode.Width = Container.Width
'    rtbVB.Width = Container.Width
'    rtbASP.Height = Container.Height
'    lblASPCode.Width = Container.Width
'    rtbASP.Width = Container.Width
'    tabCode.Height = Me.Height - 4900
'
'    ' Refresh the line numbers
'    DrawLines picLines
'    If Container.Height <> tabCode.Height - 780 Then Form_Resize
End Sub

Public Sub DrawLines(picTo As PictureBox)

    Dim lLine As Long
    Dim lCount As Long
    Dim lCurrent As Long
    Dim hBr As Long
    Dim lEnd As Long
    Dim lhDC As Long
    Dim bComplete As Boolean
    Dim tR As RECT
    Dim tTR As RECT
    Dim oCol As OLE_COLOR
    Dim lStart As Long
    Dim lEndLine As Long
    Dim tPO As POINTAPI
    Dim lLineHeight As Long
    Dim hPen As Long
    Dim hPenOld As Long
 
    lhDC = picTo.hdc
    DrawText lhDC, "Hy", 2, tTR, DT_CALCRECT
    lLineHeight = tTR.Bottom - tTR.Top
    
  
    If lCount < 50 Then lCount = 50
  
  
   
   
   
    GetClientRect picTo.hwnd, tR
    lEnd = tR.Bottom - tR.Top
    
    hBr = CreateSolidBrush(TranslateColor(picTo.BackColor))
    FillRect lhDC, tR, hBr
    DeleteObject hBr
    tR.Left = 2
    tR.Right = tR.Right - 2
    tR.Top = 0
    tR.Bottom = tR.Top + lLineHeight
    
    SetTextColor lhDC, TranslateColor(vbButtonShadow)
    
    Do
       ' Ensure correct colour:
       If (lLine = lCurrent) Then
          SetTextColor lhDC, TranslateColor(vbWindowText)
       ElseIf (lLine = lEndLine + 1) Then
          SetTextColor lhDC, TranslateColor(vbButtonShadow)
       End If
       ' Draw the line number:
       DrawText lhDC, CStr(lLine + 1), -1, tR, DT_RIGHT
       
       ' Increment the line:
       lLine = lLine + 1
       ' Increment the position:
       OffsetRect tR, 0, lLineHeight
       If (tR.Bottom > lEnd) Or (lLine + 1 > lCount) Then
          bComplete = True
       End If
    Loop While Not bComplete
    
    ' Draw a line...
    MoveToEx lhDC, tR.Right + 1, 0, tPO
    hPen = CreatePen(PS_SOLID, 1, TranslateColor(vbButtonShadow))
    hPenOld = SelectObject(lhDC, hPen)
    LineTo lhDC, tR.Right + 1, lEnd
    SelectObject lhDC, hPenOld
    DeleteObject hPen
    If picTo.AutoRedraw Then
       picTo.Refresh
    End If
   
End Sub

Private Sub cboSprocs_Click()
    DoEvents
    If bDBLoading Then Exit Sub
    If cboDatabases.Text = "Choose Sproc" Then Exit Sub
    If cboDatabases.Text = gCurrentSproc Then Exit Sub
   
    Screen.MousePointer = vbHourglass
    Create_Connection db_sql, gCurrentDatabase, Trim(txtServer.Text), Trim(txtUser.Text), Trim(txtPassword.Text)
   Screen.MousePointer = vbDefault
End Sub

Private Sub cmdConnect_Click()
    fwq = 0
    bServerLoading = True
    cboDatabases.Clear
  
    DoEvents
    Select Case True
        Case Trim(txtServer.Text) = ""
            MsgBox "服务器必须输入！", vbOKOnly, "系统警告"
            txtServer.SetFocus
            txtServer.SelStart = 0
            txtServer.SelLength = Len(txtServer)
        Case Trim(txtUser.Text) = ""
            MsgBox "请输入登录服务器用户名！", vbOKOnly, "系统警告"
         Case Trim(txtPassword.Text) = ""
            MsgBox "请您输入登录服务器密码", vbOKOnly, "系统警告"
        Case Else
            Screen.MousePointer = vbHourglass
            gCurrentServer = Trim(txtServer.Text)
            gCurrentUser = Trim(txtUser.Text)
          
            
            gCurrentPassword = Trim(txtPassword.Text)
            bDBLoading = True
            Create_Connection db_sql, "Master", gCurrentServer, gCurrentUser, gCurrentPassword
            Set oRS = ExecuteSP("sp_databases", sp_Select)
                  If fwq = 1 Then
                  MsgBox "对不起！信息错误，请重新输入", vbOKOnly, "警告！"
                  GoTo aa:
                  End If
             If Not oRS Is Nothing Then
                Do Until oRS.EOF
                    cboDatabases.AddItem oRS("Database_Name")
                    oRS.MoveNext
                Loop
                cboDatabases.Text = "Master"
                cboDatabases.Enabled = True
             End If
aa:
            bDBLoading = False
           

            Screen.MousePointer = vbDefault
    End Select
    bServerLoading = False
  
 
End Sub