VBS 将Txt 转成Excel，并加图片列头的处理...

wsql

浏览: 11966354 次
性别:
来自: 深圳

最近访客更多访客>>

GDGZWQZ

IT_way

qq_33632159

mhx1535

博主相关

博客

微博

相册

留言

关于我

文章分类

全部博客 (14573)

社区版块

存档分类

2013-03 ( 19)
2013-02 ( 15)
2013-01 ( 268)
更多存档...

Excel F#J#

'------------------------------------------------------------
'O2 Data File Transfer
'Get File type is txt, Change Transport to file type is xls
'
'Create Date: 2008-11-11
'Author: Wei_Zhu
'Chage Log:
'Last Chage Date:
'-------------------------------------------------------------

Const ForReading = 1, ForWriting = 2, ForAppending = 8
Const TristateUseDefault = -2, TristateTrue = -1, TristateFalse = 0

set ws=createobject("wscript.shell")
set fso=createobject("scripting.filesystemobject")
set folder=fso.getfolder(ws.currentdirectory&"\From")

set files=folder.files
for each file in files
ReadFile file.name,folder
MoveFile file.name,folder
next

'-------Read Data File-----

Sub ReadFile(lstg_file,folder)
Dim fso,f
dim lstg_from_file
dim lstg_f
dim lstg_f_txt
dim lstg_f_line
lstg_f_ling = 0
lstg_from_file=folder&"\"&lstg_file
Set fso = CreateObject("Scripting.FileSystemObject")
Set f = fso.GetFile(lstg_from_file)
Set lstg_f = f.OpenAsTextStream(ForReading, TristateUseDefault)
While Not lstg_f.atEndOfLine
lstg_f_txt=lstg_f.readall
lstg_f_line=lstg_f.line 'Get File Line Count
msgbox lstg_f_line
lstg_f_txt=Replace(lstg_f_txt,"|",Chr(9))
WEnd
TransferFile lstg_f_txt,folder,lstg_file
End Sub

'-------Transfer Data File-----
Sub TransferFile(lstg_f_txt,folder,lstg_file)
dim lstg_to_f
Dim l_f
Dim fso, f
Set fso = CreateObject("Scripting.FileSystemObject")

lstg_to_f = folder
lstg_to_f = replace(lstg_to_f,"From","To")
lstg_file=UCase(lstg_file)
'---Get Report Type---

if instr(lstg_file,"ATWIP")=1 then
'msgbox "1"
l_f = "1"
end if
if instr(lstg_file,"WAO")=1 then
'msgbox "2"
l_f = "2"
end if
if instr(lstg_file,"WSC")=1 then
'msgbox "3"
l_f = "3"
end if
if instr(lstg_file,"SFAS")=1 then
'msgbox "4"
l_f = "4"
end if
lstg_file = replace(lstg_file,"TXT","xls")
lstg_to_f = lstg_to_f&"\"&lstg_file

Set f = fso.OpenTextFile(lstg_to_f, ForWriting, True)
f.Write lstg_f_txt
f.Close
'msgbox lstg_to_f
'msgbox lstg_f_txt

Set objExcel = CreateObject("Excel.Application")
'Set objWorkbook=objExcel.Workbooks.Add() 'This is add new
Set objWorkbook=objExcel.Workbooks.Open(lstg_to_f)

Select Case l_f
Case "1"
Set objRange =objExcel.Range("A1","A1")
objRange.EntireRow.Insert
objRange.EntireRow.Insert
'---Set Title---
Set objRange = objExcel.Range("A1","J1")
objRange.Font.Size = 14
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).value="Auto-WIP(SHOP FLOOR)"
objrange.Interior.ColorIndex = 15'Set BackColor
objrange.MergeCells = true
'objrange.HorizontalAlignment = -4108
objrange.HorizontalAlignment = 3
objrange.Merge

'---Set Header---
'JOBPART#LOT#DEPARTMENT_CODEQUEUE_QTYRUNNING(WIP)_QTYHOLD_QTYMOVE_PASS_QTYMOVE_FAIL_QTYWAFE_PCS

