frm_cartoon_outstemperspecbill.frm

一个公司的客户财产管理系统vb源码

VERSION 5.00
Object = "{86CF1D34-0C5F-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCT2.OCX"
Begin VB.Form Frm_Cartoon_OutStemperSpecBill 
   BackColor       =   &H00C0FFC0&
   BorderStyle     =   0  'None
   Caption         =   "Form1"
   ClientHeight    =   1020
   ClientLeft      =   8100
   ClientTop       =   5535
   ClientWidth     =   6030
   LinkTopic       =   "Form1"
   LockControls    =   -1  'True
   ScaleHeight     =   1020
   ScaleWidth      =   6030
   ShowInTaskbar   =   0   'False
   Begin VB.Timer Timer1 
      Enabled         =   0   'False
      Interval        =   1000
      Left            =   0
      Top             =   30
   End
   Begin MSComCtl2.Animation Animation1 
      Height          =   615
      Left            =   540
      TabIndex        =   0
      Top             =   203
      Width           =   1095
      _ExtentX        =   1931
      _ExtentY        =   1085
      _Version        =   393216
      FullWidth       =   73
      FullHeight      =   41
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "正在将数据导出到EXCEL表格，请稍等......"
      ForeColor       =   &H000000FF&
      Height          =   180
      Left            =   1980
      TabIndex        =   1
      Top             =   420
      Width           =   3510
   End
End
Attribute VB_Name = "Frm_Cartoon_OutStemperSpecBill"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

