form2.frm

软测量软件包（BP+MATLAB）

VERSION 5.00
Begin VB.Form Form2 
   BackColor       =   &H80000013&
   ClientHeight    =   3195
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   4680
   Icon            =   "Form2.frx":0000
   LinkTopic       =   "Form2"
   ScaleHeight     =   3195
   ScaleWidth      =   4680
   StartUpPosition =   2  'CenterScreen
   Begin VB.CommandButton Command1 
      Caption         =   "忽略"
      Height          =   615
      Index           =   2
      Left            =   3240
      TabIndex        =   2
      Top             =   1920
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      Caption         =   "复制到原表"
      Height          =   615
      Index           =   1
      Left            =   1680
      TabIndex        =   1
      Top             =   1920
      Width           =   1215
   End
   Begin VB.CommandButton Command1 
      BackColor       =   &H00C0C0FF&
      Caption         =   "新建一张表"
      Height          =   615
      Index           =   0
      Left            =   120
      MaskColor       =   &H0080C0FF&
      TabIndex        =   0
      Top             =   1920
      Width           =   1215
   End
   Begin VB.Label Label1 
      BackColor       =   &H80000016&
      Caption         =   "请选择你要进行的操作"
      BeginProperty Font 
         Name            =   "隶书"
         Size            =   15.75
         Charset         =   134
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H000000FF&
      Height          =   375
      Left            =   600
      TabIndex        =   3
      Top             =   600
      Width           =   3375
   End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Sub Command1_Click(Index As Integer)
Select Case Index
Case 0
Unload Me
Form1.Show
Call CreateTable
If intnewname = "" Or flag5 = 1 Then
Form2.Show
Form1.Hide
 Exit Sub

End If
Call Choose
Case 1
flag8 = 1
If flag = 0 Then
MsgBox ("字段名必须和上次一样")
Exit Sub
End If
Call Choose
Form1.Show

Case 2
Unload Me
Form1.Show
End Select

End Sub
Sub CreateTable()
'Set cnn2 = New ADODB.Connection
'strcon = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=gqw"
'cnn2.Open strcon

Set rs1 = New ADODB.Recordset
rs1.CursorLocation = adUseClient
intnewname = InputBox("请输入你新表的名称", "新表名称", Chr(13))
 If Trim(intnewname) = "" Then
 'MsgBox "按了取消键，或没输入任何内容"
 intnewname = oldtabname
 flag5 = 1
 Exit Sub

  End If
  If Trim(intnewname) = Chr(13) Then
  'MsgBox "按了确定键，没有任何输入"
  intnewname = oldtabname       '恢复为上一次的值
  flag5 = 1
  Exit Sub
End If
oldtabname = intnewname
If flag7 = 1 Then
aa(t) = zdname
End If
 'MkDir intnewlocation
      curCreateSql = "create table " + intnewname + " ("
    For i = 1 To t
        If i > 1 Then
            curCreateSql = curCreateSql & ","
        End If
        curCreateSql = curCreateSql & aa(i)
        curCreateSql = curCreateSql & " " & bb(i) & "(" & cc(i) & ")"
    Next i
    curCreateSql = curCreateSql & ")"
    Debug.Print curCreateSql
     rs1.Open curCreateSql, cnn1
   ' cnn1.Execute curCreateSql
   ' End Select

End Sub
Sub Choose()

If dc1 <> "" And dc2 <> "" Then
  'Form1.Adodc2.RecordSource = "select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc1) + "%'" + " or " + " date_time like '%" + Trim(dc2) + "%'" + " and " + LTrim(RTrim(aa(t))) + " <>'0.0000'"
  
  'Form1.Adodc2.Refresh
 Set rs3 = New ADODB.Recordset
  rs3.CursorLocation = adUseClient
   rs3.Open "select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc1) + "%'" + " or " + " date_time like '%" + Trim(dc2) + "%'", cnn1
 ' newstring = "select " + sColumn + " from " + sFilename + CheckString
  'Debug.Print newstring
   Set Form1.DataGrid2.DataSource = rs3
   Call AppendRecord
   Set rr = rs3
   strOut = App.Path + "\test.txt"
    Call OutputText
 'Set rsu = New Recordset

'Set rsu = cnn1.Execute(strsql, -1)
'FileCopy "C:\Program Files\Microsoft Visual Studio\vb98\" & intnewname, intnewlocation & "\" & intnewname
MsgBox ("表已经生成")
Else
 If dc1 <> "" And dc2 = "" Then
'Form1.Adodc2.RecordSource = "Select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc1) + "%'"
' Form1.Adodc2.Refresh
  Set rs3 = New ADODB.Recordset
  rs3.CursorLocation = adUseClient
   rs3.Open "select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc1) + "%'", cnn1
   Set Form1.DataGrid2.DataSource = rs3
   'Form1.DataGrid2.Refresh
  Call AppendRecord
  Set rr = rs3
   strOut = App.Path + "\test.txt"
  Call OutputText
 '    Form1.Hide
  ' Form2.Show
