📄 frmopen.frm
字号:
End
Begin VB.Label lbl2
Caption = "2. 比较前请将文件中所有的 , 字符替换为 _*_ 字符 !!!!!!!!"
ForeColor = &H000000FF&
Height = 225
Left = 210
TabIndex = 11
Top = 2130
Width = 8115
End
Begin VB.Label lbl1
Caption = "1. 文件中的第一行只能是数字与字母, 不能有非法字符, 比如: + / \ * ... "
ForeColor = &H000000FF&
Height = 225
Left = 210
TabIndex = 10
Top = 1860
Width = 8115
End
Begin VB.Label Label4
Caption = "处理进度:"
Height = 225
Left = 180
TabIndex = 7
Top = 3270
Width = 1005
End
Begin VB.Image Image2
Height = 240
Left = 8100
Picture = "frmOpen.frx":35B6
Top = 480
Width = 240
End
Begin VB.Image Image1
Height = 240
Left = 8100
Picture = "frmOpen.frx":3700
Top = 3240
Width = 240
End
Begin VB.Label Label3
Caption = "Csv file2:"
BeginProperty Font
Name = "Verdana"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 240
TabIndex = 2
Top = 1200
Width = 3675
End
Begin VB.Label Label2
Caption = "Csv file1:"
BeginProperty Font
Name = "Verdana"
Size = 9
Charset = 0
Weight = 700
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 225
Left = 210
TabIndex = 1
Top = 510
Width = 3765
End
Begin VB.Menu mnuMenu
Caption = "myMenu"
Visible = 0 'False
Begin VB.Menu mnuStart
Caption = "&Start"
End
Begin VB.Menu mnuckXls
Caption = "ck Xls ?"
End
Begin VB.Menu mnuline9293
Caption = "-"
End
Begin VB.Menu mnuQuit
Caption = "&Quit"
End
End
End
Attribute VB_Name = "frmOpen"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim sSheetName As String
Dim sImportFile As String
Dim sImportFile2 As String
Dim cn As New ADODB.Connection
Dim iSec As Integer
Private Sub cmdOpen1_Click()
dlg.ShowOpen
txtf1.Text = dlg.FileName
If txtf1 = "" Then txtf2.Text = txtf1.Text
End Sub
Private Sub cmdOpen2_Click()
dlg.ShowOpen
txtf2.Text = dlg.FileName
End Sub
Private Function GetFldName(ByVal s1 As String) As String
If Trim(s1) = "" Then
MsgBox "发现第一行的列名称有空, 请将它们删除掉, 然后再试一次.", vbExclamation, ErrMsg
GetFldName = "" '''"C" & Int(Rnd(99) * 100) & Int(Rnd(999) * 1000)
Else
GetFldName = s1
End If
End Function
Private Sub doImportCheckTwoXls(ByVal iCheckType As Integer)
On Error GoTo ErrMsg:
'Label7.Caption = "Equal Content Found:"
'Label8.Caption = "NOT Equal Found:"
sb.Panels(1).Text = "Executing..."
timExe.Enabled = True
'lstFound.Clear
'lstNot.Clear
'lstMsg.Clear
'lblFound = "0"
'lblNot = "0"
'lblNOT_PT = "0"
'lblMsg = "0"
iSec = 0
'lblRepeat = "Repeat(0)"
sImportFile = Trim(txtf1)
sImportFile2 = Trim(txtf2)
If cn.State = 1 Then cn.Close
cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\CheckTwoFile.mdb;Persist Security Info=False"
cn.Open
Dim cn0 As New ADODB.Connection
Dim rs As New ADODB.Recordset
Dim Obj As New Scripting.FileSystemObject
Dim fs As TextStream
If iCheckType = 1 Then ''' Xls
cn0.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Excel Files;Initial Catalog=" '' & sImportFile
cn0.CursorLocation = adUseClient
cn0.CommandTimeout = 0
cn0.Open
End If
Dim i As Integer
Dim iRc As Integer
Dim sSQL As String
Dim sTblName As String
Dim j As Integer
Dim r As Long
Dim f As New frmCheckXls
Screen.MousePointer = vbHourglass
Dim aa
Dim ff
Dim vv
Dim strValue, strckValue As String
Dim RR(2) As Long
Dim bb(2) As String
Dim u As Integer
Dim CC()
ReDim CC(2)
Dim FLD()
ReDim FLD(2)
Dim ickSAME As Integer
Dim ickGetTWO As Integer
Dim sOldSheetName As String
sOldSheetName = "Sheet1" '''sSheetName
pb.Value = 1
pb.Min = 1
pb.Max = 3
Dim s As String
For i = 1 To 2
If iCheckType = 1 Then ''' EXCEL
If rs.State = 1 Then rs.Close ''' can't seach by Excel ... because can save some result flag!!!
If i = 2 Then sSheetName = Mid(sSheetName, 1, Len(sSheetName) - 1) & i
sSQL = "Select * from [" & sSheetName & "$]"
rs.Open sSQL, cn0, adOpenKeyset, adLockReadOnly
iRc = rs.RecordCount
If iRc <= 0 Then
Screen.MousePointer = vbDefault
MsgBox "Sorry, No one Record, Please try to do again!", vbExclamation, ErrMsg
rs.Close
cn0.Close
Set cn0 = Nothing
Exit Sub
End If
For j = 0 To rs.Fields.Count - 1
If i = 1 Then
f.lst.AddItem Trim(rs(j).Name)
Else
f.lst2.AddItem Trim(rs(j).Name)
End If
Next
Else ''' checkType
If i = 1 Then ''' csv1 / csv2
Set fs = Obj.OpenTextFile(sImportFile, ForReading)
Else
Set fs = Obj.OpenTextFile(sImportFile2, ForReading)
End If
bb(i) = Trim(fs.ReadLine)
aa = Split(bb(i), ",")
RR(i) = 0
While Not fs.AtEndOfStream
fs.ReadLine
RR(i) = RR(i) + 1
Wend
If RR(i) <= 1 Then ''' the first line is column
Screen.MousePointer = vbDefault
MsgBox "Sorry, No one Record, Please try to do again!", vbExclamation, ErrMsg
fs.Close
Exit Sub
End If
For j = 0 To UBound(aa)
If i = 1 Then
f.lst.AddItem GetFldName(Trim(aa(j)))
Else
f.lst2.AddItem GetFldName(Trim(aa(j)))
End If
Next
fs.Close
End If ''' CheckType Xls/Csv
pb.Value = pb.Value + 1
If i = 2 Then
Screen.MousePointer = vbDefault
f.Show vbModal
If f.strColName = "" Or f.strColName2 = "" Then Exit Sub
CC(1) = f.strColName
CC(2) = f.strColName2
ickSAME = f.ickSAME
ickGetTWO = f.ickGetTWO
Set f = Nothing
DoEvents
Screen.MousePointer = vbHourglass
End If
'FF(i) = strColName
Next
sSheetName = sOldSheetName
For i = 1 To 2
r = 0
If iCheckType = 1 Then
If rs.State = 1 Then rs.Close ''' can't seach by Excel ... because can save some result flag!!!
If i = 2 Then sSheetName = Mid(sSheetName, 1, Len(sSheetName) - 1) & i
sSQL = "Select * from [" & sSheetName & "$]"
rs.Open sSQL, cn0, adOpenKeyset, adLockReadOnly
iRc = rs.RecordCount
Else
If i = 1 Then ''' csv1 / csv2
Set fs = Obj.OpenTextFile(sImportFile, ForReading)
Else
Set fs = Obj.OpenTextFile(sImportFile2, ForReading)
End If
iRc = RR(i)
End If
pb.Value = 1
pb.Max = iRc + 1
pb.Min = 1
sTblName = "CheckXls" & i
sb.Panels(2).Text = "Creating table " & sTblName & "..."
cnExecuteSQL ("Drop Table " & sTblName)
sSQL = ""
If iCheckType = 1 Then
For j = 0 To rs.Fields.Count - 1
sSQL = sSQL & "[" & rs(j).Name & "] VarChar(64),"
Next
Else
ff = Split(bb(i), ",")
For j = 0 To UBound(ff)
sSQL = sSQL & "[" & GetFldName(Trim(ff(j))) & "] VarChar(64),"
Next
End If
sSQL = "Create Table " & sTblName & " (LineID Int," & sSQL & "ckFlag Varchar(1),ckCol Varchar(254))"
cnExecuteSQL (sSQL)
sb.Panels(2).Text = "Creating index..."
cnExecuteSQL ("Create Index Idx_" & j & " On " & sTblName & " (ckCol)")
cnExecuteSQL ("Create Index Idx_ckColFlag" & j & " On " & sTblName & " (ckCol,ckFlag)")
'cnExecuteSQL ("Create Index Idx_" & j & " On " & sTblName & " (" & strColName & ")")
'For j = 0 To UBound(aa)
'cnExecuteSQL ("Create Index Idx_" & j & j & " On " & sTblName & " (" & aa(j) & ")")
'Next
''' all one is 74 '
''' none = 74 '
''' xxx + one = 31
''' one + xxx = 31
''' xxx = 31
aa = Split(CC(i), ",")
'''
''' 2004/06/23 change the origin colname.!
'''
'FLD(i) = CC(i)
FLD(i) = ""
If iCheckType = 1 Then
For j = 0 To rs.Fields.Count - 1 ''' change column name again
s = "[" & Trim(rs(j).Name) & "]"
'If InStr(1, CC(i), s) = 0 Then
'FLD(i) = FLD(i) & "," & s
'End If
FLD(i) = FLD(i) & s & ","
Next
Else
ff = Split(bb(i), ",")
For j = 0 To UBound(ff) ''' change column name again
s = "[" & GetFldName(Trim(ff(j))) & "]"
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -