1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
|
Sub test()
'Worksheets.Add
'On Error Resume Next
'Worksheets("ImportMtlFile").Delete
'Worksheets(1).Name = "ImportMtlFile"
Worksheets("ImportMtlFile").Activate
Worksheets("ImportMtlFile").Range("a1:e65536").Clear
Dim i, j As Integer
Dim TextPart As String
Dim FileName As Variant
Dim Rmax As Integer
Dim NewMtlAddressRow As Integer
Dim KdRangeRow As Integer
Dim LenghtNewMtlArray As Integer
'
' import mtl file
'
FileName = Application.GetOpenFilename("mtl File (*.mtl),*.mtl,", 1, _
"Select the mtl associated to the obj file to Import")
Open FileName For Binary As #1
Do While Not EOF(1)
Line Input #1, strLigne
t = Split(strLigne, " ")
On Error Resume Next
dl = ActiveSheet.Range("a65536").End(xlUp).Row + 1
If UBound(t) = -1 Then ActiveSheet.Cells(dl, 1) = "'"
ActiveSheet.Cells(dl, 1).Resize(1, UBound(t) + 1) = t
Loop
Close #1
MyDataObject.Clear
Set MyDataObject = Nothing
'find size of the array
NewMtlAddressRow = Range("a1:a65536").Find("newmtl", LookIn:=xlValues).Row
Cells(NewMtlAddressRow, 1).Select
'searching Kd in the selected array
KdRangeRow = Worksheets("ImportMtlFile").Range("A1:A65536"). _
Find("Kd", LookIn:=xlValues).Row - NewMtlAddressRow
Worksheets("ImportMtlFile").Range("a1:a65536").Find("Kd", LookIn:=xlValues).Select
Rmax = Range("B65536").End(xlUp).Offset(1, 0).Row
Cells(NewMtlAddressRow, 1).Select
Do While ActiveCell <> Empty
ActiveCell.Offset(1, 0).Select
Loop
LenghtNewMtlArray = ActiveCell.Row
Worksheets("ImportMtlFile").Range("A" & NewMtlAddressRow + 1, "F" & LenghtNewMtlArray).Copy
'
' setting the 5 colors
'
'lawngreen
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Offset(2, 0).Select
ActiveCell.Value = "newmtl"
ActiveCell.Offset(0, 1) = "lawngreen"
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Select
Do While ActiveCell.Value <> "Kd"
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(0, 1).Value = "0.486275"
ActiveCell.Offset(0, 2).Value = "0.988235"
ActiveCell.Offset(0, 3).Value = "0"
'yellowgreen
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = "newmtl"
ActiveCell.Offset(0, 1) = "yellowgreen"
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Select
Do While ActiveCell.Value <> "Kd"
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(0, 1).Value = "0.603922"
ActiveCell.Offset(0, 2).Value = "0.803922"
ActiveCell.Offset(0, 3).Value = "0.196078"
'gold
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = "newmtl"
ActiveCell.Offset(0, 1) = "gold"
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Select
Do While ActiveCell.Value <> "Kd"
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(0, 1).Value = "1"
ActiveCell.Offset(0, 2).Value = "0.843137"
ActiveCell.Offset(0, 3).Value = "0"
'orangered
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = "newmtl"
ActiveCell.Offset(0, 1) = "orangered"
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Select
Do While ActiveCell.Value <> "Kd"
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(0, 1).Value = "1"
ActiveCell.Offset(0, 2).Value = "0.270588"
ActiveCell.Offset(0, 3).Value = "0"
'darkred
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.Value = "newmtl"
ActiveCell.Offset(0, 1) = "darkred"
ActiveCell.Offset(1, 0).Select
ActiveSheet.Paste
Worksheets("ImportMtlFile").Range("a65536").End(xlUp).Select
Do While ActiveCell.Value <> "Kd"
ActiveCell.Offset(-1, 0).Select
Loop
ActiveCell.Offset(0, 1).Value = "0.545098"
ActiveCell.Offset(0, 2).Value = "0"
ActiveCell.Offset(0, 3).Value = "0"
'delete blank rows
Range("a1").EntireRow.Delete shift:=xlShiftDown
Worksheets("ImportMtlFile").Range("a1:a65536").Find("Ke", LookIn:=xlValues).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Delete shift:=xlShiftDown
Worksheets("ImportMtlFile").Range("a1:a65536").Find("Ke", LookIn:=xlValues).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.EntireRow.Delete shift:=xlShiftDown
'Worksheets("ImportMtlFile").Range("a1:e65536").NumberFormat = "General"
Worksheets("ImportMtlFile").Range("a1:e65536").Replace what:=",", replacement:="."
'exportation as mtl
exportmtl:
MtlName = Replace(Mid(FileName, InStrRev(FileName, "\") + 1), ".mtl", "")
currpath = ThisWorkbook.Path
ThisWorkbook.Worksheets("ImportMtlFile").Copy
Application.DisplayAlerts = False 'in case of an error message, it will hide it
On Error Resume Next
ActiveWorkbook.SaveAs currpath & "\" & MtlName & ".xlsm"
Rmax = Range("B65536").End(xlUp).Offset(1, 0).Row
Dim File As String, Chain As String
Dim R As Long
Dim F As Integer, c As Integer
F = FreeFile()
File = Replace(currpath & "\" & MtlName & "bis.xlsm", ".xlsm", ".mtl")
Open File For Output As #F
For R = 1 To Rmax
Chain = Cells(R, 1)
For c = 2 To 300
Chain = Chain & " " & Cells(R, c)
Next c
Print #F, Chain
Next R
Close #F
End Sub |