VBA-Functional-Array/mkSelected.vbs at master · mnru/VBA-Functional-Array · GitHub

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
Dim fso, sstm, tstm
Call main

Sub main()
Dim sourcePath
Set fso = CreateObject("Scripting.FileSystemObject")
parentPath = Replace(WScript.ScriptFullName, WScript.ScriptName, "")
'parentPath = ThisWorkbook.Path
'sAryEnum = Array(Array("modAry.bas", 5, 15),Array("modUtil.bas", 5, 10),Array("modRng.bas", 5, 9))
sAryEnum = Array()
sAryProc = Array(Array("modAry.bas", 5, -1), Array("modFnc.bas", 5, -1), Array("modMulti.bas", 2, -1), Array("modUtil.bas", 5, -1),Array("modRng.bas", 5, -1), Array("modLog.bas", 5, 45))
tAry = Array("FunctionalArraySelectedNoLog.bas", "FunctionalArraySelected.bas","FunctionalArrayMin.bas")
For Each targetFile In tAry
 targetPath = parentPath & "\" & targetFile
 Set tstm = fso.createtextfile(targetPath)
 str0 = "Attribute VB_Name = """ & fso.getbasename(targetPath) & """"
 str1 = strHead()
 tstm.writeline (str0)
 tstm.writeline (str1)
 tstm.Close
 For Each sElm In sAryEnum
 sourcePath = parentPath & "\src\" & sElm(0)
 Call cpFile(targetPath, sourcePath, sElm(1), sElm(2),False)
 Next
 For Each sElm In sAryProc
 sourcePath = parentPath & "\src\" & sElm(0)
 If sElm(0) = "modMulti.bas" Then
  Call cpFile1(targetPath, sourcePath, sElm(1), sElm(2), True)
 Else
  Call cpFile(targetPath, sourcePath, sElm(1), sElm(2), True)
		if targetFile = "FunctionalArrayMin.bas" and sElm(0) = "modFnc.bas" then
			exit for
		end if
		if targetFile = "FunctionalArraySelectedNoLog.bas" and sElm(0) = "modRng.bas" then
			exit for
		end if
 End If
 Next
Next
MsgBox "finished"
End Sub

Sub cpFile(tf, sf, fromLine, toLine, bolFrom)
Dim fso, tstm, sstm
Set fso = CreateObject("Scripting.FileSystemObject")
Set tstm = fso.opentextfile(tf, 8) 'for appending
Set sstm = fso.opentextfile(sf, 1) 'for reading
If bolFrom Then
 tstm.writeblanklines (1)
 tstm.writeline (String(20, "'"))
 tstm.writeline ("'from " & fso.getbasename(sf))
 tstm.writeline (String(20, "'"))
End If
Do While Not sstm.atEndOfStream
 Line = sstm.Line
 If Line < fromLine Or (toLine > 0 And Line > toLine) Then
 sstm.skipline
 Else
 str0 = sstm.readline
 tstm.writeline (str0)
 End If
Loop
sstm.Close
tstm.Close
End Sub

Sub cpFile1(tf, sf, fromLine, toLine, bolFrom)
Dim fso, tstm, sstm
Set fso = CreateObject("Scripting.FileSystemObject")
Set tstm = fso.opentextfile(tf, 8) 'for appending
Set sstm = fso.opentextfile(sf, 1) 'for reading
If bolFrom Then
 tstm.writeblanklines (1)
 tstm.writeline (String(20, "'"))
 tstm.writeline ("'from " & fso.getbasename(sf))
 tstm.writeline (String(20, "'"))
End If
Do While Not sstm.atEndOfStream
 Line = sstm.Line
 If Line < fromLine Or (toLine > 0 And Line > toLine) Then
 sstm.skipline
 Else
 str0 = sstm.readline
 If getCaseNum(str0) <= 5 Then
  tstm.writeline (str0)
 End If
 End If
Loop
sstm.Close
tstm.Close
End Sub

Function getCaseNum(str)
ret = -1
str1 = Trim(str)
If Left(str1, 4) = "Case" Then
 tmp = InStr(str1, ":")
 If tmp = 0 Then
 str2 = Trim(Right(str1, Len(str1) - 5))
 Else
 str2 = Trim(Mid(str1, 6, tmp - 6))
 End If
 If IsNumeric(str2) Then
 ret = CLng(str2)
 End If
End If
getCaseNum = ret
End Function

Function strHead()
Dim ret
ret = Join(Array("","Option Base 0", "Option Explicit","",String(20, "'"), "' enum", String(20, "'")), vbCrLf)
strHead = ret
End Function