frmadduser.frm

VB医药保险品查询系统

VERSION 5.00
Begin VB.Form frmadduser 
   BorderStyle     =   0  'None
   Caption         =   "增加用户"
   ClientHeight    =   6285
   ClientLeft      =   0
   ClientTop       =   -105
   ClientWidth     =   7890
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MousePointer    =   99  'Custom
   ScaleHeight     =   6285
   ScaleWidth      =   7890
   ShowInTaskbar   =   0   'False
   StartUpPosition =   2  '屏幕中心
   Begin VB.PictureBox Picture1 
      BorderStyle     =   0  'None
      Height          =   6255
      Left            =   0
      Picture         =   "frmadduser.frx":0000
      ScaleHeight     =   6255
      ScaleWidth      =   7935
      TabIndex        =   0
      Top             =   0
      Width           =   7935
      Begin VB.ComboBox Combo1 
         BackColor       =   &H00FFC0C0&
         Height          =   300
         Left            =   3600
         TabIndex        =   4
         Top             =   3840
         Width           =   2055
      End
      Begin VB.TextBox Text3 
         BackColor       =   &H00FFC0C0&
         Height          =   375
         IMEMode         =   3  'DISABLE
         Left            =   3600
         PasswordChar    =   "*"
         TabIndex        =   3
         Top             =   3240
         Width           =   2055
      End
      Begin VB.TextBox Text2 
         BackColor       =   &H00FFC0C0&
         Height          =   375
         IMEMode         =   3  'DISABLE
         Left            =   3600
         PasswordChar    =   "*"
         TabIndex        =   2
         Top             =   2640
         Width           =   2055
      End
      Begin VB.TextBox Text1 
         BackColor       =   &H00FFC0C0&
         Height          =   375
         Left            =   3600
         TabIndex        =   1
         Top             =   2040
         Width           =   2055
      End
      Begin VB.Label Label1 
         BackStyle       =   0  'Transparent
         Height          =   495
         Left            =   7320
         MouseIcon       =   "frmadduser.frx":7146
         MousePointer    =   99  'Custom
         TabIndex        =   7
         Top             =   0
         Width           =   495
      End
      Begin VB.Label command2 
         BackStyle       =   0  'Transparent
         Height          =   495
         Left            =   4560
         MouseIcon       =   "frmadduser.frx":7298
         MousePointer    =   99  'Custom
         TabIndex        =   6
         Top             =   5040
         Width           =   1215
      End
      Begin VB.Label command1 
         BackStyle       =   0  'Transparent
         DragIcon        =   "frmadduser.frx":73EA
         Height          =   495
         Left            =   2040
         MouseIcon       =   "frmadduser.frx":782C
         MousePointer    =   99  'Custom
         TabIndex        =   5
         Top             =   5040
         Width           =   1215
      End
   End
End
Attribute VB_Name = "frmadduser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Download by http://www.codefans.net
Option Explicit
Dim cnt As Integer                     '记录确定次数
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Long) As Long
Private 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
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE = &H2
Private Const HWND_TOPMOST = -1
Private Const HWND_NOTOPMOST = -2
Private Const RGN_XOR = 3
Private Const HTCAPTION = 2
Private Const WM_NCLBUTTONDOWN = &HA1
Private Type RECT
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type
Dim Xs As Long

Function CreatePictureform()
  On Error Resume Next
  Dim hRgn As Long, hRect As RECT, hTempRgn As Long, tColour As Long, OldScaleMode As Integer, AbsoluteX As Long, AbsoluteY As Long
  Dim Color As Long, Hrect1 As RECT
  Dim xx As Long, yy As Long
  Dim rtn As Long
  Me.Picture = Me.Picture1
  Me.Width = Me.Picture1.Width
  Me.Height = Me.Picture1.Height
  OldScaleMode = Me.ScaleMode
  Me.AutoRedraw = True
  Me.ScaleMode = 3
  Color = vbWhite
  rtn = GetWindowRect(Me.hwnd, hRect)
  hRgn = CreateRectRgn(0, 0, hRect.right, hRect.bottom)
  For AbsoluteX = 0 To Me.ScaleWidth
    For AbsoluteY = 0 To Me.ScaleHeight
      tColour = GetPixel(Me.hdc, AbsoluteX, AbsoluteY)
      If tColour = Color Then
        hTempRgn = CreateRectRgn(AbsoluteX, AbsoluteY, AbsoluteX + 1, AbsoluteY + 1)
        rtn = CombineRgn(hRgn, hRgn, hTempRgn, RGN_XOR)
        rtn = DeleteObject(hTempRgn)
      End If
    Next AbsoluteY
  Next AbsoluteX
  rtn = SetWindowRgn(Me.hwnd, hRgn, True)
  DeleteObject hRgn
  Me.ScaleMode = OldScaleMode
  If Err Then
    MsgBox Error, 16, Err
  End If