Set objRange = objExcel.Range("A2","J2")
objRange.Font.Size = 10
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).Value="JOB"
objrange.Cells(2).Value="PART#"
objrange.Cells(3).Value="LOT#"
objrange.Cells(4).Value="DEPARTMENT_CODE"
objrange.Cells(5).Value="QUEUE_QTY"
objrange.Cells(6).Value="RUNNING(WIP)_QTY"
objrange.Cells(7).Value="HOLD_QTY"
objrange.Cells(8).Value="MOVE_PASS_QTY"
objrange.Cells(9).Value="MOVE_FAIL_QTY"
objrange.Cells(10).Value="WAFE_PCS"
objrange.Interior.ColorIndex = 34'Set BackColor
objRange.Borders.LineStyle = 1
Set objRange = objExcel.ActiveCell.EntireColumn

objRange.AutoFit()
'----Fill Data----

'----Auto Fill The Column Width---
Set objcol = objExcel.Columns("A:J").EntireColumn
objcol.AutoFit
Case "2"
Set objRange =objExcel.Range("A1","A1")
objRange.EntireRow.Insert
objRange.EntireRow.Insert
'---Set Title---
Set objRange = objExcel.Range("A1","F1")
objRange.Font.Size = 14
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).value="O2M_AUTOWIP_FTP_TEMP"
objrange.Interior.ColorIndex = 15'Set BackColor
objrange.MergeCells = true
'objrange.HorizontalAlignment = -4108
objrange.HorizontalAlignment = 3
objrange.Merge

'---Set Header---
'JOBPRODUCTPROCESSOUT_QTYDATE_CODEREMARK

Set objRange = objExcel.Range("A2","F2")
objRange.Font.Size = 10
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).Value="JOB"
objrange.Cells(2).Value="PRODUCT"
objrange.Cells(3).Value="PROCESS"
objrange.Cells(4).Value="OUT_QTY"
objrange.Cells(5).Value="DATE_CODE"
objrange.Cells(6).Value="REMARK"
objrange.Interior.ColorIndex = 34'Set BackColor
objRange.Borders.LineStyle = 1
Set objRange = objExcel.ActiveCell.EntireColumn

objRange.AutoFit()
'----Fill Data----

'----Auto Fill The Column Width---
Set objcol = objExcel.Columns("A:J").EntireColumn
objcol.AutoFit
Case "3"
Set objRange =objExcel.Range("A1","A1")
objRange.EntireRow.Insert
objRange.EntireRow.Insert
'---Set Title---
Set objRange = objExcel.Range("A1","F1")
objRange.Font.Size = 14
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).value="O2MO WIP SCHEDULE CONFIRMED"
objrange.Interior.ColorIndex = 15'Set BackColor
objrange.MergeCells = true
'objrange.HorizontalAlignment = -4108
objrange.HorizontalAlignment = 3
objrange.Merge

'---Set Header---
'PRODUCT JOBPROCESSJOB_QTYLOT_NUMBERDATE_CONFIRMED
Set objRange = objExcel.Range("A2","F2")
objRange.Font.Size = 10
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objrange.Cells(1).Value="PRODUCT"
objrange.Cells(2).Value="JOB"
objrange.Cells(3).Value="PROCESS"
objrange.Cells(4).Value="JOB_QTY"
objrange.Cells(5).Value="LOT_NUMBER"
objrange.Cells(6).Value="DATE_CONFIRMED"
objrange.Interior.ColorIndex = 34'Set BackColor
objRange.Borders.LineStyle = 1
Set objRange = objExcel.ActiveCell.EntireColumn

objRange.AutoFit()

'----Fill Data----

'----Auto Fill The Column Width---
Set objcol = objExcel.Columns("A:F").EntireColumn
objcol.AutoFit
Case "4"
Set objRange =objExcel.Range("A1","A1")
'---Insert 6 balnk row---
objRange.EntireRow.Insert
objRange.EntireRow.Insert
objRange.EntireRow.Insert
objRange.EntireRow.Insert
objRange.EntireRow.Insert
objRange.EntireRow.Insert

'---Insert Picedure--
objExcel.ActiveSheet.Pictures.Insert(ws.currentdirectory&"\logo\O2.png").select

