├── README.md ├── libdef.txt ├── main.bas ├── modSample.bas └── src └── ThisWorkbook.cls /README.md: -------------------------------------------------------------------------------- 1 | text-scripting-vba 2 | ================== 3 | 4 | Modules for text scripting on VBA 5 | 6 | See Alse: http://rsh.csh.sh/text-scripting-vba/ (Japanese only now) 7 | 8 | -------------------------------------------------------------------------------- /libdef.txt: -------------------------------------------------------------------------------- 1 | 'main 2 | ./main.bas 3 | 4 | 'modules 5 | ./modSample.bas 6 | 7 | -------------------------------------------------------------------------------- /main.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modMain" 2 | 3 | Option Explicit 4 | 5 | Const REVISION_PROJECT As String = "20130103" 6 | 7 | 8 | Public Sub showRevision () 9 | MsgBox "Revision: " & REVISION_PROJECT 10 | End Sub 11 | 12 | -------------------------------------------------------------------------------- /modSample.bas: -------------------------------------------------------------------------------- 1 | Attribute VB_Name = "modSample" 2 | 3 | Option Explicit 4 | 5 | 6 | Sub dispOS() 7 | Dim nameOS As String 8 | nameOS = Application.OperatingSystem 9 | 10 | If nameOS Like "Windows *" Then 11 | ' Windows (32-bit) NT 6.01 12 | MsgBox "This is Windows OS. [" & nameOS & "]" 13 | 14 | ElseIf nameOS Like "Macintosh *" Then 15 | ' Macintosh (Intel) 10.8 16 | MsgBox "This is Mac OS X. [" & nameOS & "]" 17 | 18 | End If 19 | End Sub 20 | 21 | 22 | Sub dispVersion() 23 | MsgBox Application.Version 24 | End Sub 25 | 26 | -------------------------------------------------------------------------------- /src/ThisWorkbook.cls: -------------------------------------------------------------------------------- 1 | ' Text Scripting on VBA v1.0.0 2 | ' last update: 2013-01-03 3 | ' HATANO Hirokazu 4 | ' 5 | ' Detail: http://rsh.csh.sh/text-scripting-vba/ 6 | ' See Also: http://d.hatena.ne.jp/language_and_engineering/20090731/p1 7 | 8 | Option Explicit 9 | 10 | 11 | '----------------------------- Consts --------------- 12 | 13 | 'ライブラリリストの設定 (設置フォルダはワークブックと同じディレクトリ) 14 | Const FILENAME_LIBLIST As String = "libdef.txt" 'ライブラリリストのファイル名 15 | Const FILENAME_EXPORT As String = "ThisWorkbook-sjis.cls" 'エクスポート clsファイル名 16 | 17 | 'ワークブック オープン時に実行する(True) / しない(False) 18 | Const ENABLE_WORKBOOK_OPEN As Boolean = True 19 | 'Const ENABLE_WORKBOOK_OPEN As Boolean = False 20 | 21 | 'ショートカットキー 22 | Const SHORTKEY_RELOAD As String = "r" 'ctrl + r 23 | 24 | 25 | '----------------------------- Workbook_open() --------------- 26 | 27 | 'ワークブック オープン時に実行 28 | Private Sub Workbook_Open() 29 | If ENABLE_WORKBOOK_OPEN = False Then 30 | Exit Sub 31 | End If 32 | 33 | Call setShortKey 34 | Call reloadModule 35 | End Sub 36 | 37 | 'ワークブック クローズ時に実行 38 | Private Sub Workbook_BeforeClose(Cancel As Boolean) 39 | Call clearShortKey 40 | End Sub 41 | 42 | 43 | 44 | '----------------------------- public Subs/Functions --------------- 45 | 46 | Public Sub reloadModule() 47 | '手動リロード用 Public関数 48 | 49 | Dim msgError As String 50 | msgError = loadModule("." & Application.PathSeparator & FILENAME_LIBLIST) 51 | 52 | If Len(msgError) > 0 Then 53 | MsgBox msgError 54 | End If 55 | End Sub 56 | 57 | 58 | Public Sub exportThisWorkbook() 59 | 'ThisWorkbook 手動export用 Public関数 60 | Call exportModule("ThisWorkbook", FILENAME_EXPORT) 61 | End Sub 62 | 63 | 64 | 65 | 66 | '----------------------------- main Subs/Functions --------------- 67 | 68 | Private Function loadModule(ByVal pathConf As String) As String 69 | 'Main: モジュールリストファイルに書いてある外部ライブラリを読み込む。 70 | 71 | '1. 全モジュールを削除 72 | Dim isClear As Boolean 73 | isClear = clearModules 74 | 75 | If isClear = False Then 76 | loadModule = "Error: 標準モジュールの全削除に失敗しました。" 77 | Exit Function 78 | End If 79 | 80 | 81 | '2. モジュールリストファイルの存在確認 82 | ' 2.1. モジュールリストファイルの絶対パスを取得 83 | pathConf = absPath(pathConf) 84 | 85 | ' 2.2. 存在チェック 86 | Dim isExistList As Boolean 87 | isExistList = checkExistFile(pathConf) 88 | 89 | If isExistList = False Then 90 | loadModule = "Error: ライブラリリスト" & pathConf & "が存在しません。" 91 | Exit Function 92 | End If 93 | 94 | 95 | '3. モジュールリストファイルの読み込み&配列化 96 | Dim arrayModules As Variant 97 | arrayModules = list2array(pathConf) 98 | 99 | If UBound(arrayModules) = 0 Then 100 | loadModule = "Error: ライブラリリストに有効なモジュールの記述が存在しません。" 101 | Exit Function 102 | End If 103 | 104 | 105 | '4. 各モジュールファイル読み込み 106 | Dim i As Integer 107 | Dim msgError As String 108 | msgError = "" 109 | 110 | ' 配列は0始まり。(最大値: 配列個数-1) 111 | For i = 0 To UBound(arrayModules) - 1 112 | Dim pathModule As String 113 | pathModule = arrayModules(i) 114 | 115 | '4.1. モジュールリストファイルの存在確認 116 | ' 4.1.1. モジュールリストファイルの絶対パスを取得 117 | pathModule = absPath(pathModule) 118 | 119 | ' 4.1.2. 存在チェック 120 | Dim isExistModule As Boolean 121 | isExistModule = checkExistFile(pathModule) 122 | 123 | '4.2. モジュール読み込み 124 | If isExistModule = True Then 125 | ThisWorkbook.VBProject.VBComponents.Import pathModule 126 | Else 127 | msgError = msgError & pathModule & " は存在しません。" & vbCrLf 128 | End If 129 | Next i 130 | loadModule = msgError 131 | 132 | End Function 133 | 134 | 135 | 136 | '----------------------------- Functions / Subs --------------- 137 | 138 | Private Sub exportModule(ByVal nameModule As String, ByVal nameFile As String) 139 | 140 | Dim component As Object 141 | For Each component In ThisWorkbook.VBProject.VBComponents 142 | 143 | If component.Name = nameModule Then 144 | component.Export ThisWorkbook.path & Application.PathSeparator & nameFile 145 | MsgBox nameModule & " を " & ThisWorkbook.path & Application.PathSeparator & nameFile & " として保存しました。" 146 | End If 147 | 148 | Next component 149 | 150 | End Sub 151 | 152 | 153 | 154 | 155 | '----------------------------- common Functions / Subs --------------- 156 | Private Function clearModules() As Boolean 157 | '標準モジュール/クラスモジュール初期化(全削除) 158 | 159 | Dim component As Object 160 | For Each component In ThisWorkbook.VBProject.VBComponents 161 | 162 | '標準モジュール(Type=1) / クラスモジュール(Type=2)を全て削除 163 | If component.Type = 1 Or component.Type = 2 Then 164 | ThisWorkbook.VBProject.VBComponents.Remove component 165 | End If 166 | 167 | Next component 168 | 169 | '標準モジュール/クラスモジュールの合計数が0であればOK 170 | Dim cntBAS As Long 171 | cntBAS = countBAS() 172 | 173 | Dim cntClass As Long 174 | cntClass = countClasses() 175 | 176 | If cntBAS = 0 And cntClass = 0 Then 177 | clearModules = True 178 | Else 179 | clearModules = False 180 | End If 181 | 182 | End Function 183 | 184 | 185 | 186 | Private Function countBAS() As Long 187 | Dim count As Long 188 | count = countComponents(1) 'Type 1: bas 189 | countBAS = count 190 | End Function 191 | 192 | 193 | 194 | Private Function countClasses() As Long 195 | Dim count As Long 196 | count = countComponents(2) 'Type 2: class 197 | countClasses = count 198 | End Function 199 | 200 | 201 | 202 | Private Function countComponents(ByVal numType As Integer) As Long 203 | '存在する標準モジュール/クラスモジュールの数を数える 204 | 205 | Dim i As Long 206 | Dim count As Long 207 | count = 0 208 | 209 | With ThisWorkbook.VBProject 210 | For i = 1 To .VBComponents.count 211 | If .VBComponents(i).Type = numType Then 212 | count = count + 1 213 | End If 214 | Next i 215 | End With 216 | 217 | countComponents = count 218 | End Function 219 | 220 | 221 | 222 | Private Function absPath(ByVal pathFile As String) As String 223 | ' ファイルパスを絶対パスに変換 224 | 225 | Dim nameOS As String 226 | nameOS = Application.OperatingSystem 227 | 228 | 'replace Win backslash(Chr(92)) 229 | pathFile = Replace(pathFile, Chr(92), Application.PathSeparator) 230 | 231 | 'replace Mac ":"Chr(58) 232 | pathFile = Replace(pathFile, ":", Application.PathSeparator) 233 | 234 | 'replace Unix "/"Chr(47) 235 | pathFile = Replace(pathFile, "/", Application.PathSeparator) 236 | 237 | 238 | Select Case Left(pathFile, 1) 239 | 240 | 'Case1. . で始まる場合(相対指定) 241 | Case ".": 242 | 243 | Select Case Left(pathFile, 2) 244 | 245 | ' Case1-1. 相対指定 "../" 対応 246 | Case "..": 247 | 'MsgBox "Case1-1: " & pathFile 248 | absPath = ThisWorkbook.path & Application.PathSeparator & pathFile 249 | Exit Function 250 | 251 | ' Case1-2. 相対指定 "./" 対応 252 | Case Else: 253 | 'MsgBox "Case1-2: " & pathFile 254 | absPath = ThisWorkbook.path & Mid(pathFile, 2, Len(pathFile) - 1) 255 | Exit Function 256 | 257 | End Select 258 | 259 | 'Case2. 区切り文字で始まる場合 (絶対指定) 260 | Case Application.PathSeparator: 261 | 262 | ' Case2-1. Windows Network Drive ( chr(92) & chr(92) & "hoge") 263 | 'MsgBox "Case2-1: " & pathFile 264 | If Left(pathFile, 2) = Chr(92) & Chr(92) Then 265 | absPath = pathFile 266 | Exit Function 267 | 268 | Else 269 | ' Case2-2. Mac/UNIX Absolute path (/hoge) 270 | absPath = pathFile 271 | Exit Function 272 | 273 | End If 274 | 275 | End Select 276 | 277 | 278 | 'Case3. [A-z][0-9]で始まる場合 (Mac版Officeで正規表現が使えれば select文に入れるべき...) 279 | 280 | ' Case3-1.ドライブレター対応("c:" & chr(92) が "c" & chr(92) & chr(92)になってしまうので書き戻す) 281 | If nameOS Like "Windows *" And Left(pathFile, 2) Like "[A-z]" & Application.PathSeparator Then 282 | 'MsgBox "Case3-1" & pathFile 283 | absPath = Replace(pathFile, Application.PathSeparator, ":", 1, 1) 284 | Exit Function 285 | End If 286 | 287 | ' Case3-2. 無指定 "filename"対応 288 | If Left(pathFile, 1) Like "[0-9]" Or Left(pathFile, 1) Like "[A-z]" Then 289 | absPath = ThisWorkbook.path & Application.PathSeparator & pathFile 290 | Exit Function 291 | Else 292 | MsgBox "Error[AbsPath]: fail to get absolute path." 293 | 294 | End If 295 | 296 | End Function 297 | 298 | 299 | 300 | 301 | Private Function checkExistFile(ByVal pathFile As String) As Boolean 302 | 303 | On Error GoTo Err_dir 304 | If Dir(pathFile) = "" Then 305 | checkExistFile = False 306 | Else 307 | checkExistFile = True 308 | End If 309 | 310 | Exit Function 311 | 312 | Err_dir: 313 | checkExistFile = False 314 | 315 | End Function 316 | 317 | 318 | 319 | 'リストファイルを配列で返す(行頭が'(コメント)の行 & 空行は無視する) 320 | Private Function list2array(ByVal pathFile As String) As Variant 321 | 322 | Dim nameOS As String 323 | nameOS = Application.OperatingSystem 324 | 325 | '1. リストファイルの読み取り 326 | Dim fp As Integer 327 | fp = FreeFile 328 | Open pathFile For Input As #fp 329 | 330 | '2. リストの配列化 331 | Dim arrayOutput() As String 332 | Dim countLine As Integer 333 | countLine = 0 334 | ReDim Preserve arrayOutput(countLine) ' 配列0で返す場合があるため 335 | 336 | Do Until EOF(fp) 337 | 'ライブラリリストを1行ずつ処理 338 | Dim strLine As String 339 | Line Input #fp, strLine 340 | 341 | Dim isLf As Long 342 | isLf = InStr(strLine, vbLf) 343 | 344 | If nameOS Like "Windows *" And Not isLf = 0 Then 345 | 'OSがWindows かつ リストに LFが含まれる場合 (ファイルがUNIX形式) 346 | 'ファイル全体で1行に見えてしまう。 347 | 348 | Dim arrayLineLF As Variant 349 | arrayLineLF = Split(strLine, vbLf) 350 | 351 | Dim i As Integer 352 | For i = 0 To UBound(arrayLineLF) - 1 353 | '行頭が '(コメント) ではない & 空行ではない場合 354 | If Not Left(arrayLineLF(i), 1) = "'" And Len(arrayLineLF(i)) > 0 Then 355 | 356 | '配列への追加 357 | countLine = countLine + 1 358 | ReDim Preserve arrayOutput(countLine) 359 | arrayOutput(countLine - 1) = arrayLineLF(i) 360 | End If 361 | Next i 362 | 363 | 364 | Else 365 | 'OSがWindows and ファイルがWindows形式 (変換不要) 366 | 'OSがMacOS X and ファイルがUNIX形式 (変換不要) 367 | 368 | 'OSがMacOS X and ファイルがWindows形式 369 | ' vbCrがモジュールファイル名を発見できなくなる。 370 | strLine = Replace(strLine, vbCr, "") 371 | 372 | 373 | '行頭が '(コメント) ではない & 空行ではない場合 374 | If Not Left(strLine, 1) = "'" And Len(strLine) > 0 Then 375 | 376 | '配列への追加 377 | countLine = countLine + 1 378 | ReDim Preserve arrayOutput(countLine) 379 | arrayOutput(countLine - 1) = strLine 380 | End If 381 | 382 | End If 383 | Loop 384 | 385 | '3. リストファイルを閉じる 386 | Close #fp 387 | 388 | '4. 戻り値を配列で返す 389 | list2array = arrayOutput 390 | End Function 391 | 392 | 393 | 394 | ' ショートカットの設定 (Macでは Macro指定できないっぽい) 395 | Private Sub setShortKey() 396 | If Application.OperatingSystem Like "Windows *" Then 397 | Application.MacroOptions Macro:="ThisWorkbook.reloadModule", ShortcutKey:=SHORTKEY_RELOAD 398 | 399 | Else 400 | ' Mac OS Xの場合の注意: ThisWorkbook.reloadModule関数を持つマクロファイルを複数開いていると、 401 | ' 最後に開いたマクロファイルの ThisWorkbook.reloadModule関数が呼び出される模様。 402 | ' (その場合、マクロ一覧から'該当マクロファイル!reloadModule' を呼び出してください。) 403 | Application.OnKey "^" & SHORTKEY_RELOAD, "ThisWorkbook.reloadModule" 404 | 405 | End If 406 | 407 | End Sub 408 | 409 | 410 | 'ショートカット設定の削除 (Macでは Macro指定できないっぽい) 411 | Private Sub clearShortKey() 412 | If Application.OperatingSystem Like "Windows *" Then 413 | Application.MacroOptions Macro:="ThisWorkbook.reloadModule", ShortcutKey:="" 414 | 415 | Else 416 | ' Mac OS Xの場合の注意: ThisWorkbook.reloadModule関数を持つマクロファイルを複数開いていると、 417 | ' 最後に開いたマクロファイルの ThisWorkbook.reloadModule関数がクリアされる可能性が高いと思われる(未検証)。 418 | Application.OnKey SHORTKEY_RELOAD, "" 419 | End If 420 | 421 | End Sub 422 | 423 | --------------------------------------------------------------------------------