Dim txtFile
Dim wordFile
chick() chick()
txtFile = document.getElementById("txtFile").value
wordFile = document.getElementById("wordFile").value
If Len(trim(txtFile)) = 0 Or Len(trim(wordFile)) = 0 Then
MsgBox "請選擇文件!"
Else
dowrite()
End If
end function
dowrite() dowrite()
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strAry()
Dim linCount
Dim strLine
ReDim strAry(1000)
Set TxtFile = fso.OpenTextFile(txtFile,1, False)
While Not TxtFile.AtEndOfStream
strLine = TxtFile.ReadLine
If Len(strLine) > 0 Then
strAry(linCount) = strLine
linCount = linCount + 1
End If
Wend
Set myDocApp = CreateObject("Word.Application")
myDocApp.Visible = True
myDocApp.Activate
myDocApp.Application.ScreenUpdating = False
set myDoc = myDocApp.Documents.Open(wordFile)
Set objSelection = myDocApp.Selection
For i = 0 To linCount-1
objSelection.Font.Name = "黑體"
objSelection.Font.Size = 22
objSelection.ParagraphFormat.Alignment = 1
objSelection.ParagraphFormat.LineSpacingRule = 0
objSelection.Font.Bold = true
objSelection.TypeText "檢測報告單"&vbCrLf
objSelection.Font.Size = 12
objSelection.Font.Bold = false
Set table1 = objSelection.Tables.Add(objSelection.Range, 14, 6)
Set Table1 = myDoc.Tables(i+1)
With Table1
.PreferredWidthType = 2
.PreferredWidth = 100
.Columns.PreferredWidthType = 2
With .Borders(-2)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-4)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-1)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-3)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-5)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
.Borders(-7).LineStyle = 0
.Borders(-8).LineStyle = 0
.Borders.Shadow = False
End With
With myDocApp.Options
.DefaultBorderLineStyle = 1
.DefaultBorderLineWidth = 4
.DefaultBorderColor = -16777216
End With
'合併單元格 開始
'第一行合併單元格
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第五行合併單元格
objSelection.MoveRight 1,2
objSelection.MoveDown 5,3
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第六行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第六行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第六行的第五六列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七、八、九行的第五六列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.MoveDown 5,2,1
objSelection.Cells.Merge
'第八行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第八行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第九行的第一二列合併單元格
objSelection.MoveRight 1,3
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第九行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第十行合併單元格
objSelection.MoveRight 1,3
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第十一、十二、十三、十四行合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 6, 1
objSelection.MoveDown 5,3,1
objSelection.Cells.Merge
'合併單元格 結束
'填寫內容 開始
Table1.Cell(1,1).Range.Text = "基本信息"
Table1.Cell(2,1).Range.Text = "樣品編號"
Table1.Cell(2,2).Range.Text = Mid(strAry(i),21,15)
Table1.Cell(2,3).Range.Text = "姓名"
Table1.Cell(2,4).Range.Text = ""
Table1.Cell(2,5).Range.Text = "性別"
Table1.Cell(2,6).Range.Text = ""
Table1.Cell(3,1).Range.Text = "年 齡"
Table1.Cell(3,2).Range.Text = ""
Table1.Cell(3,3).Range.Text = "病歷號"
Table1.Cell(3,4).Range.Text = ""
Table1.Cell(3,5).Range.Text = "牀位號"
Table1.Cell(3,6).Range.Text = ""
Table1.Cell(4,1).Range.Text = "送檢日期"
Table1.Cell(4,2).Range.Text = Mid(strAry(i),6,15)
Table1.Cell(4,3).Range.Text = "臨牀診斷"
Table1.Cell(4,4).Range.Text = ""
Table1.Cell(4,5).Range.Text = ""
Table1.Cell(4,6).Range.Text = ""
Table1.Cell(5,1).Range.Text = "檢測結果"
Table1.Cell(6,1).Range.Text = "指標"
Table1.Cell(6,2).Range.Text = "檢測值"
Table1.Cell(6,3).Range.Text = "陰陽性"
Table1.Cell(7,1).Range.Text = "0分鐘(T0)"
Table1.Cell(8,1).Range.Text = "20分鐘(T1)"
Table1.Cell(9,1).Range.Text = "差值"
Table1.Cell(9,2).Range.Text = Right(Left(strAry(i),5),4)
Table1.Cell(7,3).Range.Text = "陰性(<4.0)"&vbCrLf&"陽性(≥4.0)"
Table1.Cell(10,1).Range.Text = "結果評價"
objSelection.ParagraphFormat.Alignment = 3
Table1.Cell(11,1).Range.Text = ""&vbCrLf&"13C-UREA呼氣試驗Hp結果爲:"
'填寫內容 結束
objSelection.EndKey(6)
objSelection.ParagraphFormat.Alignment = 3
objSelection.TypeText "檢驗人: 檢驗日期:"&vbCrLf
If (i+1) Mod 2 = 1 Then
objSelection.TypeText ""&vbCrLf&"-------------------剪------------- 切---------------線---------------"&vbCrLf
End If
Next
myDoc.close()
myDocApp.quit()
end function
Dim wordFile
chick() chick()
txtFile = document.getElementById("txtFile").value
wordFile = document.getElementById("wordFile").value
If Len(trim(txtFile)) = 0 Or Len(trim(wordFile)) = 0 Then
MsgBox "請選擇文件!"
Else
dowrite()
End If
end function
dowrite() dowrite()
Set fso = CreateObject("Scripting.FileSystemObject")
Dim strAry()
Dim linCount
Dim strLine
ReDim strAry(1000)
Set TxtFile = fso.OpenTextFile(txtFile,1, False)
While Not TxtFile.AtEndOfStream
strLine = TxtFile.ReadLine
If Len(strLine) > 0 Then
strAry(linCount) = strLine
linCount = linCount + 1
End If
Wend
Set myDocApp = CreateObject("Word.Application")
myDocApp.Visible = True
myDocApp.Activate
myDocApp.Application.ScreenUpdating = False
set myDoc = myDocApp.Documents.Open(wordFile)
Set objSelection = myDocApp.Selection
For i = 0 To linCount-1
objSelection.Font.Name = "黑體"
objSelection.Font.Size = 22
objSelection.ParagraphFormat.Alignment = 1
objSelection.ParagraphFormat.LineSpacingRule = 0
objSelection.Font.Bold = true
objSelection.TypeText "檢測報告單"&vbCrLf
objSelection.Font.Size = 12
objSelection.Font.Bold = false
Set table1 = objSelection.Tables.Add(objSelection.Range, 14, 6)
Set Table1 = myDoc.Tables(i+1)
With Table1
.PreferredWidthType = 2
.PreferredWidth = 100
.Columns.PreferredWidthType = 2
With .Borders(-2)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-4)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-1)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-3)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
With .Borders(-5)
.LineStyle = 1
.LineWidth = 4
.Color = -16777216
End With
.Borders(-7).LineStyle = 0
.Borders(-8).LineStyle = 0
.Borders.Shadow = False
End With
With myDocApp.Options
.DefaultBorderLineStyle = 1
.DefaultBorderLineWidth = 4
.DefaultBorderColor = -16777216
End With
'合併單元格 開始
'第一行合併單元格
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第五行合併單元格
objSelection.MoveRight 1,2
objSelection.MoveDown 5,3
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第六行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第六行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第六行的第五六列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第七、八、九行的第五六列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.MoveDown 5,2,1
objSelection.Cells.Merge
'第八行的第一二列合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第八行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第九行的第一二列合併單元格
objSelection.MoveRight 1,3
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第九行的第三四列合併單元格
objSelection.MoveRight 1,1
objSelection.MoveRight 1, 2, 1
objSelection.Cells.Merge
'第十行合併單元格
objSelection.MoveRight 1,3
objSelection.MoveRight 1, 6, 1
objSelection.Cells.Merge
'第十一、十二、十三、十四行合併單元格
objSelection.MoveRight 1,2
objSelection.MoveRight 1, 6, 1
objSelection.MoveDown 5,3,1
objSelection.Cells.Merge
'合併單元格 結束
'填寫內容 開始
Table1.Cell(1,1).Range.Text = "基本信息"
Table1.Cell(2,1).Range.Text = "樣品編號"
Table1.Cell(2,2).Range.Text = Mid(strAry(i),21,15)
Table1.Cell(2,3).Range.Text = "姓名"
Table1.Cell(2,4).Range.Text = ""
Table1.Cell(2,5).Range.Text = "性別"
Table1.Cell(2,6).Range.Text = ""
Table1.Cell(3,1).Range.Text = "年 齡"
Table1.Cell(3,2).Range.Text = ""
Table1.Cell(3,3).Range.Text = "病歷號"
Table1.Cell(3,4).Range.Text = ""
Table1.Cell(3,5).Range.Text = "牀位號"
Table1.Cell(3,6).Range.Text = ""
Table1.Cell(4,1).Range.Text = "送檢日期"
Table1.Cell(4,2).Range.Text = Mid(strAry(i),6,15)
Table1.Cell(4,3).Range.Text = "臨牀診斷"
Table1.Cell(4,4).Range.Text = ""
Table1.Cell(4,5).Range.Text = ""
Table1.Cell(4,6).Range.Text = ""
Table1.Cell(5,1).Range.Text = "檢測結果"
Table1.Cell(6,1).Range.Text = "指標"
Table1.Cell(6,2).Range.Text = "檢測值"
Table1.Cell(6,3).Range.Text = "陰陽性"
Table1.Cell(7,1).Range.Text = "0分鐘(T0)"
Table1.Cell(8,1).Range.Text = "20分鐘(T1)"
Table1.Cell(9,1).Range.Text = "差值"
Table1.Cell(9,2).Range.Text = Right(Left(strAry(i),5),4)
Table1.Cell(7,3).Range.Text = "陰性(<4.0)"&vbCrLf&"陽性(≥4.0)"
Table1.Cell(10,1).Range.Text = "結果評價"
objSelection.ParagraphFormat.Alignment = 3
Table1.Cell(11,1).Range.Text = ""&vbCrLf&"13C-UREA呼氣試驗Hp結果爲:"
'填寫內容 結束
objSelection.EndKey(6)
objSelection.ParagraphFormat.Alignment = 3
objSelection.TypeText "檢驗人: 檢驗日期:"&vbCrLf
If (i+1) Mod 2 = 1 Then
objSelection.TypeText ""&vbCrLf&"-------------------剪------------- 切---------------線---------------"&vbCrLf
End If
Next
myDoc.close()
myDocApp.quit()
end function