form1.frm

本软件可以实现从sqlserver数据库的表中导出所有的数据到excel表格中

MsgBox ("没有记录!")
Exit Function
End If
'记录总数
irowcount = .RecordCount
If .RecordCount > 65534 Then
    MsgBox "电子表格导出记录最大数为65535，您导出的数据过多，请重新选择起始和结束时间！"
    Exit Function
End If
'字段总数
Icolcount = .Fields.Count
End With

Set xlApp = CreateObject("Excel.Application") '创建excel对象
Set xlBook = Nothing '工作簿
Set xlsheet = Nothing '工作表
Set xlBook = xlApp.Workbooks().Add '添加一个工作簿
Set xlsheet = xlBook.Worksheets("sheet1") '工作表
'xlApp.Visible = True '意思不明白，加上没影响！

'添加查询语句，导入EXCEL数据
Set xlQuery = xlsheet.QueryTables.Add(Rs_Data, xlsheet.Range("a1")) '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 = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(irowcount + 1, Icolcount)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End With

With xlsheet.PageSetup
Rem 以下页面设置因其个性化太强，故不用
'.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
Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlsheet = Nothing
Set xlQuery = Nothing
Rs_Data.Close
Set Rs_Data = Nothing
MsgBox "电子表格导出操作顺利完成！"

If Combo1.Text = "是" Then
    With Ds_Data '记录集对象
        If .State = adStateOpen Then
        .Close '如果记录集处于打开状态，则先关闭它
        End If
        .ActiveConnection = getconnobj '连接
        .CursorLocation = adUseClient '本地游标
        .CursorType = adOpenStatic '静态游标
        .LockType = adLockReadOnly '只读
        .Source = DelDBString '通过函数传过来的字符串
        .Open
    End With
        Ds_Data.Close
    Set Ds_Data = Nothing
    MsgBox "数据删除操作顺利完成！"

Else
End If

End Function

Rem 导出电子表格excel的自定义过程
'接收参数：查询字符串，电子表格名
Public Sub ghexcel(stropen As String, cexcelname As String)
On Error GoTo gherr
If Len(stropen) = 0 Or Len(cexcelname) = 0 Then
MsgBox ("没有可导出数据信息或没有指定文件名，导出操作已取消")
Exit Sub
End If
Dim icol As Integer '列数，用于保存字段个数
Dim rstable As New ADODB.Recordset
Dim ijlts As Long '记录条数


Dim AppExcel As Excel.Application '定义尚未创建
Dim BookExcel As Excel.Workbook '工作簿对象
Dim sheetexcel As Excel.Worksheet '工作表


'If Not mainmoudle.getlink Then
'Exit Sub
'End If

With rstable '记录集对象
If .State = adStateOpen Then
.Close '如果记录集处于打开状态，则先关闭它
End If
.ActiveConnection = getconnobj '连接
.CursorLocation = adUseClient '本地游标
.CursorType = adOpenStatic '静态游标
.LockType = adLockReadOnly '只读
.Source = stropen '通过参数传过来的字符串
.Open
End With

With rstable
If .RecordCount < 1 Then
MsgBox ("没有记录,导出操作已被取消！")
Exit Sub
End If
'记录总数
'Irowcount = .RecordCount
'字段总数
icol = .Fields.Count '求出字段数
ijlts = .RecordCount
End With

' Set AppExcel = CreateObject("Excel.Application") '这句起何作用？

If Dir$(cexcelname) = "" Then
Set AppExcel = New Excel.Application '创建excel对象
AppExcel.Visible = False '什么用处？
Set BookExcel = AppExcel.Workbooks.Add '添加工作表
Set sheetexcel = BookExcel.Worksheets("sheet1")
' AppExcel.Worksheets(1).Name = "工作表一" '在Text1中输入表名
For icol = 0 To rstable.Fields.Count - 1
AppExcel.Worksheets(1).Cells(1, icol + 1).Value = rstable.Fields(icol).Name
Next

AppExcel.Worksheets(1).Range("A2").CopyFromRecordset rstable

With sheetexcel
.Range(.Cells(1, 1), .Cells(1, 5)).Font.Name = "黑体"
'设标题为黑体字
.Range(.Cells(1, 1), .Cells(1, 5)).Font.Bold = False '不加粗
'标题字体加粗
.Range(.Cells(1, 1), .Cells(ijlts + 1, icol)).Borders.LineStyle = xlContinuous '如果第一行不显示字段，则不用加一
'设表格边框样式
End With

'以下一句用法是正确的
'sheetexcel.Range(sheetexcel.Cells(3, 1), sheetexcel.Cells(3.3)).Font.Size = 120

