|
不能發(fā)附件，自己建窗體 代碼如下 VERSION 5.00 Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} myCover Caption = "EXCLE批量轉(zhuǎn)換格式" 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不能打開高版本文件，請(qǐng)?jiān)?7以上版本進(jìn)行轉(zhuǎn)換！") Exit Sub End If If TextBox1.Value = "" Then MsgBox ("老大，你沒有指定路徑，讓我轉(zhuǎn)空氣??？") 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 '目標(biāo)路徑不存在時(shí)先建立 If Dir(myDirO, vbDirectory) = "" Then MkDir myDirO On Error Resume Next Application.ScreenUpdating = True Application.DisplayAlerts = False If OptionButton1.Value = True Then '07-13格式轉(zhuǎn)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 "全部轉(zhuǎn)換完畢，共轉(zhuǎn)換文件 " & i & "個(gè)" '03格式轉(zhuǎn)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 "全部轉(zhuǎn)換完畢，共轉(zhuǎn)換文件 " & i & "個(gè)" End If End Sub Private Sub CommandButton2_Click() Unload Me End Sub ' 窗體初始化 Private Sub UserForm_Initialize() TextBox1.Value = ActiveWorkbook.Path TextBox1.SetFocus End Sub |
|
|