'声明API函数
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'定义变量
Dim TabName As String
Dim Selection As String
'*********************************************************
'* 名称：ExporToExcel
'* 功能：导出数据到EXCEL
'* 用法：ExporToExcel(sql查询字符串)
'*********************************************************
Private Function ExporToExcel(strOpen As String)
On Error GoTo err

    '如果EXCEL文件已经打开,需要先关闭它.
    Dim lpClassName As String
    Dim lpCaption As String
    Dim Handle As Long
    lpClassName = "XLMAIN"
    lpCaption = "Microsoft Excel - " & Trim(Frm_OutStemperSpecBill_Export.Text1.text) & ".XLS" ' MyExcel.xls"
    Handle = FindWindow(lpClassName$, lpCaption$)
    If Handle <> 0 Then
       MsgBox "请先关闭EXCEL文件!", vbOKOnly + vbInformation, "不能对已经打开的文件进行写操作!"
       Exit Function
    End If
    '检查EXCEL文件是否存在,如果存在则删除
    If Dir("\\HLOT-SERVER\EXCEL\" & Trim(Frm_OutStemperSpecBill_Export.Text1.text) & ".XLS") <> "" Then Kill "\\HLOT-SERVER\EXCEL\" & Trim(Frm_StemperSpecBill_Export.Text1.text) & ".XLS"
'*********************************************************

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

With Rs_Data
If .State = adStateOpen Then
.Close
End If
.ActiveConnection = Cs
.CursorLocation = adUseClient
.CursorType = adOpenStatic
.LockType = adLockReadOnly
.Source = strOpen
.Open
End With
With Rs_Data
If .RecordCount < 1 Then
MsgBox ("没有记录!")
Exit Function
End If
'记录总数
Irowcount = .RecordCount
'字段总数
Icolcount = .Fields.Count
End With

Set xlApp = CreateObject("Excel.Application")
'    Set XlApp = CreateObject("Excel.Application")
'    XlApp.Visible = True
'    Set xlBook = XlApp.Workbooks.Open(App.Path & "\rp.xls", , , , 7281322)
'   Set xlBook = XlApp.Workbooks.Open(App.Path & "\" & Text2.Text & ".xls", , , , 7281322)
''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''
Set xlBook = Nothing
Set xlsheet = Nothing
Set xlBook = xlApp.Workbooks().Add
Set xlsheet = xlBook.Worksheets("sheet1")
xlApp.Visible = False '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(2, Icolcount)).Font.Name = "华文细黑"
''设标题为黑体字
'.Range(.Cells(1, 1), .Cells(2, Icolcount)).Font.Bold = True:
''标题字体加粗
' .Range(.Cells(1, 1), .Cells(Irowcount + 2, Icolcount)).Borders.LineStyle = xlContinuous
'设表格边框样式
End With

With xlsheet
' .Cells(1, 1) = Text1.text
' .Cells(1, 2) = Text1.text
' .Range(.Cells(1, 1), .Cells(1, 1)).HorizontalAlignment = 4
' .Range(.Cells(1, 2), .Cells(1, 2)).HorizontalAlignment = 2
' .Cells(1, 3) = Text1.text
' .Cells(1, 4) = Text1.text
' .Range(.Cells(1, 3), .Cells(1, 3)).HorizontalAlignment = 4
' .Range(.Cells(1, 4), .Cells(1, 4)).HorizontalAlignment = 2
' .Cells(Icolcount, 1) = Label5.Caption
' .Cells(Icolcount, 2) = Text3.Text
' .Cells(Icolcount, 3) = Label4.Caption
' .Cells(Icolcount, 4) = Text4.Text
' .Cells(Icolcount, 5) = Label6.Caption
' .Cells(Icolcount, 6) = Text5.Text
' .Cells(Icolcount, 7) = Label7.Caption
' .Cells(Icolcount, 8) = Text6.Text
'

End With


With xlsheet.PageSetup
.LeftHeader = "" '"" & Chr(10) & "&""楷体_GB2312,常规""&10制表日期：" + Str(Date)  ' & Gsmc
'.LeftHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10部门：仓库" ' & Gsmc
.CenterHeader = "&""楷体_GB2312,常规""剩余良品粉碎情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10"
'.CenterHeader = "&""楷体_GB2312,常规""剩余良品粉碎情况表&""宋体,常规""" & Chr(10) & "&""楷体_GB2312,常规""&10日 期："
.RightHeader = "" & Chr(10) & "&""楷体_GB2312,常规""&10部门：人力资源部—仓库"
.LeftFooter = "&""楷体_GB2312,常规""&10" + Frm_StemperSpecBill_Export.Text1.text + "：" + Frm_StemperSpecBill_Export.Text1.text & "    " & Frm_StemperSpecBill_Export.Text1.text & "：" + Frm_StemperSpecBill_Export.Text1.text & "    " & Frm_StemperSpecBill_Export.Text1.text & "：" + Frm_StemperSpecBill_Export.Text1.text & "    " & Frm_StemperSpecBill_Export.Text1.text & "：" + Frm_StemperSpecBill_Export.Text1.text
'.CenterFooter = "&""楷体_GB2312,常规""&10制表日期：" + Str(Date)
.RightFooter = "&""楷体_GB2312,常规""&10第&P页 共&N页"
End With

xlApp.Application.Visible = False  ' True' False '

'  xlBook.SaveAs Text1.Text '保存EXCEL文件
    xlBook.SaveAs "\\HLOT-SERVER\EXCEL\" & Frm_OutStemperSpecBill_Export.Text1.text '保存EXCEL文件
    '***************************关闭EXCEL对象*******************
'    If Check1.Value = vbChecked Then
        xlBook.Close
        xlApp.Quit
'    End If

Set xlApp = Nothing '"交还控制给Excel
Set xlBook = Nothing
Set xlsheet = Nothing
MsgBox "数据导出成功!"
Unload Me
Exit Function
err:
   MsgBox err.Description + Chr(13) + "数据导出失败！", vbCritical
   Exit Function
End Function


Private Sub Form_Load()
On Error GoTo err
    Me.Animation1.Open App.Path & "\media\create.avi"
    Me.Animation1.Play
    Me.Timer1.Enabled = True
Exit Sub
err:
   MsgBox err.Description, vbCritical
End Sub

Private Sub Timer1_Timer()
On Error GoTo err
    Me.Timer1.Enabled = False
    Call ExporToExcel("OutStemper_SpecBillExport")
Exit Sub
err:
   MsgBox err.Description, vbCritical
End Sub