frmdata.frm

本人写的一个垃圾代码,主要是实现简单的打印功能

            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   240
         Left            =   240
         TabIndex        =   28
         Top             =   2400
         Width           =   1470
      End
      Begin VB.Label Label10 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "建 筑 面 积"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   720
         TabIndex        =   27
         Top             =   3600
         Width           =   1095
      End
      Begin VB.Label Label25 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "建 筑 层 数"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   255
         Left            =   720
         TabIndex        =   26
         Top             =   4200
         Width           =   1095
      End
      Begin VB.Label Label11 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "西至"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   240
         Left            =   6600
         TabIndex        =   25
         Top             =   3600
         Width           =   450
      End
      Begin VB.Label Label8 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "南至"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   240
         Left            =   6600
         TabIndex        =   24
         Top             =   4200
         Width           =   450
      End
      Begin VB.Label Label5 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "北至"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   240
         Left            =   6600
         TabIndex        =   23
         Top             =   4800
         Width           =   450
      End
      Begin VB.Label Label4 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "东至"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         ForeColor       =   &H00C00000&
         Height          =   240
         Left            =   6600
         TabIndex        =   22
         Top             =   3000
         Width           =   450
      End
      Begin VB.Label Label3 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "土地使用证号"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   240
         Left            =   5760
         TabIndex        =   21
         Top             =   1200
         Width           =   1350
      End
      Begin VB.Label Label23 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "号"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   240
         Left            =   4800
         TabIndex        =   20
         Top             =   600
         Width           =   225
      End
      Begin VB.Label Label22 
         AutoSize        =   -1  'True
         BackStyle       =   0  'Transparent
         Caption         =   "日 期"
         BeginProperty Font 
            Name            =   "Microsoft Sans Serif"
            Size            =   9.75
            Charset         =   0
            Weight          =   400
            Underline       =   0   'False
            Italic          =   0   'False
            Strikethrough   =   0   'False
         EndProperty
         Height          =   240
         Left            =   1320
         TabIndex        =   19
         Top             =   4800
         Width           =   495
      End
   End
End
Attribute VB_Name = "frmData"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private blnChange As Boolean
Private Sub cmdPrint_Click()
  If MsgBox("确定打印吗？", vbQuestion + vbYesNo, "问题") = vbYes Then
    TextPrint frmA
  End If
End Sub




Private Sub cmdAdd_Click()
'Dim fso As New FileSystemObject
'Dim file1, file2 As File
'Dim ts As TextStream
Dim strbhqz As String

On Error GoTo ErrOpenFile
    Call ClearFrm(Me) '清除窗体
    'Set file1 = fso.OpenTextFile(App.Path & "\zjqz.txt")
    'Set file2 = fso.GetFile(App.Path & "\zjqz.txt")
    'Set ts = file2.OpenAsTextStream(ForReading)
    Open "zjqz.txt" For Input As #1
    
    Input #1, strbhqz
    
    txtFrmData(0).Text = strbhqz
    txtFrmData(1).SetFocus
    
     'cmdAdd.Enabled = False
   Exit Sub
ErrOpenFile:
    MsgBox err.Description, vbExclamation + vbOKOnly, "打开前缀文件错误"
    End
End Sub



Private Sub cmdClear_Click()
   Call ClearFrm(Me)
  'cmdAdd.Enabled = True
End Sub



Private Sub cmdDelete_Click()
    Dim strQuery As String '查询各表中是否存在
    Dim strSQL As String   '执行删除操作的SQL语句
    Dim strPrompt As String '提示信息
    Dim strDelKey As String '要删除的案例编号
    Dim rst As ADODB.Recordset
    If txtFrmData(1).Text = "" Then
        Call ClearFrm(Me)
       Exit Sub
    End If
    strDelKey = Trim(txtFrmData(1).Text)
    Set rst = New ADODB.Recordset
    
    rst.CursorLocation = adUseClient
    strQuery = "select * from 基本情况 where 编号='" & strDelKey & "'"
    rst.Open strQuery, myDB, adOpenForwardOnly, adLockReadOnly
    If Not rst.EOF Then
        strPrompt = "确定删除编号=" & strDelKey & "的记录吗?"
        If MsgBox(strPrompt, vbYesNo + vbQuestion, "问题") = vbYes Then
     
            strSQL = "delete from 基本情况 where 编号='" & strDelKey & "'" '实例库表
            myDB.Execute strSQL
            MsgBox "记录被成功删除", vbInformation, "提示"
            Call ClearFrm(Me)
        End If
    Else
       strPrompt = "你要删除的记录不存在!"
        MsgBox strPrompt, vbOKOnly, "提示"
        Call ClearFrm(Me)
    End If
    
     rst.Close
    Set rst = Nothing
