Kiều Mạnh
I don't program, I beat code into submission!!!
- Tham gia
- 9/6/12
- Bài viết
- 5,421
- Được thích
- 4,033
- Giới tính
- Nam
Xuất phát từ topic Add-Ins Tạo Menu RibbonTiếng Việt Có Dấu Cho Office
Link
http://www.giaiphapexcel.com/forum/...s-Tạo-Menu-RibbonTiếng-Việt-Có-Dấu-Cho-Office
Mạnh có nghiên cứu lại một loạt bài của Bạn doveandrose và Anh ndu96081631
Link
http://www.giaiphapexcel.com/forum/showthread.php?108310-V%E1%BB%8Dc-ch%C6%A1i-v%E1%BB%9Bi-nh%E1%BB%AFng-thu%E1%BA%ADt-to%C3%A1n-n%C3%A9n-v%C3%A0-gi%E1%BA%A3i-n%C3%A9n-file
Sau khi nghiên cứu thuật toán winrar từ loạt bài link trên để phục phụ cho mục đích Viết Add-Ins Ribbon
thì mình bất chợt nhận ra rằng nó có liên quan và xử lý tốt cho styles mà doveandrose và Anh ndu96081631 đã viết ở topic đó ....vậy Mình mượn hai Hàm của doveandrose và Anh ndu96081631
Và viết thêm 1 hàm nữa ngắn gọn để xử lý styles rác thấy hiệu quả Úp lên cho Bạn nào cần thì tải về mà xài ....chạy tốt trên mọi Win32 & 64 bit
Nếu Bạn doveandrose và Anh ndu96081631 .... Có ghé qua thì Chấm điểm dùm đồ đệ theo hai thầy học thuật toán Winrar Nộp bài liệu có được 5 điểm chăng ....
Xin cảm ơn 2 thầy với loạt bài
Vọc chơi với những thuật toán nén và giải nén file
Code Của Bạn doveandrose
Code Của Anh ndu96081631
Code Kiều Mạnh
Giải nén ra trong Folder có:
1/ 1 Filestyles.rar là file có nhiều styles rác mà test
2/ Trong Folder có 1 file ClearStyles Office Excel.exe rành cho Bạn nào chưa biết bật Mắt Rô thì chạy file đó cho nó gọn chức năng như file ClearStyles Office Excel.xlsm
3/ Mình Bổ sung thêm xử lý 2 Loại File Excel nữa là 5 Loại File :: *.xls; *.xlsx;*.xlsm;*.xlsb;*.xlam
Tải File ClearStyles Office Excel_Ver2.rar
Link
http://www.giaiphapexcel.com/forum/...s-Tạo-Menu-RibbonTiếng-Việt-Có-Dấu-Cho-Office
Mạnh có nghiên cứu lại một loạt bài của Bạn doveandrose và Anh ndu96081631
Link
http://www.giaiphapexcel.com/forum/showthread.php?108310-V%E1%BB%8Dc-ch%C6%A1i-v%E1%BB%9Bi-nh%E1%BB%AFng-thu%E1%BA%ADt-to%C3%A1n-n%C3%A9n-v%C3%A0-gi%E1%BA%A3i-n%C3%A9n-file
Sau khi nghiên cứu thuật toán winrar từ loạt bài link trên để phục phụ cho mục đích Viết Add-Ins Ribbon
thì mình bất chợt nhận ra rằng nó có liên quan và xử lý tốt cho styles mà doveandrose và Anh ndu96081631 đã viết ở topic đó ....vậy Mình mượn hai Hàm của doveandrose và Anh ndu96081631
Và viết thêm 1 hàm nữa ngắn gọn để xử lý styles rác thấy hiệu quả Úp lên cho Bạn nào cần thì tải về mà xài ....chạy tốt trên mọi Win32 & 64 bit
Nếu Bạn doveandrose và Anh ndu96081631 .... Có ghé qua thì Chấm điểm dùm đồ đệ theo hai thầy học thuật toán Winrar Nộp bài liệu có được 5 điểm chăng ....
Xin cảm ơn 2 thầy với loạt bài
Vọc chơi với những thuật toán nén và giải nén file
Code Của Bạn doveandrose
Mã:
Private Function ClearStyleXML(ByVal xmlFile As String) As Boolean
Dim doc As Object, xNode, n As Long ''// Copy Form doveandrose - www.giaiphapexcel.com
Set doc = CreateObject("Microsoft.XMLDOM")
doc.Load xmlFile
For Each xNode In doc.SelectNodes("/styleSheet/cellStyles/cellStyle")
If TypeName(xNode.Attributes.getNamedItem("builtinId")) = "Nothing" Then
xNode.ParentNode.RemoveChild xNode
n = n + 1
End If
Next
If n > 0 Then
UniMsgbox "Da xoa xong " & n & " styles rác"
doc.Save xmlFile
ClearStyleXML = True
Else
ClearStyleXML = False
UniMsgbox "Không có styles rác nào"
End If
Set doc = Nothing
End Function
Mã:
Private Function ClearStylesFromXML(ByVal xmlFile As String) As Boolean
Dim Params As String, FileName As String, StartDir As String, Ext As String
Dim text1 As String, text2 As String, text3 As String
Dim Arr, aBuiltInYes(), aBuiltInNo() ''// Copy Form ndu96081631 - www.giaiphapexcel.com
Dim lBuiltInYes As Long, lBuiltInNo As Long, i As Long, lPos_Start As Long, lPos_End As Long
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
'On Error Resume Next
With Fso
If Not .FileExists(xmlFile) Then Exit Function
If .GetFile(xmlFile).Name <> "styles.xml" Then Exit Function
With .OpenTextFile(xmlFile)
text1 = .ReadAll
.Close
End With
lPos_Start = InStr(1, text1, "<cellStyle name=")
lPos_End = InStr(1, text1, "</cellStyles>")
text2 = Mid(text1, lPos_Start, lPos_End - lPos_Start)
text3 = Replace(text2, "/><", "/>" & vbLf & "<")
Arr = Split(text3, vbLf)
For i = LBound(Arr) To UBound(Arr)
If InStr(1, Arr(i), "builtinId") Then
lBuiltInYes = lBuiltInYes + 1
ReDim Preserve aBuiltInYes(1 To lBuiltInYes)
aBuiltInYes(lBuiltInYes) = Arr(i)
Else
lBuiltInNo = lBuiltInNo + 1
ReDim Preserve aBuiltInNo(1 To lBuiltInNo)
aBuiltInNo(lBuiltInNo) = Arr(i)
End If
Next
If lBuiltInNo Then
text1 = Replace(text1, text2, Join(aBuiltInYes, ""))
.CreateTextFile(xmlFile, True).Write text1
MsgBox "Da xoa xong " & lBuiltInNo & " styles rác"
ClearStylesFromXML = True
Else
MsgBox "Không có styles rác nào"
ClearStylesFromXML = False
End If
End With
Set Fso = Nothing
End FunctionCode Kiều Mạnh
Mã:
Private Sub Deletestyles(ByVal FileExcel As String)
Dim Fso As Object, ObjShell As Object, Ext As String
Dim FileName_Path, ZipFile, xml As String ''// Coded by Kieu Manh - www.giaiphapexcel.com
ZipFile = FileExcel & ".zip"
Set ObjShell = CreateObject("Shell.Application")
Set Fso = CreateObject("Scripting.FileSystemObject")
FileName_Path = Fso.GetParentFolderName(FileExcel)
xml = FileName_Path & "\styles.xml"
Ext = Fso.GetExtensionName(FileExcel)
If (UCase(Ext) <> "XLSX") And (UCase(Ext) <> "XLSM") And (UCase(Ext) <> "XLAM") Then Exit Sub
If Fso.FileExists(FileExcel) Then
Fso.MoveFile FileExcel, FileExcel & ".zip"
ObjShell.Namespace(FileName_Path).movehere ObjShell.Namespace(ZipFile).items.Item("xl\styles.xml")
Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing
Application.Wait (Now + 0.000005)
Loop
Rem If ClearStyleXML(xml) Then ''//Ok 1
If ClearStylesFromXML(xml) Then ''//Ok 2 ....Thuy thich xai Ham tren hay duoi cung OK
ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml")
Do While ObjShell.Namespace(ZipFile & "\xl\") Is Nothing
Application.Wait (Now + 0.000005)
Loop
Else
ObjShell.Namespace(ZipFile & "\xl\").movehere ObjShell.Namespace(FileName_Path).items.Item("styles.xml")
Do Until Not Fso.FileExists(xml)
Application.Wait (Now + 0.000005)
Loop
Fso.MoveFile FileExcel & ".zip", FileExcel
Exit Sub
End If
Do Until Not Fso.FileExists(xml)
Application.Wait (Now + 0.000005)
Loop
Fso.MoveFile FileExcel & ".zip", FileExcel
UniMsgbox "done"
End If
Set ObjShell = Nothing
Set Fso = Nothing
End SubGiải nén ra trong Folder có:
1/ 1 Filestyles.rar là file có nhiều styles rác mà test
2/ Trong Folder có 1 file ClearStyles Office Excel.exe rành cho Bạn nào chưa biết bật Mắt Rô thì chạy file đó cho nó gọn chức năng như file ClearStyles Office Excel.xlsm
3/ Mình Bổ sung thêm xử lý 2 Loại File Excel nữa là 5 Loại File :: *.xls; *.xlsx;*.xlsm;*.xlsb;*.xlam
Tải File ClearStyles Office Excel_Ver2.rar
Lần chỉnh sửa cuối:
