不能发附件,自己建窗体 代码如下 VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} myCover Caption = "EXCLE批量转换格式" ClientHeight = 4200 ClientLeft = 45 ClientTop = 435 ClientWidth = 4785 OleObjectBlob = "myCover.frx":0000 StartUpPosition = 1 '所有者中心 End Attribute VB_Name = "myCover" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Private Sub CommandButton1_Click() Dim myFiles Dim myDirS, myDirO As String Dim i As Long If Application.Version = "11.0" Then MsgBox ("老大,Excel2003不能打开高版本文件,请在07以上版本进行转换!") Exit Sub End If If TextBox1.Value = "" Then MsgBox ("老大,你没有指定路径,让我转空气啊?") Exit Sub ElseIf Dir(TextBox1.Value, vbDirectory) = vbNullString Then MsgBox ("老大,你确定源文件路径真的存在?") Exit Sub End If If TextBox2.Value = "" Then TextBox2.Value = TextBox1.Value '处理路径 If Right(TextBox1.Value, 1) = "\" Then TextBox1.Value = Left(TextBox1.Value, Len(TextBox1.Value) - 1) If Right(TextBox2.Value, 1) = "\" Then TextBox2.Value = Left(TextBox2.Value, Len(TextBox2.Value) - 1) myDirS = TextBox1.Value myDirO = TextBox2.Value '目标路径不存在时先建立 If Dir(myDirO, vbDirectory) = "" Then MkDir myDirO On Error Resume Next Application.ScreenUpdating = True Application.DisplayAlerts = False If OptionButton1.Value = True Then '07-13格式转03格式 myFiles = Dir(myDirS & "\*.xlsx") Do While myFiles <> "" Workbooks.Open Filename:=myDirS & "\" & myFiles ActiveWorkbook.SaveAs Filename:= _ myDirO & "\" & Left(myFiles, Len(myFiles) - 1), FileFormat:=xlExcel8, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False ActiveWindow.Close '删除源文件 If CheckBox1.Value = False Then Kill myDirS & "\" & myFiles i = i + 1 myFiles = Dir DoEvents Loop MsgBox "全部转换完毕,共转换文件 " & i & "个" '03格式转07-13格式 Else myFiles = Dir(myDirS & "\*.xls") Do While myFiles <> "" If Right(myFiles, 1) = "x" Then GoTo NF Workbooks.Open Filename:=myDirS & "\" & myFiles ActiveWorkbook.SaveAs Filename:= _ myDirO & "\" & myFiles & "x", FileFormat:=xlOpenXMLWorkbook, _ Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _ CreateBackup:=False ActiveWindow.Close i = i + 1 '删除源文件 If CheckBox1.Value = False Then Kill myDirS & "\" & myFiles NF: myFiles = Dir DoEvents Loop MsgBox "全部转换完毕,共转换文件 " & i & "个" End If End Sub Private Sub CommandButton2_Click() Unload Me End Sub ' 窗体初始化 Private Sub UserForm_Initialize() TextBox1.Value = ActiveWorkbook.Path TextBox1.SetFocus End Sub |
|
来自: leexingyuan5 > 《ExceI VBA》