End Sub

Private Sub cmdSave_Click()
    Dim rst As ADODB.Recordset
    Dim strSQL, strLs As String
    On Error GoTo err
    
    Set rst = New ADODB.Recordset
    
    If Trim(txtFrmData(1).Text) = "" Then
        MsgBox "编号不能为空，请先添加或输入编号！", vbOKOnly + vbInformation, "提示"
        txtFrmData(1).SetFocus
        Exit Sub
    End If
    If Trim(txtFrmData(11).Text) = "" Then
      MsgBox "日期不能为空，请输入！", vbOKOnly + vbInformation, "提示"
        txtFrmData(11).SetFocus
        Exit Sub
    End If
    strSQL = "Select * from 基本情况 where 编号='" & Trim(txtFrmData(1).Text) & "'"
 
    rst.Open strSQL, myDB, adOpenDynamic, adLockOptimistic
    Debug.Print Val("")
    If rst.EOF Then
        '插入表
        strSQL = ConstructInsertSQL(Me, "基本情况", "")
        Debug.Print strSQL
        
        myDB.Execute strSQL
      
        MsgBox "保存成功！", vbOKOnly + vbInformation, "添加"
        'Call ClearFrm(Me)

    Else
         '修改表
         If MsgBox("编号已存在，是否更新原有编号的内容？ ", vbQuestion + vbYesNo, "提示") = vbYes Then
             strSQL = ConstructUpdateSQL(Me, "基本情况", "", "编号")
             Debug.Print strSQL
             myDB.Execute strSQL
             MsgBox "保存成功！", vbOKOnly + vbInformation, "修改"
         End If

    End If
    cmdAdd.Enabled = True
    
    Exit Sub
err:
   MsgBox "错误:" & err.Description, vbInformation, "提示"
End Sub

Private Sub DTPicker1_Change()
      txtFrmData(11).Text = DTPicker1.Value
End Sub


Private Sub Form_Resize()

  Static iLeft1, iTop1, iLeft2
  Static ifrmWidth, ifrmHeight

  Debug.Print ifrmWidth, ifrmHeight
  If Not (ifrmWidth = 0 Or ifrmHeight = 0) Then
  Picture1.Left = iLeft1 + (Me.Width - ifrmWidth) / 2
  Picture1.Top = iTop1 + (Me.Height - ifrmHeight) / 2
  Picture2.Top = Picture1.Top + 6000
  Picture2.Left = iLeft2 + (Me.Width - ifrmWidth) / 2
  End If
  iLeft1 = Picture1.Left
  iTop1 = Picture1.Top
  
  iLeft2 = Picture2.Left
  
  ifrmWidth = Me.Width
  ifrmHeight = Me.Height
End Sub



Private Sub txtFrmData_Change(Index As Integer)
    Select Case Index
        Case 8, 9, 10
           txtFrmData(Index) = TextExam(txtFrmData(Index).Text, "1234567890.")
        
    End Select
End Sub

Private Sub txtFrmData_KeyDown(Index As Integer, KeyCode As Integer, Shift As Integer)
  
    Dim strKey As String
    Dim rst As ADODB.Recordset
    On Error GoTo err
       
    Set rst = New ADODB.Recordset

    If KeyCode <> 13 Then
        Exit Sub
    End If
    If Index = 1 Then
          If Trim(txtFrmData(1).Text) <> "" Then
                strKey = Trim(txtFrmData(1).Text)
             '显示实例表
                strSQL = "select * from 基本情况 where 编号='" & strKey & "'"
                rst.Open strSQL, myDB, adOpenForwardOnly, adLockOptimistic
                If Not rst.EOF Then
                    If MsgBox("编号重复,要修改原有的资料吗？", vbQuestion + vbYesNo, "提示") = vbYes Then
                        Call ShowDB(Me, strSQL)
                    Else
                        txtFrmData(1).Text = ""
                        txtFrmData(1).SetFocus
                    End If
                Else
                    SendKeys "{tab}"
                End If
              
            Else
                Call ClearFrm(Me)
            End If
    Else
       SendKeys "{tab}"
    End If
    rst.Close
    Set rst = Nothing
    
    Exit Sub
err:
    MsgBox err.Description, vbInformation, "提示"
End Sub


'Private Sub txtFrmData_LostFocus(Index As Integer)
'    If Index = 8 Then
'       Debug.Print Val(txtFrmData(4).Text)
'    End If
'End Sub