Set objRange =objExcel.Range("G3","G3")
objRange.Font.Size = 16
objrange.Font.Bold = True
objrange.Font.Name = "Arial"
objRange.Value="Shop floor move transactions"

Set objRange =objExcel.Range("A5","B5")
objRange.Font.Size = 9
objrange.Font.Bold = False
objrange.Font.Name = "Times New Roman"
objRange.Cells(1).Value="Organization Code:"
objRange.Cells(2).Value="OMI"

Set objRange =objExcel.Range("I5","I6")
objRange.Font.Size = 10
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objRange.Cells(1).Value="SF NO"
objRange.Cells(2).Value="PL NO"

Set objRange =objExcel.Range("J5","J6")
objRange.Font.Size = 10
objrange.Font.Bold = False
objrange.Font.Name = "Times New Roman"
objRange.Cells(1).Value="ASXXXXXXX"
objExcel.ActiveSheet.Range("F7","F7").Cut
objRange.Cells(2).Select
objExcel.ActiveSheet.Paste

Set objRange=objExcel.Range("A7","A7")
objRange.Select
objRange.EntireRow.Delete

Set objRange =objExcel.Range("A7","K7")
objRange.Font.Size = 12
objrange.Font.Bold = True
objrange.Font.Name = "Times New Roman"
objRange.Borders.LineStyle = 1

Set objRange =objExcel.Range("A8","K8")
objRange.Font.Size = 12
objrange.Font.Bold = False
objrange.Font.Name = "Times New Roman"
objRange.Borders.LineStyle = 1

Set objcol = objExcel.Columns("A:K").EntireColumn
objcol.AutoFit
End Select

REM Set objRange = objExcel.Range("A1","D1")
REM objRange.Font.Size = 11
REM objrange.Font.Bold = True
REM objRange.Borders.LineStyle = 1 ' 1~13 have 13line style

REM Set objRange = objExcel.ActiveCell.EntireColumn
REM objRange.AutoFit()

objExcel.DisplayAlerts = False 'Close the Alert
'objExcel.ActiveWorkBook.Saveas lstg_to_f,-4143
'msgbox lstg_to_f
objExcel.ActiveWorkBook.Saveas lstg_to_f,-4143
objExcel.DisplayAlerts = False ''Close the Save Alert
objExcel.ActiveWorkbook.Close
objExcel.DisplayAlerts = False
objExcel.Application.Quit

End Sub

'-------Move File For Transfer Bakup Source File-----
Sub MoveFile(lstg_file,bak_folder)
Dim fso
dim lstg_from_file
dim lstg_bak_folder
dim lstg_log_folder
dim log_msg
lstg_from_file=bak_folder&"\"&lstg_file
lstg_bak_folder=replace(bak_folder,"From","Bak")
lstg_log_folder=replace(bak_folder,"From","Log")
' Set f = fso.GetFolder(lstg_bak_folder)
set fso = CreateObject("Scripting.FileSystemObject")

lstg_bak_folder_1=lstg_bak_folder&"\"
If fso.FileExists(lstg_bak_folder_1&"\"&lstg_file) Then
'msgBox lstg_file&" exists"
log_msg =Date&" "&Time &" Transfer File [ "& lstg_file& " ] is exists !"
LogFile lstg_log_folder&"\"&Date&".log",log_msg
else
fso.MoveFile lstg_from_file,lstg_bak_folder_1
log_msg=Date&" "&Time &" Move File [ "& lstg_file& " ] is Success !"
LogFile lstg_log_folder&"\"&Date&".log",log_msg
end if
End Sub

'-------File Operation Log-----
Sub LogFile(lstg_file,log_msg)
Dim fso,f, LogFile
Set fso = CreateObject("Scripting.FileSystemObject")

If fso.FileExists(lstg_file) Then
Set f = fso.GetFile(lstg_file)
Set LogFile = f.OpenAsTextStream(ForAppending, TristateUseDefault)
LogFile.WriteLine log_msg
LogFile.Close
else
Set LogFile = fso.CreateTextFile(lstg_file, True)
LogFile.WriteLine log_msg
LogFile.Close
end if
End Sub

---Result---