Nếu bạn chưa hiểu Fso co thể tham khảo thêm Link chữ ký của mình FileSystemObject
đúng rồi đó nó xử Uncode trực tiếp vào File customUI.xml luôn mà như file đơn giản nhất chỉ tạo Tab mình Úp bài 1 đó nó xử Ok mà ....
Private Sub AddrelsFile(ByVal Fso As Object, ByVal Extension As String, ByVal relsFile As String)
Dim XML As String
XML = "<?xml version=""1.0"" encoding=""UTF-8"" standalone=""yes""?>" & vbNewLine:
XML = XML & "<Relationships xmlns=""http://schemas.openxmlformats.org/package/2006/relationships"">"
XML = XML & "<Relationship Id=""rId3"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/extended-properties"" Target=""docProps/app.xml""/>"
XML = XML & "<Relationship Id=""rId2"" Type=""http://schemas.openxmlformats.org/package/2006/relationships/metadata/core-properties"" Target=""docProps/core.xml""/>"
XML = XML & "<Relationship Id=""rId1"" Type=""http://schemas.openxmlformats.org/officeDocument/2006/relationships/officeDocument"" Target=""xl/workbook." & _
IIf(UCase(Extension) = "XLSB", "bin""/>", "xml""/>") & Get_IDrels
With Fso.CreateTextFile(relsFile, True)
.Write XML
.Close
End With
End SubPrivate Sub AddCustomUIToRels(ByVal sRels As String)
Dim oXMLDoc As Object, oXMLElement As Object
Dim oXMLAttrib As Object, oNamedNodeMap As Object
Dim oXMLRelsList As Object
Set oXMLDoc = CreateObject("Msxml2.DOMDocument.3.0")
oXMLDoc.Load sRels
Set oXMLElement = oXMLDoc.createNode(1, "Relationship", _
"http://schemas.openxmlformats.org/package/2006/relationships")
Set oNamedNodeMap = oXMLElement.Attributes
Set oXMLAttrib = oXMLDoc.createAttribute("Id")
If AppVersion < 12 Then
oXMLAttrib.NodeValue = "cuID" ''// Office 2007
Else
oXMLAttrib.NodeValue = "cuID14" ''// Office 2010 Va Office 2016
End If
oNamedNodeMap.setNamedItem oXMLAttrib
Set oXMLAttrib = oXMLDoc.createAttribute("Type")
If AppVersion < 12 Then ''// For Office2007
oXMLAttrib.NodeValue = "http://schemas.microsoft.com/office/2006/relationships/ui/extensibility"
Else ''// For Office 2010 Va Office 2016
oXMLAttrib.NodeValue = "http://schemas.microsoft.com/office/2007/relationships/ui/extensibility"
End If
oNamedNodeMap.setNamedItem oXMLAttrib
Set oXMLAttrib = oXMLDoc.createAttribute("Target")
If AppVersion < 12 Then
oXMLAttrib.NodeValue = "customUI/customUI.xml" ''// Office 2007
Else
oXMLAttrib.NodeValue = "customUI/customUI14.xml" ''// Office 2010 Va Office 2016
End If
oNamedNodeMap.setNamedItem oXMLAttrib
Set oXMLRelsList = oXMLDoc.SelectNodes("/Relationships")
oXMLRelsList.Item(0).appendChild oXMLElement
oXMLDoc.Save sRels
Set oXMLDoc = Nothing
Set oXMLAttrib = Nothing
Set oXMLElement = Nothing
End Sub
đã inbox cho bác, toàn lụm lọc rồi chỉnh sửa lại không à. chả có cái gì của mình cả.
Mình mới thử lần 1 lỗi dòng sau: Vì máy Bạn Win64 Máy mình Win32 cái này đơn giản ta làm cái If là xong
lỗi dòng đó là do đường link đến file ảnh sai ấy bác mạnh ạ. dòng 40 41 ở cột G có 2 link file ảnh.bác nhấn đúp vào ô tương ứng rồi chọn icon trong máy bác thôi là xong. nhỏ hơn 500x500 pixel nhe bác
Ok thấy Rồi ...Nhưng mới thử File đã có customUI14.xml (2010) nó chen code vao được nhưng Ribbon ko tạo được
lạ nhỉ. e chọn 2010 nó vẫn ra mà ta
Bạn Thêm 2 dòng sau vào Hàm ExportLanguage
fso e không biết nhiều, chỉ biết có 1 vài thứ à. với lại gõ lệnh nó không hiện gợi ý tiếp theo nên chả biết nó có cái gì và chức năng ra sao nữa.
Public Function Get_XML(ByRef GTri As Boolean) As String
Dim a As Long, b As Long, c As Long, s As String, Arrs, Arrd(1 To 10000)
[COLOR=#ff0000] If Sheet1.Range("B1").Value = "2007" Then CustUI = [/COLOR][B][COLOR=#0000ff]"2006/01"[/COLOR][/B][COLOR=#ff0000] Else CusUI = [/COLOR][B][COLOR=#0000ff]"2009/07"[/COLOR][/B][COLOR=#ff0000][/COLOR]
[COLOR=#ff0000] Arrd(1) = Replace("<customUI xmlns=""http://schemas.microsoft.com/office/[/COLOR][COLOR=#0000ff][B]CusUI[/B][/COLOR][COLOR=#ff0000]/customui""" & IIf(Len(Sheet1.Cells(2, 2).Value) > 0, " onLoad=""" & Sheet1.Cells(2, 2).Value & """", "") & ">", "CusUI", CusUI)[/COLOR]xong code cho file [content_Types].xml mà không biết cách nén nó vào bác ạ.
Public Function Get_Content_Types(ByVal Arr As Variant, ByVal x As Byte)
'<Default Extension=^png^ ContentType=^image/png^/>
Dim i As Byte
Dim DinhDangAnh, NDungKhaiBao As String, NDung_Content_Types As String
For i = 1 To x 'lay nhung dinh dang anh chen tu ben ngoai
If Not (DinhDangAnh Like "* " & Arr(i, 4) & " *") Then DinhDangAnh = DinhDangAnh & " " & Arr(i, 4) & " "
Next i
'xoa nhung khoang trang du
DinhDangAnh = Application.WorksheetFunction.Trim(DinhDangAnh)
'xoa mang
Set Arr = Nothing
'lay dinh dang duoi anh vao mang
Arr = Split(DinhDangAnh, " ")
For i = LBound(Arr) To UBound(Arr) 'viet code khai bao dinh dang
NDungKhaiBao = NDungKhaiBao & Replace("<Default Extension=^xxx^ ContentType=^image/xxx^/>", "xxx", Arr(i))
Next i
'noi dung xml
NDung_Content_Types = "<Types xmlns=^http://schemas.openxmlformats.org/package/2006/content-types^>" & vbNewLine & _
NDungKhaiBao & _
"<Default Extension=^wmf^ ContentType=^image/x-wmf^/>" & _
"<Default Extension=^rels^ ContentType=^application/vnd.openxmlformats-package.relationships+xml^/>" & _
"<Default Extension=^xml^ ContentType=^application/xml^/>" & _
"<Override PartName=^/xl/workbook.xml^ ContentType=^application/vnd.ms-excel.sheet.macroEnabled.main+xml^/>" & _
"<Override PartName=^/xl/worksheets/sheet1.xml^ ContentType=^application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml^/>" & _
"<Override PartName=^/xl/theme/theme1.xml^ ContentType=^application/vnd.openxmlformats-officedocument.theme+xml^/>" & _
"<Override PartName=^/xl/styles.xml^ ContentType=^application/vnd.openxmlformats-officedocument.spreadsheetml.styles+xml^/>" & _
"<Override PartName=^/docProps/core.xml^ ContentType=^application/vnd.openxmlformats-package.core-properties+xml^/>" & _
"<Override PartName=^/docProps/app.xml^ ContentType=^application/vnd.openxmlformats-officedocument.extended-properties+xml^/></Types>"
Get_Content_Types = Replace(NDung_Content_Types, "^", """")
End FunctionĐây Cắt Ra Cắt vào ....
Sub Test_CutRa()
Dim ZipFile, Path
Path = ThisWorkbook.Path
ZipFile = Path & "\YourApp.xlsm.zip"
With CreateObject("Shell.Application")
.Namespace(Path).MoveHere .Namespace(ZipFile).items.Item("[Content_Types].xml")
End With
End Sub
Sub Test_CutVao()
Dim Path, ZipFile
Path = ThisWorkbook.Path
ZipFile = Path & "\YourApp.xlsm.zip"
With CreateObject("Shell.Application")
.Namespace(ZipFile).MoveHere .Namespace(Path).items.Item("[Content_Types].xml")
End With
End Subcó vấn đề rồi bác ạ. khi sửa file [Content_Types].xml thì toàn bộ code đã chèn trước đó sẽ mất.
Hàm Get_Content_Types
''// Check Microsoft Visual Basic for Applications Extensibility 5.3
Public Sub Check_Extensibility()
On Error Resume Next ''// Neu chay LAN 2 la loi nen Bay loi
ThisWorkbook.VBProject.References.AddFromGuid _
GUID:="{0002E157-0000-0000-C000-000000000046}", Major:=5, Minor:=3
End SubPublic Sub CheckKey()
Dim MyFile As String
Rem MyFile = "C:\Program Files (x86)\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
MyFile = "C:\Program Files\Common Files\microsoft shared\VBA\VBA6\VBE6EXT.OLB"
AddFromFileDLL (MyFile)
End Subđược bác. check OK
Sub ListReference()
Dim i As Long
Range("A1:F100").ClearContents
Range("A1:F1").Value = Array("Description", "References Name", _
"GUID:", "Major:", "Minor:", "Full Path To References")
For i = 1 To ThisWorkbook.VBProject.References.Count
With ThisWorkbook.VBProject.References(i)
Range("A65536").End(xlUp).Offset(1, 0) = .Description
Range("A65536").End(xlUp).Offset(0, 1) = .Name
Range("A65536").End(xlUp).Offset(0, 2) = .GUID
Range("A65536").End(xlUp).Offset(0, 3) = .Major
Range("A65536").End(xlUp).Offset(0, 4) = .Minor
Range("A65536").End(xlUp).Offset(0, 5) = .FullPath
End With
Next i
End Subthì vụ chèn hình trước em có nói rồi, em sử dụng chương trình khác để tạo nó cũng báo lỗi y chang vậy. mà office nó tự động sửa được cũng đỡ.
