frmdataout.frm

来自「企业人事管理系统,有考勤,人员管理等功能,值得研究,也是我付费弄来的,绝对超值」· FRM 代码 · 共 538 行 · 第 1/2 页

      Size            =   "2143;661"
      FontName        =   "宋体"
      FontHeight      =   180
      FontCharSet     =   134
      FontPitchAndFamily=   34
      ParagraphAlign  =   3
   End
End
Attribute VB_Name = "frmDataOut"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
  Dim outType As Integer '导出类型
  Dim outPath As String
  Dim outSql As String

Private Function outToExcel(ByVal strSql As String, ByVal WorksheeName As String, path As String) As Boolean
On Error GoTo err_outToExcel

'声明excel
 Dim objExcel As Excel.Application
 Dim objWorkbook As Workbook
 Dim objWorksheet As Worksheet
 
 Set objExcel = CreateObject("Excel.Application")
 Set objWorkbook = objExcel.Workbooks.Add
 Set objWorksheet = objWorkbook.Worksheets("sheet1")
 objWorksheet.Name = WorksheeName
 
 '声明adodb
 Dim rs As ADODB.Recordset
 Dim strMsg As String
 
 Set rs = ExecuteSQL(strSql, strMsg)
 
 i = 1
 rs.MoveFirst
 Do While Not rs.EOF
   
   For j = 1 To rs.Fields.Count
     objExcel.Cells(i, j) = rs.Fields(j - 1)
   Next
  i = i + 1
  rs.MoveNext
 Loop
 
 objWorkbook.SaveAs path

 objWorkbook.Close
 objExcel.Quit

 Set objWorksheet = Nothing
 Set objWorkbook = Nothing
 Set objExcel = Nothing
 outToExcel = True
 Exit Function

'错误处理
err_outToExcel:
 MsgBox Err.Description
 On Error Resume Next
 
 objWorkbook.Close
 objExcel.Quit

 Set objWorksheet = Nothing
 Set objWorkbook = Nothing
 Set objExcel = Nothing
 outToExcel = False
 
End Function

Private Sub cmdOut_Click()
 Select Case outType
 Case 1 '导出到Excel
     If outToExcel(outSql, "s1", outPath) = True Then
         MsgBox "导出成功"
     Else
         MsgBox "导出失败"
     End If
 Case 2
      If outToWord(outSql, outPath) = True Then
      MsgBox "导出成功"
      Else
      MsgBox "导出失败"
      End If
 Case 3
      If outToText(outSql, outPath) = True Then
      MsgBox "导出成功"
      Else
      MsgBox "导出失败"
      End If
      
 End Select
End Sub

Private Sub cmdPath_Click()
  Select Case outType
  Case 1
     cdgPath.Filter = "Excel文件(*.xls)|*.xls"
  Case 2
     cdgPath.Filter = "Word文件(*.doc)|*.doc"
  Case 3
    cdgPath.Filter = "记事本(*.txt)|*.txt"
  End Select
  cdgPath.ShowSave
  txtPath.Text = cdgPath.FileName
End Sub

Private Sub cmdPre_Click()
  SSTab1.Tab = 1
End Sub

Private Sub cmdSelNext_Click()
  If optExcel.Value = True Then
     outType = 1
     txtMessage.Text = "导出到Excel" & vbCrLf
     txtPath = App.path & "\1.xls"
  ElseIf optWord.Value = True Then
     txtMessage.Text = "导出到Word" & vbCrLf
      outType = 2
      txtPath = App.path & "\1.doc"
  Else
     txtMessage.Text = "导出到记事本" & vbCrLf
     outType = 3
     txtPath = App.path & "\1.txt"
  End If
     
    txtSQL = "select 工号,姓名,性别,薪金,所学专业,职务,工资类别,合同开始时间,合同终止时间,职工类型,工龄,生日,年龄,文化程度,民族,婚姻状况,政治面貌,身份证号,籍贯,联系电话,手机,家庭住址,健康状况 from t_br"
   SSTab1.Tab = 1