Else
 If dc1 = "" And dc2 <> "" Then
      Form1.Adodc2.RecordSource = "Select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc2) + "%'"
  Form1.Adodc2.Refresh
   Set rs3 = New ADODB.Recordset
   rs3.CursorLocation = adUseClient
  rs3.Open "select " + sColumn + " from " + sFilename + " where date_time like '%" + Trim(dc2) + "%'", cnn1
    Set Form1.DataGrid2.DataSource = rs3
   Call AppendRecord
   Set rr = rs3
    strOut = App.Path + "\test.txt"
    Call OutputText
    
Else
 
   'Form1.DataGrid2.Refresh

' 这部分注释很重要，不能删除！！！
' newstring = "select " + sColumn + " from " + sFilename + CheckString
'  Debug.Print newstring
'Form1.Adodc2.RecordSource = "select " + sColumn + " from " + sFilename + CheckString
'  Form1.Adodc2.Refresh
'  Set rs1 = New ADODB.Recordset
'rs1.Open "select " + sColumn + " from " + sFilename + CheckString, cnn1
 Call AppendRecord
' Form1.Adodc2.RecordSource = mystr1
 'Form1.Adodc2.Refresh
Set rr = rs3
  strOut = App.Path + "\test.txt"
 Call OutputText
    
   
 'End If
  End If
  
End If
   
 
End If
End Sub
Sub AppendRecord()
'Set cnn2 = New ADODB.Connection

'strcon = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=gqw"
'cnn2.Open strcon
Dim rs2 As ADODB.Recordset
Set rs2 = New ADODB.Recordset
rs2.CursorLocation = adUseClient
rs2.Open "select *  from " & intnewname, cnn1, adOpenDynamic, adLockOptimistic
If rs3.RecordCount > 0 Then

rs3.MoveFirst
Do While Not rs3.EOF
  rs2.AddNew
   For i = 0 To rs3.Fields.Count - 1
       rs2.Fields(i).Value = rs3.Fields(i).Value
Next i
rs2.Update
   rs3.MoveNext
   
Loop
MsgBox ("表已经生成")
End If
Call ExporToExcel(rs2)
zd = rs2.RecordCount

'Set rsu = New Recordset

'Set rsu = cnn1.Execute(strsql, -1)
'FileCopy "C:\Program Files\Microsoft Visual Studio\vb98\" & intnewname, intnewlocation & "\" & intnewname

End Sub
Private Sub ExporToExcel(strOpen As ADODB.Recordset)
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************

Dim Rs_Data As New ADODB.Recordset
Dim Irowcount As Integer
Dim Icolcount As Integer
    
    Dim xlApp As New Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Dim xlQuery As Excel.QueryTable
    'Dim db As Database
    
    
   ' With Rs_Data
       ' If .State = adStateOpen Then
       '     .Close
      '  End If
       ' .ActiveConnection = Cn
        '.CursorLocation = adUseClient
       ' .CursorType = adOpenStatic
      '  .LockType = adLockReadOnly
       ' .Source = strOpen
        
      '  .Open
   ' End With
   Set Rs_Data = strOpen
    With Rs_Data
        If .RecordCount < 1 Then
            MsgBox ("没有记录!")
            Exit Sub
        End If
        '记录总数
        Irowcount = .RecordCount
        '字段总数
        Icolcount = .Fields.Count
    End With
    
    Set xlApp = CreateObject("Excel.Application")
    Set xlBook = Nothing
    Set xlSheet = Nothing
    Set xlBook = xlApp.Workbooks().Add
    Set xlSheet = xlBook.Worksheets("sheet1")
    xlApp.Visible = True
    
    '添加查询语句，导入EXCEL数据
    If flag8 = 0 Then
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
    
    With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    
   ' With xlSheet
       ' .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Name = "黑体"
        '设标题为黑体字
       ' .Range(.Cells(1, 1), .Cells(1, Icolcount)).Font.Bold = True
        '标题字体加粗
       ' .Range(.Cells(1, 1), .Cells(Irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous
        '设表格边框样式
  '  End With
    
   ' With xlSheet.PageSetup
        '.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10公司名称："   ' & Gsmc
        '.CenterHeader = "&""楷体_GB2312,常规""公司人员情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
        '.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10单位："
        '.LeftFooter = "&""楷体_GB2312,常规""&10制表人："
        '.CenterFooter = "&""楷体_GB2312,常规""&10制表日期："
        '.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
   ' End With
    
    'xlApp.Application.Visible = True
    xlBook.SaveAs App.Path + "\" + intnewname + ".xls"
    Else
    Kill App.Path + "\" + intnewname + ".xls"
    Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a1"))
     With xlQuery
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = True
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .PreserveColumnInfo = True
    End With
    
    xlQuery.FieldNames = True '显示字段名
    xlQuery.Refresh
    xlBook.SaveAs App.Path + "\" + intnewname + ".xls"
    ' xlApp.Workbooks.Open App.Path + "\" + intnewname + ".xls"
    
  '  i = 1
   ' Do While xlApp.ActiveWorkbook.Sheets(1).Cells(i, 1) <> ""
   ' i = i + 1
  '  Loop
    
    
 ' Set xlQuery = xlSheet.QueryTables.Add(Rs_Data, xlSheet.Range("a" + CStr(i + 1) + ""))
    
    End If
    
    Set xlApp = Nothing  '"交还控制给Excel
    Set xlBook = Nothing
    Set xlSheet = Nothing

End Sub