[求助]搞了一晚上了。。。实在搞不出来了，我只是想做个txt合并的工具啊 - VB6论坛

问题点数：0 回复次数：0

[求助]搞了一晚上了。。。实在搞不出来了，我只是想做个txt合并的工具啊

下面是下下来的原码,我照着把控件做了，源码放上去结果还是运行不起来:(
查找目录的按钮按上去出不来浏览窗.后来我直接把路径写在动作里,结果还是不处理。。
请各位的老师帮帮我吧!!!不盛感激啊!!!!

这个是用来，把一个文件夹下面的子文件夹中txt合成一个txt用的!!!!!!!合成后的txt向上存一级,或加前辍都行

搞了一晚上了。。。实在搞不出来了。。对了，我装的是vb6

--------------------------------------------------------------------------------------
控件　　　　名称　　　　　　Caption　　　Index　　用途
--------------------------------------------------------------------------------------
文本框1　　SourcePathBox　　　　　　　　　　　　　输入源文件所在子文件夹的上一级目录　
文本框2　　SavePathBox　　　　　　　　　　　　　　输入保存合并后文件的文件夹目录
进度条1　　ProgressBar1　　　　　　　　　　　　　显示子文件夹的处理进度
进度条2　　ProgressBar2　　　　　　　　　　　　　显示文本合并的进度
按纽1　　　CmdScan　　　　　浏览　　　　0　　　　供 SourcePathBox 查找目录
按纽2　　　CmdScan　　　　　浏览　　　　1　　　　供 SavePathBox 查找目录
按纽3　　　CmdUniteText　　开始合并　　　　　　　执行文本合并
--------------------------------------------------------------------------------------

代码如下：

Option Explicit

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
(lpBrowseInfo As BrowseInfo) As Long

Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, _
ByVal lpBuffer As String) As Long

Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)

Private Type BrowseInfo
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Dim fs, fo

Private Sub Form_Load()
Set fs = CreateObject("Scripting.FileSystemObject")
End Sub

Private Sub Form_Unload(Cancel As Integer)
Set fs = Nothing
Set fo = Nothing
Unload Me
End
End Sub

Private Sub SourcePathBox_GotFocus()
SourcePathBox.SelStart = 0: SourcePathBox.SelLength = Len(SourcePathBox)
End Sub

Private Sub SavePathBox_GotFocus()
SavePathBox.SelStart = 0: SavePathBox.SelLength = Len(SavePathBox)
End Sub

Sub CmdScan_Click(Index As Integer)
Dim jPath As String '文件夹路径
Dim lID As Long '文件夹列表对话框句柄
Dim tBrowseInfo As BrowseInfo
With tBrowseInfo
.hOwner = Me.hWnd
.lpszTitle = "请选择" & IIf(Index = 0, "子文件夹的上一级文件夹", "保存文件夹")
.ulFlags = 3
'.lpfnCallback = MyAddressOf(AddressOf BrowseForFoldersProc)
End With
lID = SHBrowseForFolder(tBrowseInfo) '显示文件夹对话框，返回其句柄
If lID Then
jPath = Space(300)
SHGetPathFromIDList lID, jPath '获取文件夹路径
CoTaskMemFree lID '回收系统资源
jPath = Left(jPath, InStr(jPath, vbNullChar) - 1)
If Right(jPath, 1) <> "\" Then jPath = jPath & "\"
If Index = 0 Then SourcePathBox = jPath
If Index = 1 Then SavePathBox = jPath
End If
End Sub

Private Sub CmdUniteText_Click()
On Error GoTo 100
Dim bPath As String '保存文件夹名，如为空，表示保存在原子文件夹
Dim jName As String '子文件夹名称
Dim fName As String '文件名
Dim ST As String '合并后的文件内容
Dim Stzk As String '包含全部子文件夹名的字符串
Dim Jk As Integer '子文件夹数量
Dim Fk As Integer '文件数量
Dim z As String
Dim Ji As Integer, Fi As Integer, L As Integer, J As Integer, i As Integer
If SourcePathBox = "" Then Exit Sub
Screen.MousePointer = 11
Stzk = "": jName = Dir(SourcePathBox, 16) '找寻第一项
Do While jName <> "" '开始循环
If jName <> "." And jName <> ".." Then '跳过当前的目录及上层目录
If InStr(jName, ".") = 0 And (GetAttr(SourcePathBox & jName) And 16) = 16 Then '使用位比较来确定jName是否子文件夹
Jk = Jk + 1: Stzk = Stzk & jName & "," '如果是一个子文件夹，将其名称累加进 Stzk
End If
End If
jName = Dir '查找下一个子文件夹
Loop
ProgressBar1.Max = Jk: ProgressBar1.Value = 0

For Ji = 1 To Jk
ProgressBar1.Value = Ji
J = InStr(Stzk, ","): jName = Left(Stzk, J - 1): Stzk = Mid(Stzk, J + 1)
bPath = IIf(SavePathBox = "", SourcePathBox & jName & "\", SavePathBox)
Set fo = fs.GetFolder(SourcePathBox & jName)
Fk = fo.Files.Count '获取子文件夹下的文件数
If Fk > 1 Then
fName = Dir(SourcePathBox & jName & "\*.txt")
If fName <> "" Then
L = Len(fName) - 4: ST = "": i = 1
If Dir(SourcePathBox & jName & "\" & Right("00000", L) & ".txt") <> "" Then Fk = Fk - 1: i = 0
ProgressBar2.Max = Fk: ProgressBar2.Value = 0
For Fi = i To Fk
ProgressBar2.Value = Fi
z = Right("000" & Format(Fi), L) & ".txt"
fName = SourcePathBox & jName & "\" & z
If Dir(fName) <> "" Then GoSub 200
Next
GoSub 300
End If
ElseIf Fk = 1 Then '如果该子文件夹只有一个文件
fName = Dir(SourcePathBox & jName & "\*.txt")
If fName <> "" Then GoSub 200: GoSub 300
End If
Next
MsgBox "完成"
100
Screen.MousePointer = 0
Exit Sub

200
Open fName For Binary As #1
z = Space(FileLen(fName))
Get #1, , z
Close
ST = ST & Replace(z, Chr(0), "")
Return

300
Open bPath & jName & ".txt" For Output As #1
Print #1, ST
Close
Return
End Sub