End Sub

Private Sub cmdSetNext_Click()
  txtMessage.Text = ""
    If optExcel.Value = True Then
     txtMessage.Text = "导出到Excel" & vbCrLf
  ElseIf optWord.Value = True Then
     txtMessage.Text = "导出到Word" & vbCrLf
  Else
     txtMessage.Text = "导出到记事本" & vbCrLf
  End If
  
  outPath = Trim(txtPath.Text)
  outSql = txtSQL.Text
  
  txtMessage.Text = txtMessage.Text & vbCrLf & "导出路径为：" & outPath
  txtMessage.Text = txtMessage.Text & vbCrLf & "查询语句为：" & outSql
  
  
  SSTab1.Tab = 2
End Sub

Private Sub cmdSetPre_Click()
 SSTab1.Tab = 0
End Sub





Private Function outToWord(ByVal strSql As String, ByVal path As String) As Boolean
  On Error GoTo err_outToWord
    Dim wRow As Integer
    Dim wCol As Integer
    '声明Adodb
    Dim rs As ADODB.Recordset
    Dim strMsg As String
    
    
    Set rs = ExecuteSQL(strSql, strMsg)

    wRow = rs.RecordCount
    wCol = rs.Fields.Count
    
      '声明Word对象
     Dim objWord As Word.Application
     Set objWord = CreateObject("word.application")
     Dim objDocument As New Document
   
     Set objDocument = objWord.Documents.Add
     objDocument.Tables.Add Range:=objWord.Selection.Range, NumRows:=wRow, NumColumns:=wCol
    
    rs.MoveFirst
    j = 1
    Do While Not rs.EOF
     For i = 1 To wCol
       objDocument.Tables(1).Cell(j, i).Select
       objWord.Selection.Range.Text = rs.Fields(i - 1).Value
    Next
    
    j = j + 1
    rs.MoveNext
    Loop

    objDocument.SaveAs FileName:=path
    
     objDocument.Close
     Set objDocument = Nothing
    objWord.Quit
    Set objWord = Nothing
    outToWord = True
    Exit Function
    
  '错误处理
err_outToWord:
  MsgBox Err.Description
  On Error Resume Next
   objDocument.Close
     Set objDocument = Nothing
    objWord.Quit
    Set objWord = Nothing
    outToWord = False
End Function


Private Function outToText(ByVal strSql As String, ByVal path As String) As Boolean
On Error GoTo err_outToText

 Dim rs As ADODB.Recordset
 Dim strMsg As String
 Dim field_with() As Integer
 Set rs = ExecuteSQL(strSql, strMsg)
 
 Dim f1
 f1 = FreeFile
 Open path For Output As f1
 ReDim field_width(rs.Fields.Count - 1)
 
 rs.MoveFirst
 Do While Not rs.EOF
 For i = 0 To rs.Fields.Count - 1
    field_width(i) = rs.Fields(i).DefinedSize
    If field_width(i) < Len(rs.Fields(i).Name) Then
          field_width(i) = Len(rs.Fields(i).Name)
    End If
    Print #f1, rs.Fields(i).Value;
    Print #f1, Space$(field_width(i) - Len(rs.Fields(i).Value));
 Next
  Print #f1, ""
 rs.MoveNext
 Loop
 Close f1
 rs.Close
 Set rs = Nothing
 outToText = True
 Exit Function
  
err_outToText:
  MsgBox Err.Description
  On Error Resume Next
  Close f1
 rs.Close
 Set rs = Nothing
 outToText = False
End Function

Private Sub Form_Load()
  SSTab1.Tab = 0
End Sub

Private Sub optNote_Click()

End Sub

Private Sub Frame1_DragDrop(Source As Control, X As Single, Y As Single)

End Sub