BookExcel.SaveAs (cexcelname)
Else
MsgBox ("该文件名已经存在，不能导出，否则将覆盖,请给出新的名称")
Exit Sub
' Set BookExcel = AppExcel.Workbooks.Open(ExcelFileName)
' AppExcel.Worksheets(1).Name = "zgh2 table" '在Text1中输入表名
' AppExcel.Worksheets(1).Range("A70").CopyFromRecordset rsTable
' BookExcel.SaveAs (ExcelFileName)
End If


AppExcel.Quit '这一句起何作用？
Set sheetexcel = Nothing
Set BookExcel = Nothing
Set AppExcel = Nothing
rstable.Close
Set rstable = Nothing

MsgBox "电子表格导出操作顺利完成！"

Exit Sub
gherr:
MsgBox Err.Number & "," & Err.Description

End Sub

Private Sub Command1_Click()
Dim ConDBString As String

Dim contime1 As String
Dim contime2 As String
contime1 = Mid(Format(DTPicker1.Value, "yyyymmdd"), 1, 4) + "-" + Mid(Format(DTPicker1.Value, "yyyymmdd"), 5, 2) + "-" + Mid(Format(DTPicker1.Value, "yyyymmdd"), 7, 2) + " 00:00"
contime2 = Mid(Format(DTPicker2.Value, "yyyymmdd"), 1, 4) + "-" + Mid(Format(DTPicker2.Value, "yyyymmdd"), 5, 2) + "-" + Mid(Format(DTPicker2.Value, "yyyymmdd"), 7, 2) + "23:59"
ConDBString = "select * from train where 过衡时间 > '" & contime1 & "' and 过衡时间 <'" & contime2 & "'"
DelDBString = "delete from train where 过衡时间 > '" & contime1 & "' and 过衡时间 <'" & contime2 & "'"

ExportToExcel (ConDBString)

End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Combo1.AddItem "是"
Combo1.AddItem "否"
Combo2.AddItem "监控室"
Combo2.AddItem "检测室"
'getconn

 Set objFileSystem = CreateObject("Scripting.FileSystemObject")
 Strcfgfilename = App.Path + "\config.cfg"
     If (objFileSystem.FileExists(Strcfgfilename)) Then
        Call LoadCfg
    Else
        Call DefaultCfg
        Call LoadCfg
    End If
    getconnobj
