Option Explicit
Public Const FO_MOVE As Long = &H1
Public Const FO_COPY As Long = &H2
Public Const FO_DELETE As Long = &H3
Public Const FO_RENAME As Long = &H4
Public Const FOF_MULTIDESTFILES As Long = &H1
Public Const FOF_CONFIRMMOUSE As Long = &H2
Public Const FOF_SILENT As Long = &H4
Public Const FOF_RENAMEONCOLLISION As Long = &H8
Public Const FOF_NOCONFIRMATION As Long = &H10
Public Const FOF_WANTMAPPINGHANDLE As Long = &H20
Public Const FOF_CREATEPROGRESSDLG As Long = &H0
Public Const FOF_ALLOWUNDO As Long = &H40
Public Const FOF_FILESONLY As Long = &H80
Public Const FOF_SIMPLEPROGRESS As Long = &H100
Public Const FOF_NOCONFIRMMKDIR As Long = &H200
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Long
fAnyOperationsAborted As Long
hNameMappings As Long
lpszProgressTitle As String
End Type
Declare Function SHFileOperation Lib "Shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Sub Command1_Click()
Dim xlsApp As Excel.Application
Dim xlwb As Excel.Workbook
Dim wdApp As Word.Application
Dim wbzhishu As Word.Document
Dim astrData() As String
Dim fileop As SHFILEOPSTRUCT
Dim result As Long
Dim winHwnd As Long
Dim RetVal As Long
Dim intIndex As Integer
Dim intRow As Integer
Dim intCol As Integer
Dim myRange
Dim myRange1
Dim strTemp As String
Dim intFirst As Integer
Dim intSecond As Integer
If Text1.Text = "" Then
MsgBox "请选择EXCEL文件", vbExclamation
GoTo PROC_EXIT
End If
If MsgBox("请确认选择的文件里有表名为'sheet1'", vbExclamation + vbOKCancel) = vbCancel Then GoTo PROC_EXIT
If Text3.Text = 0 Then
MsgBox "请输入工资记录数", vbExclamation
GoTo PROC_EXIT
End If
If MsgBox("确认将数据转换成WORD格式", vbExclamation + vbOKCancel) = vbCancel Then GoTo PROC_EXIT
Label4.Caption = "正在准备转换数据"
Screen.MousePointer = vbHourglass
'检测word程序是否正在运行，如果是则关闭它，可以使用如下代码来实现：
winHwnd = FindWindow(vbNullString, "工资单 - Microsoft Word")
If winHwnd <> 0 Then
SendMessage winHwnd, WM_CLOSE, 0, 0
End If
'检测EXCEL程序是否正在运行，如果是则关闭它，可以使用如下代码来实现：
Dim astrFile() As String
astrFile = Split(strFileName, "\")
strTemp = astrFile(UBound(astrFile()))
astrFile = Split(strTemp, ".")
strTemp = " Microsoft Excel - " & astrFile(0) & " "
winHwnd = FindWindow(vbNullString, strTemp)
If winHwnd <> 0 Then
SendMessage winHwnd, WM_CLOSE, 0, 0
End If
On Error Resume Next
Kill App.Path & "\工资单.doc"
'On Error GoTo PROC_ERR
'对预设的格式文件进行copy
With fileop
.hwnd = Me.hwnd
.wFunc = FO_COPY
.pFrom = App.Path & "\工资单样本.doc"
.pTo = App.Path & "\工资单.doc"
.fFlags = FOF_SIMPLEPROGRESS Or FOF_FILESONLY
End With
result = SHFileOperation(fileop)
Set wdApp = CreateObject("word.Application")
Set wbzhishu = wdApp.Documents.Open(fileop.pTo)
Set xlsApp = CreateObject("Excel.Application")
Set xlwb = xlsApp.Workbooks.Open(strFileName)
'xlsApp.Sheets("sheet1").Select
ReDim astrData(0 To intCount, 1 To 27)
intIndex = 0
intRow = 1
strTemp = "A3:AA" & (intCount + 2)
Dim c
For Each c In xlsApp.Sheets("sheet1").Range(strTemp)
intIndex = intIndex + 1
astrData(intRow, intIndex) = c.Value
If intIndex Mod 27 = 0 Then
intRow = intRow + 1
intIndex = 0
End If
Next c
Set myRange = wdApp.ActiveDocument.Content
myRange.Copy
For intIndex = 1 To intCount - 1
myRange.Collapse Direction:=wdCollapseEnd
myRange.InsertBreak Type:=wdSectionBreakNextPage
myRange.Paste
Label4.Caption = "复制表格格式已完成：" & intIndex & "/" & intCount
DoEvents
Next intIndex
With wdApp.ActiveDocument
For intFirst = 1 To intCount
myRange.Find.Execute FindText:="hi", ReplaceWith:="hello", Replace:=wdReplaceAll
strTemp = "部门：" & astrData(intFirst, 27) & Space(5) & "姓名：" & astrData(intFirst, 1) & Space(5) & "月份： " & Combo1.Text
Set myRange = wdApp.ActiveDocument.Content
myRange.Find.Execute FindText:="DEPT", Forward:=True
If myRange.Find.Found = True Then
myRange.Text = strTemp
End If
With .Tables(1 + (intFirst - 1) * 3)
For intSecond = 1 To 3
.Cell(3, intSecond).Range = astrData(intFirst, intSecond)
Next intSecond
End With
With .Tables(2 + (intFirst - 1) * 3)
For intSecond = 1 To 10
.Cell(3, intSecond).Range = Format(astrData(intFirst, intSecond + 3), "#0.00")
Next intSecond
End With
With .Tables(3 + (intFirst - 1) * 3)
For intSecond = 1 To 12
.Cell(3, intSecond).Range = Format(astrData(intFirst, intSecond + 13), "#0.00")
Next intSecond
End With
Label4.Caption = "插入工资数据已完成：" & intFirst & "/" & intCount
DoEvents
Next intFirst
End With
Set myRange = wdApp.ActiveDocument.Range(Start:=wdApp.ActiveDocument.Paragraphs(1).Range.Start, _
End:=wdApp.ActiveDocument.Paragraphs(1).Range.End)
myRange.Font.Size = 15
myRange.Font.Bold = wdToggle
wdApp.Visible = True
wdApp.DisplayAlerts = wdAlertsMessageBox
Label4.Caption = ""
xlsApp.Visible = True
xlsApp.Quit
Set xlsApp = Nothing
Set xlwb = Nothing
Screen.MousePointer = vbDefault
PROC_EXIT:
Exit Sub
PROC_ERR: ' 错误处理程序。
On Error Resume Next
Screen.MousePointer = vbDefault
xlsApp.Visible = True
DoEvents
'如果在打开对话框里选择取消,则忽略错误
If Err.Number = 32755 Then GoTo PROC_EXIT
MsgBox Err.Description, vbExclamation
GoTo PROC_EXIT
End Sub
