frmtmedit1.frm

Visual basic 数据库编程技术与实例源码 源码

         Height          =   180
         Left            =   225
         TabIndex        =   22
         Top             =   1755
         Width           =   270
      End
      Begin VB.Label lblD 
         AutoSize        =   -1  'True
         Caption         =   "D、"
         Height          =   180
         Left            =   225
         TabIndex        =   21
         Top             =   1395
         Width           =   270
      End
      Begin VB.Label lblC 
         AutoSize        =   -1  'True
         Caption         =   "C、"
         Height          =   180
         Left            =   225
         TabIndex        =   20
         Top             =   1050
         Width           =   270
      End
      Begin VB.Label lblB 
         AutoSize        =   -1  'True
         Caption         =   "B、"
         Height          =   180
         Left            =   225
         TabIndex        =   19
         Top             =   720
         Width           =   270
      End
      Begin VB.Label lblA 
         AutoSize        =   -1  'True
         Caption         =   "A、"
         Height          =   180
         Left            =   225
         TabIndex        =   18
         Top             =   330
         Width           =   270
      End
   End
   Begin VB.Label lblTp 
      AutoSize        =   -1  'True
      Caption         =   "题目图片："
      Height          =   180
      Left            =   2460
      TabIndex        =   16
      Tag             =   "3330"
      Top             =   3945
      Width           =   900
   End
   Begin VB.Label lblTmda 
      AutoSize        =   -1  'True
      Caption         =   "题目答案："
      Height          =   180
      Left            =   2460
      TabIndex        =   15
      Tag             =   "2460"
      Top             =   3570
      Width           =   900
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      Caption         =   "题目名称："
      Height          =   180
      Left            =   135
      TabIndex        =   14
      Top             =   495
      Width           =   900
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "题目编号："
      Height          =   180
      Left            =   135
      TabIndex        =   13
      Top             =   165
      Width           =   900
   End
End
Attribute VB_Name = "frmTmAdd"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Private miTmlx_id As Integer '题目类型编号
Private miTmlb_id As Integer '题目类别编号

Private rs As ADODB.Recordset '数据源
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

'设置
Public Property Let TmADORecordset(ByRef vNewValue As ADODB.Recordset)
    Set rs = vNewValue
End Property
'设置
Public Property Let Tmlx_id(ByVal vNewValue As Integer)
    miTmlx_id = vNewValue
End Property
'设置
Public Property Let Tmlb_id(ByVal vNewValue As Integer)
    miTmlb_id = vNewValue
End Property
'添加一行
Private Sub InsertRow()
    '加一条新记录
    rs.AddNew
    
    txtTmlb_id.Text = CStr(miTmlb_id)
    txtTmlx_id.Text = CStr(miTmlx_id)
    '----------------------------
    cmdOK.Enabled = False
    Combo1.ListIndex = 0
    txtTmda.Text = Combo1.Text
        