End Function



Private Sub Combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Dim sql As String
Dim rs_add As New ADODB.Recordset
If Trim(Text1.Text) = "" Then
   MsgBox "用户名不能为空", vbOKOnly + vbExclamation, ""
   Exit Sub
   Text1.SetFocus
Else
   sql = "select * from 系统管理"
   rs_add.Open sql, conn, adOpenKeyset, adLockPessimistic
   While (rs_add.EOF = False)
        If Trim(rs_add.Fields(0)) = Trim(Text1.Text) Then
           MsgBox "已有这个用户", vbOKOnly + vbExclamation, ""
           Text1.SetFocus
           Text1.Text = ""
           Text2.Text = ""
           Text3.Text = ""
           Combo1.Text = ""
           Exit Sub
         Else
           rs_add.MoveNext
         End If
    Wend
    If Trim(Text2.Text) = "" Then
         MsgBox "密码不能为空，请重新输入！", vbOKOnly + vbExclamation, "警告"
         Text2.Text = ""
         Text2.SetFocus
         Exit Sub
    End If
    If Trim(Text2.Text) <> Trim(Text3.Text) Then
       MsgBox "两次密码不一致", vbOKOnly + vbExclamation, ""
       Text2.SetFocus
       Text2.Text = ""
       Text3.Text = ""
       Exit Sub
    ElseIf Trim(Combo1.Text) <> "system" And Trim(Combo1.Text) <> "guest" Then
       MsgBox "请选择正确的用户权限", vbOKOnly + vbExclamation, ""
       Combo1.SetFocus
       Combo1.Text = ""
       Exit Sub
    Else
       rs_add.AddNew
       rs_add.Fields(0) = Text1.Text
       rs_add.Fields(1) = Text2.Text
       rs_add.Fields(2) = Combo1.Text
       rs_add.Update
       rs_add.Close
       MsgBox "添加用户成功", vbOKOnly + vbExclamation, ""
       Unload Me
    End If
End If
End If
End Sub

Private Sub Command1_Click()
Dim sql As String
Dim rs_add As New ADODB.Recordset
If Trim(Text1.Text) = "" Then
   MsgBox "用户名不能为空", vbOKOnly + vbExclamation, ""
   Exit Sub
   Text1.SetFocus
Else
   sql = "select * from 系统管理"
   rs_add.Open sql, conn, adOpenKeyset, adLockPessimistic
   While (rs_add.EOF = False)
        If Trim(rs_add.Fields(0)) = Trim(Text1.Text) Then
           MsgBox "已有这个用户", vbOKOnly + vbExclamation, ""
           Text1.SetFocus
           Text1.Text = ""
           Text2.Text = ""
           Text3.Text = ""
           Combo1.Text = ""
           Exit Sub
         Else
           rs_add.MoveNext
         End If
    Wend
    If Trim(Text2.Text) = "" Then
         MsgBox "密码不能为空，请重新输入！", vbOKOnly + vbExclamation, "警告"
         Text2.Text = ""
         Text2.SetFocus
         Exit Sub
    End If
    If Trim(Text2.Text) <> Trim(Text3.Text) Then
       MsgBox "两次密码不一致", vbOKOnly + vbExclamation, ""
       Text2.SetFocus
       Text2.Text = ""
       Text3.Text = ""
       Exit Sub
    ElseIf Trim(Combo1.Text) <> "system" And Trim(Combo1.Text) <> "guest" Then
       MsgBox "请选择正确的用户权限", vbOKOnly + vbExclamation, ""
       Combo1.SetFocus
       Combo1.Text = ""
       Exit Sub
    Else
       rs_add.AddNew
       rs_add.Fields(0) = Text1.Text
       rs_add.Fields(1) = Text2.Text
       rs_add.Fields(2) = Combo1.Text
       rs_add.Update
       rs_add.Close
       MsgBox "添加用户成功", vbOKOnly + vbExclamation, ""
       Unload Me
    End If
End If
End Sub

Private Sub Command2_Click()
Unload Me
Main.Show
End Sub

Private Sub Form_Load()
Combo1.AddItem "system"
Combo1.AddItem "guest"
End Sub


Private Sub Label1_Click()
Unload Me
Main.Show
End Sub

Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 1 Then
    Dim ReturnVal As Long
    Xs = ReleaseCapture()
    ReturnVal = SendMessage(hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0)
  End If
End Sub