VBScript

2016年1月 7日 (木)

VBA雑記帳0107

Sub m_PutModuleHeader(ByVal pMdNm, ByRef pMd As tModuleData)
    Dim lText As String
    Close #1
    Open "c:\MHead" + CStr(Format(Now(), "yyyymmddhhmm")) + ".txt" For Append As #1
   
    'モジュールシート名出力
    lText = pMdNm + String(10, "-") + Chr(13)
    Print #1, lText
   
    '機能概要出力
    For i = LBound(pMd.lGaiyo) To UBound(pMd.lGaiyo)
        If pMd.lGaiyo(i) = "" Then GoTo next_i
       
        lModulNm = Mid(pMd.lMNm(i), 5, Len(pMd.lMNm(i)) - 4)    'メソッド名
        lGaiyo = Trim(pMd.lGaiyo(i))                            '機能概要
        lKino = Trim(pMd.lKino(i))                              '機能名
        lText = "(" + CStr(i) + ")" + lKino + Chr(13) + lGaiyo + Chr(13)
        Print #1, lText
next_i:
    Next i
    Close #1
End Sub

Sub m_PutModuleHeader()
    Dim lText As String
   
        'ファイル指定
    fileOpenName = Application.GetOpenFilename("*.sqlファイル (*.sql), *.sql", MultiSelect:=True, Title:="★★★ ファイル選択 ★★★")
   
    If IsArray(fileOpenName) Then
        For i = 1 To UBound(fileOpenName)
            Close #1
            Open fileOpenName(i) For Input As #1
            lSp = Dir(fileOpenName(i), vbNormal)
            Open "c:\work\sp_out\" & lSp For Output As #2
            
            Do While Not EOF(1)
                Line Input #1, InputData
                'If InputData = "" Then GoTo next_i
                '                                          v_proc_id number(10)
                If StrConv(InputData, vbLowerCase) Like "*v_proc_id number*" Then
                    lText = Replace(InputData, "v_proc_id number", "v_proc_id verchar(30)")
                ElseIf StrConv(InputData, vbLowerCase) Like "*v_proc_id *" Then
                    lText = Replace(InputData, "@@proc_id", "'" & lSp & "'")
                Else
                    lText = InputData
                End If
                lCR = InStr(s, vbCr)
                lLF = InStr(s, vbLf)
                lCL = InStr(s, vbCrLf)
               
'                lText = Replace(Replace(Replace(lText, vbCrLf, vbLf), vbCr, vbLf), vbLf, vbCr)
                Print #2, lText
next_i:
            Loop
            
            Close #1
            Close #2
               
        Next
    End If

End Sub

2015年12月13日 (日)

VBA雑記帳1213_2

Sub ☆Iro_Henko_test()

'    Call ☆Iro_Henko(ActiveSheet, xlOff)
    Call ☆Iro_Henko(ActiveSheet, xlOn)

End Sub

Function ☆Iro_Henko(ByVal pWs, ByVal pFlg)
    Const cSetCol As String = "O"
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
   
    If pFlg = xlOff Then
'        Set rtn = pWs.Cells.Find(a)
        pWs.Range("A1").Select
        With Application.FindFormat.Interior
            .PatternColorIndex = xlAutomatic
            .Color = 12632256
            .TintAndShade = 0
            .PatternTintAndShade = 0
        End With
        Set rtn = pWs.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
            xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , MatchByte:=False, SearchFormat:=True)
       
        If Not rtn Is Nothing Then
            pWs.Cells(rtn.Row, cSetCol).Value = rtn.Address
            
            '灰色どこまでか横方向検索
            lCol = rtn.Column
            Do While pWs.Cells(rtn.Row, lCol).Interior.Color = 12632256
                lMaxAdd = pWs.Cells(rtn.Row, lCol).Address
                lCol = lCol + 1
            Loop
            pWs.Cells(rtn.Row, cSetCol).Value = pWs.Cells(rtn.Row, cSetCol).Value & ":" & lMaxAdd
            
            '灰色どこまでか縦方向検索
            lStAddress = rtn.Address
            Set rtn2 = rtn.Offset(1, 0)
            rtn2.Activate
            Do
               
                Set rtn2 = pWs.Cells.Find(What:="", After:=ActiveCell, LookIn:=xlFormulas, LookAt:= _
                xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
                , MatchByte:=False, SearchFormat:=True)
                If Not rtn2 Is Nothing Then
                    If rtn2.Address = lStAddress Then Exit Do
               
                    pWs.Cells(rtn2.Row, cSetCol).Value = rtn2.Address
                    '灰色どこまでか横方向検索
                    lCol = rtn2.Column
                    Do While pWs.Cells(rtn2.Row, lCol).Interior.Color = 12632256
                        lMaxAdd = pWs.Cells(rtn2.Row, lCol).Address
                        lCol = lCol + 1
                    Loop
                    pWs.Cells(rtn2.Row, cSetCol).Value = pWs.Cells(rtn2.Row, cSetCol).Value & ":" & lMaxAdd
                   
                   
                    Set rtn2 = rtn2.Offset(1, 0)
                    rtn2.Activate
            
                End If
            Loop
            
        End If
    Else
        lMax = pWs.Cells(65000, cSetCol).End(xlUp).Row
        For i = 1 To lMax
            i = pWs.Cells(i, cSetCol).End(xlDown).Row
               
            Do While i <= lMax
               
                With pWs.Range(pWs.Cells(i, cSetCol).Value).Interior
                    .Color = 12632256
                End With
                pWs.Cells(i, cSetCol).Value = ""
               
                i = pWs.Cells(i, cSetCol).End(xlDown).Row
            Loop
        Next
   
    End If
   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = False