End Sub
Private Sub cmdBrowse_Click()
    Dim pfn As String '路径及文件名
    Dim fn As String '纯文件名
    '
    On Error GoTo ErrHandler
    
    CommonDialog1.CancelError = True
    CommonDialog1.DialogTitle = "选择图片文件"
    CommonDialog1.Filter = "位图文件(*.bmp)|*.bmp|JPG文件(*.jpg)|*.jpg"
    CommonDialog1.FilterIndex = 1
    'Display the Open dialog box
    CommonDialog1.ShowOpen
    
    pfn = CommonDialog1.FileName
    fn = CommonDialog1.FileTitle
    
    If pfn <> (GetAppPath() & "pic\" & fn) Then '在给定图片路径下不存在
        CopyFile pfn, GetAppPath() & "pic\" & fn, 0
    End If
    '--------------------------------------------------------------
    Text1(9).Text = "pic\" & fn
    
    Image1.Picture = LoadPicture(GetAppPath() & "pic\" & fn)
    
    Exit Sub
ErrHandler:
    '按了"取消"按钮
End Sub
Private Sub cmdCancel_Click()
    rs.CancelUpdate
    Unload Me
End Sub
Private Sub cmdOK_Click()
    Dim bh As Integer
    Dim ct As Integer
    Dim rs As ADODB.Recordset
    Dim szSQL As String
    
    On Error GoTo ErrHandler
    bh = CInt(Text1(1).Text)
    '10:编号是否重复
    szSQL = "SELECT Count(*) as ct FROM tbTK WHERE tmlb_id=" & CStr(miTmlb_id) & " AND tmlx_id=" & CStr(miTmlx_id) & " AND tmbh=" & CStr(bh)
    Set rs = gadoCONN.Execute(szSQL)
    If Not rs.EOF Then rs.MoveLast
    If Not rs.BOF Then rs.MoveFirst
    If ToLong(rs("ct")) >= 1 Then
        MsgBox "该题目编号已经使用，请用其他编号！", vbOKOnly + vbInformation, Me.Caption
        Text1(1).SetFocus
        Exit Sub
    End If
    
    '保存记录
    Adodc1.Recordset.Move 0
        
    '添加新记录
    Call InsertRow
    
    Text1(1).SetFocus
    Exit Sub
ErrHandler:
    Set rs = Nothing
    ErrMessageBox "保存记录cmdOK_Click()", Me.Caption
End Sub
Private Sub Combo1_Click()
    txtTmda.Text = Combo1.Text
End Sub

Private Sub cmdClear_Click()
    Text1(9).Text = ""
    Image1.Picture = LoadPicture()
End Sub

Private Sub Form_Load()
    On Error Resume Next
    
    '是选择题还是判断题
    Select Case miTmlx_id
        Case 0 '选择题
            Me.Caption = "添加选择题"
            Combo1.AddItem "A"
            Combo1.AddItem "B"
            Combo1.AddItem "C"
            Combo1.AddItem "D"
            Combo1.AddItem "E"
            Combo1.AddItem "F"
        Case 1 '判断题
            Me.Caption = "添加判断题"
            Combo1.AddItem "对"
            Combo1.AddItem "错"
            
            Call ChangePosition
            
            Frame1.Visible = False
    End Select
    '
'    Picture1.CurrentX = 600
'    Picture1.CurrentY = 800
'    Picture1.Print "图片预览"
    '
    Set Adodc1.Recordset = rs
    '添加一行
    Call InsertRow
End Sub
Private Sub Text1_Change(Index As Integer)
    If miTmlb_id = 0 Then
        Select Case Index
            Case 1, 2, 3, 4, 5
                If (Text1(1).Text = "") Or (Text1(2).Text = "") Or (Text1(3).Text = "") Or (Text1(4).Text = "") Or (Text1(5).Text = "") Then
                    cmdOK.Enabled = False
                Else
                    cmdOK.Enabled = True
                End If
            Case Else
        End Select
    Else
        Select Case Index
            Case 1, 2
                If (Text1(1).Text = "") Or (Text1(2).Text = "") Then
                    cmdOK.Enabled = False
                Else
                    cmdOK.Enabled = True
                End If
            Case Else
        End Select
    End If
End Sub
Private Sub Text1_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then '回车键
        If miTmlx_id = 0 Then '选择题
            Select Case Index
                Case 8
                    Combo1.SetFocus
                Case Else
                    Text1(Index + 1).SetFocus
            End Select
        Else '判断题
            SendKeys "{tab}"
        End If
    End If
End Sub
Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then '回车键
        SendKeys "{Tab}"
    End If
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
    If Index = 1 Then '编号
        If KeyAscii < 48 Or KeyAscii > 57 Then '只允许输入数字
            KeyAscii = 0
        End If
    End If
End Sub
'如果是判断题，则调整各控件的位置
Private Sub ChangePosition()
    Dim offset As Integer
    
    offset = Frame1.Height
        
    Picture1.Top = Picture1.Top - offset
    lblTmda.Top = lblTmda.Top - offset
    Combo1.Top = Combo1.Top - offset
    lblTp.Top = lblTp.Top - offset
    Text1(9).Top = Text1(9).Top - offset
    cmdBrowse.Top = cmdBrowse.Top - offset
    cmdClear.Top = cmdClear.Top - offset
    cmdOK.Top = cmdOK.Top - offset
    cmdCancel.Top = cmdCancel.Top - offset
    
    Me.Height = Me.Height - offset
End Sub