'------------------------------------------------------------------+
' Module specification
'------------------------------------------------------------------+
'
' Module Name : ExpWStoQL
'
' Copyright : Yokogawa SCE, 2004
'
' Author : Jan Worst
'
' Description : Export Worksheet to Quickload file
'
'
'------------------------------------------------------------------+
' Changes ....
'------------------------------------------------------------------+
' Who When Change What
'------------------------------------------------------------------+
' WST Jun-04 exxxx FAST/TOOLS to Excel demo
' WST Oct-05 Add comment column (starting with "#")
'------------------------------------------------------------------+
Option Explicit
Dim qldws As New qldWorkSheet
Dim myWS As New Excel.Worksheet
Dim wsAbs As wsAbstract
Dim ColInstall As Integer
Dim ColUnit As Integer
Dim ColTag As Integer
Dim ColSub As Integer
Dim ColGroupName As Integer
Dim ComposedKey As Boolean ' Indicates NAME field missing
Dim colQldFields As Collection
Dim ColSelected(256) As Boolean ' Shows if column must be exported
Dim wsM As WsMacros
Public Sub ExpWStoQL(ws As Excel.Worksheet, _
qlFile As String, _
Append As Boolean, _
SelectedRowsOnly As Boolean, _
SelectedColumnsOnly As Boolean, _
WriteDummyLines As Boolean)
Dim Row As Long
Dim i As Long
Dim Column As Integer
Application.ScreenUpdating = False
qldws.Initialize ws
Set myWS = ws
Set wsM = New WsMacros
Set wsAbs = New wsAbstract
wsAbs.Initialize ws
'----------------------------------------------------------
' Open Quickload file
'----------------------------------------------------------
If Append Then
Open qlFile For Append As #1
Else
Open qlFile For Output As #1
End If
On Error GoTo ExportError
Print #1, "!-----------------------------------------------------------------------"
Print #1, "! Quickload file : " & qlFile
Print #1, "! From workbook : " & ActiveWorkbook.FullName
Print #1, "! Sheet : " & ActiveSheet.Name
Print #1, "! Generated : " & FormatDateTime(Now, vbLongDate) & " " & _
FormatDateTime(Now, vbLongTime)
Print #1, "! By : " & Environ("username") & "@" & Environ("computername")
Print #1, "!-----------------------------------------------------------------------"
Print #1, ""
'----------------------------------------------------------
' Write text "@FIELDS"
'----------------------------------------------------------
Print #1, "@FIELDS"
'----------------------------------------------------------
' Check if key (NAME) field must bo composed from
' fields INSTALL, UNIT, TAG, SUB
'----------------------------------------------------------
GetQuickloadFields SelectedColumnsOnly
'----------------------------------------------------------
' Write Recordset Fields
'----------------------------------------------------------
Dim FirstColumnWritten As Boolean
For i = 1 To colQldFields.count
If Left$(colQldFields.Item(i), 1) <> "#" Then ' not a comment column
If FirstColumnWritten = False Then
FirstColumnWritten = True
Else
Print #1, ", ";
End If
PrintHeaderMacro colQldFields.Item(i), qldws.RowDataHeader
End If
Next i
'----------------------------------------------------------
' Write text "@<dataset name>"
'----------------------------------------------------------
Print #1, ""
Print #1, "@" & qldws.DatasetName
'----------------------------------------------------------
' Write all records
' (do not write rows that are hidden by the "Excel Autofilter"
'----------------------------------------------------------
For Row = qldws.RowDataFirst To qldws.RowDataLast
If Not SelectedRowsOnly Or wsAbs.RowSelected(Row) Then
OneRow Row, SelectedColumnsOnly
ElseIf WriteDummyLines Then
Print #1, " "
End If
Next Row
'----------------------------------------------------------
' Close Quickload file
'----------------------------------------------------------
Print #1, ""
Close #1
Set qldws = Nothing
Set wsM = Nothing
Application.ScreenUpdating = True
Set wsAbs = Nothing
Exit Sub
ExportError:
Close #1
Application.ScreenUpdating = True
Set wsM = Nothing
Set qldws = Nothing
Set wsAbs = Nothing
' propagate error
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Sub
'----------------------------------------------------------
' Write one row
'----------------------------------------------------------
Private Sub OneRow(Row As Long, SelectedColumnsOnly As Boolean)
Dim FirstColumnWritten As Boolean
Dim Column As Integer
Dim ws As Worksheet
Set ws = qldws.Worksheet
FirstColumnWritten = False
'-----------------------------------------
' Write composed key field
'-----------------------------------------
If ComposedKey Then
PrintFieldMacro "", qldws.getKeyValue(Row), Row
FirstColumnWritten = True
End If
'-----------------------------------------
' Write composed key field
'-----------------------------------------
For Column = 1 To qldws.ColumnCount
' Debug.Print Column, ws.Cells(qldws.RowDataHeader, Column), ws.Cells(Row, Column), Row
If Left$(ws.Cells(qldws.RowDataHeader, Column), 1) <> "#" Then ' not a comment column
' If Not SelectedColumnsOnly Or _
' (SelectedColumnsOnly And _
' Not Intersect(Selection, myWs.Cells(qldws.RowDataHeader, Column)) Is Nothing) Then
If ColSelected(Column) Then
If (Not ComposedKey Or ( _
ComposedKey And _
qldws.IsSplitNameField(ws.Cells(qldws.RowDataHeader, Column)) = False And _
UCase$(ws.Cells(qldws.RowDataHeader, Column)) <> "NAME")) Then
If FirstColumnWritten = False Then
FirstColumnWritten = True
Else
Print #1, ", ";
End If
PrintFieldMacro ws.Cells(qldws.RowDataHeader, Column), ws.Cells(Row, Column), Row
End If
End If
End If
Next Column
Print #1, ""
End Sub
'----------------------------------------------------------
' Evaluate Header macro
'----------------------------------------------------------
Private Sub PrintHeaderMacro(ByVal CellContents As String, Row As Long)
CellContents = Trim$(CellContents)
If Left$(CellContents, 1) = "$" Then
Dim i As Integer
On Error GoTo HeaderMacroNotFound
With wsM.HeaderMacro(CellContents)
For i = 1 To .FieldCount
Print #1, .Field(i);
If i <> .FieldCount Then
Print #1, ", ";
End If
Next i
End With
Else
If CellContents = "<none>" Then CellContents = ""
Print #1, CellContents;
End If
Exit Sub
HeaderMacroNotFound:
On Error GoTo ItemNameMacroNotFound
Print #1, wsM.ItemNameMacro(CellContents).Field;
Exit Sub
ItemNameMacroNotFound:
' Throw error
Err.Raise Err.Number, Err.Source, _
Err.Description & vbCrLf & vbCrLf & "Cannot evaluate macro" & CellContents, _
Err.HelpFile, Err.HelpContext
End Sub
'----------------------------------------------------------
' Evaluate Field macro
'----------------------------------------------------------
Private Sub PrintFieldMacro(HeaderMacroName As String, ByVal CellContents As String, Row As Long)
CellContents = Trim$(CellContents)
If Left$(CellContents, 1) = "$" Then
Dim i As Integer
On Error GoTo HeaderMacroNotFound
With wsM.HeaderMacro(HeaderMacroName).FieldMacro(CellContents)
For i = 1 To .FieldCount
Print #1, """" & .Field(i) & """";
If i <> .FieldCount Then
Print #1, ", ";
End If
Next i
End With
Else
If CellContents = "<none>" Then CellContents = ""
Print #1, """" & CellContents & """";
End If
Exit Sub
HeaderMacroNotFound:
On Error GoTo ItemNameMacroNotFound
Print #1, """" & CellContents & """";
Exit Sub
ItemNameMacroNotFound:
' Throw error
Err.Raise Err.Number, Err.Source, _
Err.Description & vbCrLf & vbCrLf & "Cannot evaluate macro" & CellContents, _
Err.HelpFile, Err.HelpContext
End Sub
'--------------------------------------------------------------------
' Get quickload field names
' normally they correspond with the Excel header fields, exceptions are
' made for "composed keys" for UNIT_DF, ITEM_DEF, etc.
'
' Outputs: ComposedKey - indicates that key is composed
' colQldFields - collection of fields written to Quickload file
'
'--------------------------------------------------------------------
Private Sub GetQuickloadFields(SelectedColumnsOnly As Boolean)
Set colQldFields = New Collection
ComposedKey = True ' assume True
Dim col As Long
'----------------------------------------------------------
' Check if key (NAME) field must bo composed from
' fields INSTALL, UNIT, TAG, SUB
'----------------------------------------------------------
ComposedKey = qldws.hasSplitName
ColInstall = qldws.ColFieldName("INSTALL")
ColUnit = qldws.ColFieldName("UNIT")
ColTag = qldws.ColFieldName("TAG")
ColSub = qldws.ColFieldName("SUB")
ColGroupName = qldws.ColFieldName("GROUP_NAME")
'----------------------------------------------------------
' Fill Fields collection
'----------------------------------------------------------
If ComposedKey Then
colQldFields.Add "NAME"
End If
Dim FieldContents As String
Dim R As Range
For col = 1 To qldws.ColumnCount
' Find out about selected columns
FieldContents = ""
ColSelected(col) = True
If SelectedColumnsOnly Then
Set R = Intersect(Selection, myWS.Cells(qldws.RowDataHeader, col))
If R Is Nothing Then
FieldContents = "#" ' fake commment column
ColSelected(col) = False
End If
End If
FieldContents = FieldContents & UCase$(qldws.Worksheet.Cells(qldws.RowDataHeader, col))
If ComposedKey Then
If col <> ColInstall And _
col <> ColUnit And _
col <> ColTag And _
col <> ColSub And _
col <> ColGroupName Then
colQldFields.Add FieldContents
End If
Else
colQldFields.Add FieldContents
End If
Next col
End Sub
'---------------------------------------
' Read Shift-JIS and Write UTF-8N
'---------------------------------------
Public Sub WriteUTF8N(strFilename As String)
Dim objReadStream As Object
Dim objWriteStream As Object
Dim bytData() As Byte
Const adTypeText = 2
Const adTypeBinary = 1
Const adReadLine = -2
Const adWriteLine = 1
Const adCRLF = -1
Const adSaveCreateOverWrite = 2
Set objReadStream = CreateObject("ADODB.Stream")
Set objWriteStream = CreateObject("ADODB.Stream")
With objReadStream
.Open
.Type = adTypeText
.Charset = "GB2312"
.LineSeparator = adCRLF
.LoadFromFile strFilename
End With
With objWriteStream
.Open
.Type = adTypeText
.Charset = "UTF-8"
.LineSeparator = adCRLF
End With
Do Until objReadStream.EOS
objWriteStream.WriteText objReadStream.ReadText(adReadLine), adWriteLine
Loop
objReadStream.Close
With objWriteStream
.Position = 0
.Type = adTypeBinary
.Position = 3
bytData = .Read
.Close
.Open
.Position = 0
.Type = adTypeBinary
.Write bytData
.SaveToFile strFilename, adSaveCreateOverWrite
' .SaveToFile strFilename & ".txt", adSaveCreateOverWrite
.Close
End With
End Sub
用VS编写C#程序
最新发布
扫一扫
7066
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