End Function

VBA雑記帳1213

Sub ☆テキスト読み込み()
   
    fileOpenName = Application.GetOpenFilename("*.Textファイル (*.Txt), *.Txt", MultiSelect:=True, Title:="★★★ ファイル選択 ★★★")
   
    Application.Calculation = xlManual
    Application.ScreenUpdating = False
    If IsArray(fileOpenName) Then
        For fcnt = 1 To UBound(fileOpenName)
            
            'ファイル読み込み
            Workbooks.OpenText Filename:=fileOpenName(fcnt), Origin:=xlWindows, _
                StartRow:=1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
                ConsecutiveDelimiter:=True, Tab:=False, Semicolon:=False, Comma:=False _
                , Space:=False, Other:=False, FieldInfo:=Array(1, 2), _
                TrailingMinusNumbers:=True
            Set ActWb = ActiveWorkbook
            Set ActWs = ActWb.Sheets(1)
            
            Range("A11").Select
            Range(Selection, Selection.End(xlDown)).Select
            
            '分割
            Selection.TextToColumns Destination:=Range("A11"), DataType:=xlDelimited, _
                TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=False, _
                Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar _
                :="[", FieldInfo:=Array(Array(1, 2), Array(2, 2)), TrailingMinusNumbers:=True
            
            Range("B11").Select
            Range(Selection, Selection.End(xlDown)).Select
            
            '文字列置換
            Columns("B:B").Select
            Selection.Replace What:="SJIS]: ", Replacement:="", LookAt:=xlPart, _
                SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
                ReplaceFormat:=False
               
            lMax = ActWs.Cells(65000, "A").End(xlUp).Row
            For i = 11 To lMax - 1
                lPath = ActWs.Cells(i, "A").Value
                lSp1 = InStrRev(lPath, "\")
                lSp2 = InStrRev(lPath, "\", lSp1 - 1)
                ActWs.Cells(i, "C").Value = "'" & Replace(Mid(ActWs.Range("A2").Value, InStr(ActWs.Range("A2").Value, """")), """", "")
                ActWs.Cells(i, "D").Value = ActWs.Name
                ActWs.Cells(i, "F").Value = Mid(lPath, lSp1 + 1)
                ActWs.Cells(i, "F").Value = Mid(ActWs.Cells(i, "F").Value, 1, InStr(ActWs.Cells(i, "F").Value, "(") - 1)
                ActWs.Cells(i, "E").Value = Mid(lPath, lSp2 + 1, lSp1 - lSp2 - 1)
                If i = 75 Then
                    xxxx = 1
                End If
                lVal = StrConv(ActWs.Cells(i, "B").Value, vbLowerCase)
                lKen = StrConv(ActWs.Cells(i, "C").Value, vbLowerCase)
                lLenMax = Len(ActWs.Cells(i, "B").Value)
                lLen = Len(ActWs.Cells(i, "C").Value)
                For j = 1 To lLenMax
                    lSp3 = InStr(j, lVal, lKen)
                    If lSp3 <> 0 Then
                        With ActWs.Cells(i, "B").Characters(Start:=lSp3, Length:=lLen).Font
                            .ColorIndex = 3
                        End With
                        j = lSp3
                    Else
                        Exit For
                    End If
                Next

            Next
            Application.ReferenceStyle = xlA1
            ActWs.Range("G9").Formula = "=COUNTIF(G11:G" & lMax & ",""○"")"
            With ActWs.Range("G9").Interior
                .Color = 65535
            End With
            With ActWs.Range("G9").Font
                .Color = -16776961
            End With
            

            ActWs.Range("C10:G10") = Array("検索条件", "修正No", "抽出フォルダ", "抽出ファイル名", "判定")
            Columns("C:G").Select
            Columns("C:G").EntireColumn.AutoFit
            
        Next
'        MsgBox "処理が完了しました。"
    End If

    Set ActWb = Nothing
    Set ActWs = Nothing
   

   
    Application.Calculation = xlAutomatic
    Application.ScreenUpdating = False

End Sub

2010年11月 6日 (土)

▲VBScript(複数のIEを一気に終了する)

VBスクリプトネタ第2弾です。
最近IEを一気にたくさん開いておこなう作業が多くて、終了する際に一画面一画面閉じていたのですが
いい加減面倒くさくなったので一気に閉じるVBSを作成してみました。
IEにはWordのように一気に閉じる機能がないようなので自作しました。
テキストエディタに張り付けて、ショートカットファイルをツールバーの「クイック起動」に置いておけば、即座
にIEを終了することができます。お試しあれ。
ほぼこのままVBAにしても実行できます。

Option Explicit

Dim lVal
Dim oWinS
Dim objShell
Dim objWindowsShell

Set objShell = CreateObject("Shell.Application")
Set objWindowsShell = objShell.Windows()

Dim a
Dim i
ReDim a(0)
For Each oWinS In objWindowsShell
    If InStr(LCase(oWinS.FullName), "iexplore.exe") > 0 Then
        i = i + 1
        ReDim Preserve a(i)
        Set a(i) = oWinS
    End If
Next
For i = 1 To UBound(a)
    a(i).Quit
Next

Set oWinS = Nothing
Set objShell = Nothing
Set objWindowsShell = Nothing
WScript.Quit

2010年2月21日 (日)

▲VBScript(文字列をクリップボードへコピー)

 VBScriptネタ初投稿です。
 今、VBScriptでいろいろツールを作成しているのですが、VBScript初心者の私にとってはVBAと同じなようで結構違いがあって戸惑っています。メーラーに文字列をSendKeysで流し込もうとしたのですが全角文字が文字化けしてしまいます。そこでクリップボード経由で貼り付けようとしたのですがVBScriptはクリップボードが不得手のようですね。
 クリップボード使用方法として世間ではIEオブジェクトを利用したりInputBoxを利用したりといったサンプルが花盛りのようです。詳細は紹介サイトを検索していただきたいのですが、IEはセキュリティの問題があったり、InputBoxはVBScript単体で処理できる利点がありますが一瞬画面が表示されるのが残念です。
 万人向けではありませんが、Excelを持っている方(特に会社では有効だと思いますが)向けに以下の方法を考えてみました。どうでしょうか?
 実際はメーラーを想定していますが、このサンプルはエクスプローラを起動してアドレス欄に文字列を貼り付けるものです。毎回Excelオブジェクトを生成しては削除する構造はちょっといかがなものかなと思いますがまぁそこは大目に見てやってくださいね。Sleepタイムは皆様のPCに合わせて調整してみてください。

option explicit

Dim arg,wsh
set wsh = CreateObject("WScript.Shell")

arg="進捗状況" & Mid(Replace(FormatDateTime(Now, 1),"/",""),3)

'クリップボードに文字列コピー
Call RangeCopy( arg )
WScript.sleep 300

'エクスプローラに貼り付け
wsh.run "c:\windows\explorer.exe"
WScript.sleep 800
wsh.sendkeys "{TAB 2}"
WScript.sleep 300
wsh.sendkeys "^v"

set wsh = Nothing
WScript.Quit

'#########################################
'# クリップボードに文字列コピー
'#
'# 引数 arg:対象文字列
'# 戻り値 なし
'#########################################
Public Sub RangeCopy( arg )
Dim oExl,oWb
set oExl = WScript.CreateObject("Excel.Application")
set oWb = oExl.WorkBooks.Add()

With oExl.Sheets(1).Range("A1")
.value = arg
.copy
End With

oExl.DisplayAlerts = False
oWb.close
oExl.Quit
set oWb = Nothing
set oExl = Nothing

End Sub