End Sub
Private Sub LoadCfg()
    Dim strInput As String
    Dim strvalue As String
    Dim t As Long
    On Error Resume Next
    '[ComConfig]
   
    'sql config
    strvalue = String(255, " ")
    t = GetPrivateProfileString("config", "sever", "sql sever", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    VarDriver = Mid(strvalue, 1, Len(strvalue) - 1) 'DATABASE DRIVER
   
    strvalue = String(255, " ")
    t = GetPrivateProfileString("sql", "severname", "test", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    VarServer = Mid(strvalue, 1, Len(strvalue) - 1) 'SERVER NAME

    strvalue = String(255, " ")
    t = GetPrivateProfileString("sql", "databasename", "dfrw", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    VarDbase = Mid(strvalue, 1, Len(strvalue) - 1) 'DATABASE NAME

    strvalue = String(255, " ")
    t = GetPrivateProfileString("sql", "userid", "sa", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    VarUser = Mid(strvalue, 1, Len(strvalue) - 1)  'UESR NAME

    strvalue = String(255, " ")
    t = GetPrivateProfileString("sql", "passwd", "123456", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    VarPassword = Mid(strvalue, 1, Len(strvalue) - 1) 'UESR PASSWORD
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("sql", "sqlconnection", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    BSqlConnection = Mid(strvalue, 1, Len(strvalue) - 1) 'AConnect  SQL SERVER 2000 TRUE OR FALSE
    'access config
    strvalue = String(255, " ")
    t = GetPrivateProfileString("access", "Data Source", "dfrw", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataSouce = Mid(strvalue, 1, Len(strvalue) - 1) 'AConnect  ACCESS DATASOUCE

    strvalue = String(255, " ")
    t = GetPrivateProfileString("access", "accessconnection", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    BAccessConnection = Mid(strvalue, 1, Len(strvalue) - 1) 'AConnect  ACCESS TRUE OR FALSE
    'datafile path
    strvalue = String(255, " ")
    t = GetPrivateProfileString("datafile path", "datafile", "C:\LY.PRN", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataFile = Mid(strvalue, 1, Len(strvalue) - 1) 'DATA FILE PATH
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("datafile path", "DataSave", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataSave = Mid(strvalue, 1, Len(strvalue) - 1) 'DATA FILE SAVE TRUE OR FALSE
    'trainnum file path
    strvalue = String(255, " ")
    t = GetPrivateProfileString("trainnum file path", "trainnumfile", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    TrainNumFile = Mid(strvalue, 1, Len(strvalue) - 1) 'READ TRAINNUM FILE PATH

    strvalue = String(255, " ")
    t = GetPrivateProfileString("trainnum file path", "trainnumconnection", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    BTrainNumConnection = Mid(strvalue, 1, Len(strvalue) - 1) 'READ TRAINNUM FILE PATH
    'upload file config
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "TrainDirection", "12", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    BDirection = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "uploadfile", "12", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrUploadFilePath = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "FT_Lable", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrFT_Lable = Mid(strvalue, 1, Len(strvalue) - 1) '
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "FT_Server_IP", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrFT_Server_IP = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "FT_Server_Port", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrFT_Server_Port = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("upload file config", "FT_BakDir", "1", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrFT_BakDir = Mid(strvalue, 1, Len(strvalue) - 1)
    'datalist config
    strvalue = String(255, " ")
    t = GetPrivateProfileString("datalist config", "dataitemNo", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataItemNo = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("datalist config", "datalist", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataList = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("datalist config", "datalistwidth", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    DataListWidth = Mid(strvalue, 1, Len(strvalue) - 1)

    'print config
    strvalue = String(255, " ")
    t = GetPrivateProfileString("print config", "printtablehand", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrPrintTableHand = Mid(strvalue, 1, Len(strvalue) - 1)
    
    strvalue = String(255, " ")
    t = GetPrivateProfileString("print config", "printtablehandsize", "0", strvalue, 255, Strcfgfilename)
    strvalue = Trim(strvalue)
    StrPrintTableHandSize = Mid(strvalue, 1, Len(strvalue) - 1)
End Sub
Private Sub DefaultCfg()
On Error Resume Next
Open (Strcfgfilename) For Append As #1
    Print #1, "[ComConfig]"
    Print #1, "COM1 = ON, 9600, n, 8, 1"
    Print #1, "COM2 = ON, 9600, n, 8, 1"
    Print #1, "COM3 = OFF, 9600, n, 8, 1"
    Print #1, "COM4 = OFF, 9600, n, 8, 1"
    Print #1, "COM5 = OFF, 9600, n, 8, 1"
    Print #1, "COM6 = OFF, 9600, n, 8, 1"
    Print #1, "COM7 = OFF, 9600, n, 8, 1"
    Print #1, "COM8 = OFF, 9600, n, 8, 1"
    Print #1, ""
    Print #1, "[sql]"
    Print #1, "sever= sql server"
    Print #1, "severname = 127.0.0.1"
    Print #1, "DatabaseName = ftx"
    Print #1, "userid = sa"
    Print #1, "passwd = 0823261"
    Print #1, "sqlconnection = 1"
    Print #1, "//0:不导入Sql server 2000"
    Print #1, "//1:导入Sql server 2000"
    Print #1, ""
    Print #1, "[access]"
    Print #1, "Data Source = dfrw"
    Print #1, "accessconnection = 0"
    Print #1, "//0:不导入Access"
    Print #1, "//1:导入Access"
    Print #1, ""
    Print #1, "[datafile path]"
    Print #1, "datafile=C:\gc.txt"
    Print #1, "datasave = 0"
    Print #1, "//0:不保存称重历史文件"
    Print #1, "//1:保存称重历史文件,文件名及存储路径:年月日时分秒.txt"
    Print #1, "datasavepath=d:\rw\data"
    Print #1, "//用户可以指定历史记录保存的主文件夹"
    Print #1, ""
    Print #1, "[trainnum file path]"
    Print #1, "trainnumfile=c:\tran\chreport.rep"
    Print #1, "trainnumconnection = 0"
    Print #1, "//0:不读取车号"
    Print #1, "//1:读取车号"
    Print #1, ""
    Print #1, "[upload file config]"
    Print #1, "TrainDirection=0"
    Print #1, "uploadfile=D:\rw\gc.txt"
    Print #1, "FT_Lable=1"
    Print #1, "FT_Server_IP =127.0.0.1"
    Print #1, "FT_Server_Port = 12349"
    Print #1, "FT_BakDir = ./send/"
    Print #1, ""
    Print #1, "[datalist config]"
    Print #1, "dataitemNo = 15"
    Print #1, "datalist =过衡时间,序号,车号,车号,速度,总重,自重,标重,净重,盈亏,发站,到站,车型,到站,发站,"
    Print #1, "datalistwidth=1600,600,800,900,800,800,800,800,800,800,1000,1000,1000,1000,800,"
    Print #1, "//dataitemNo为列表项的数目，datalist为列表列名称，datalistwidth为列表宽度。"
    Print #1, ""
    Print #1, "[print config]"
    Print #1, "printtablehand = 北京东方瑞威科技发展有限公司"
    Print #1, "printtablehandsize = 20"
Close #1
End Sub