#ls2

リンク

連想配列

  • Dictionary オブジェクトが連想配列として使える。

    <%@ language="VBScript" %>
    <%
        ' HashTable.asp
        Dim HashTable
        Set HashTable = CreateObject("Scripting.Dictionary")
        HashTable.add "key1", "value1"
        HashTable.Item("key2") = "value2"
    
        Response.ContentType = "text/plain"
        Response.Charset = "Shift_JIS"
        Response.Expires = -1
    
        Response.write "key1: " & HashTable.Item("key1") & vbCRLF
        Response.write "key2: " & HashTable.Item("key2") & vbCRLF
    %>
    
  • 既に存在するキーに対して、addメソッドを使うとエラーとなるが、Itemプロパティを使った場合には警告なく置き換えられる。

環境変数

  • 環境変数を読み出すにはRequestオブジェクトServerVariablesコレクションを読み出せばよい。

    Browser = Request.ServerVariables ( "HTTP_USER_AGENT" )
    
    <html>
    <%@ language="VBScript" %>
    <!-- printEnv.asp -->
    <body>
    <table border="1">
    <tr><th>Server Variable</th><th>Value</th></tr>
    <% For Each strKey In Request.ServerVariables %>
    <tr><td><%= strKey %></td><td><%= Request.ServerVariables(strKey) %></td></tr>
    <% Next %>
    </table>
    </body>
    </html>
    

FileSystemObjectオブジェクト

Webからのダウンロード

  • IXMLHTTPRequestオブジェクトを使って、指定したURIをダウンロードして表示する。

    TinyProxy.asp?URI=http://xxx〜
    
  • charsetを返さないサーバに対して使用すると文字化けする。

    <%@ language="VBScript" %>
    <!-- #include File="adovbs.inc" -->
    <%
        ' TinyProxy.asp
    
        Response.ContentType = "text/html"
        Response.Charset = "Shift_JIS"
        Response.Expires = -1
    
        Dim sHTML
        sHTML = getURL( Request.QueryString("URI") )
        Response.Write sHTML
    
    ''''''''
    
        Function getURL( sURL )
            Dim oXMLHTTP, sHTML, sEncoding
            Set oXMLHTTP = Server.CreateObject("MSXML2.XMLHTTP")
    
            oXMLHTTP.Open "GET", sURL, False
            oXMLHTTP.Send
            sHTML = oXMLHTTP.responseBody
            sEncoding = oXMLHTTP.getResponseHeader("Content-type")
    
            Dim oRegExp
            Set oRegExp = New RegExp
            oRegExp.Pattern = ".*\s*charset=(.*)\s*"
            oRegExp.IgnoreCase = True
            oRegExp.Global = True
            If oRegExp.Test(sEncoding) Then
                sEncoding = oRegExp.Replace( sEncoding, "$1" )
            Else
                sEncoding = "Shift_JIS"
            End If
            Set oRegExp = Nothing
    
            Dim oStream
            Set oStream = Server.CreateObject("ADODB.Stream")
            oStream.Open
            oStream.Type = adTypeBinary
            oStream.Write sHTML
            oStream.Position = 0
            oStream.Type = adTypeText
            oStream.Charset = sEncoding
            getURL = oStream.ReadText()
            oStream.Close
            Set oStream = Nothing
    
            Set oXMLHTTP = Nothing
        End Function
    %>
    
  • (参考) ダウンロードしたHTMLを加工しない場合

    Dim oXMLHTTP
    Set oXMLHTTP = Server.CreateObject("MSXML2.XMLHTTP")
    
    oXMLHTTP.Open "GET", sURL, False
    oXMLHTTP.Send
    Response.BinaryWrite oXMLHTTP.responseBody
    
  • WSHで作るRSSアグリゲータ

Excel からの CSV(K3フォーマット) 書き出し

SaveAsK3.bas

 Attribute VB_Name = "Module1"
 Private Const g_cnsDQ = """"
 Private Const g_cnsSQ = "'"
 Private Const g_cnsSH = "#"
 
 Private Const g_cnsEXT = ".txt"     ' 拡張子
 
 Sub SaveAsK3_csv()
     Call SaveAsK3(",", ".csv")
 End Sub
 
 Sub SaveAsK3(Optional separator As String = vbTab, Optional extension As String = g_cnsEXT)
 Attribute SaveAsK3.VB_Description = "すべてのシートをCSVとして書き出します。\n文字列は「""」でくくり、数値と日付はそのまま出力します。"
     Dim fh As Long                  'ファイルハンドル
     Dim myData As Range             'データ領域格納
     Dim myRecord As String          '出力するデータ(1行)
     Dim myField As String           '出力するデータ(1フィールド)
     Dim dataval As Variant          'データの値
     Dim datatype As String          'データの型
     Dim path As String              '出力パス
     Dim filename As String          '出力ファイル名
     Dim filenames As String         '出力ファイル名のリスト
     
     Dim w As Worksheet
     Dim i As Long, j As Long
     
     If ActiveWorkbook.path <> "" Then
         path = ActiveWorkbook.path & Application.PathSeparator
     Else
         path = CurDir & Application.PathSeparator
     End If
     filenames = ""
     
     For Each w In Worksheets
         'CSVファイル作成 (既存ファイルは上書き)
         filename = w.Name & extension
         fh = FreeFile
         Open path & filename For Output As #fh
         filenames = filenames & vbNewLine & filename
         'A1から始まる全データ範囲取得
         Set myData = w.Range("A1").CurrentRegion
         
         '範囲内の全行数ループ
         For i = 1 To myData.Rows.Count
             myRecord = ""
             '範囲内の1行ループ
             For j = 1 To myData.Columns.Count
                 dataval = myData(i, j).Value
                 datatype = TypeName(dataval)
                 ' 文字列は「"」でくくる
                 If datatype = "String" Then
                     myField = g_cnsDQ & dataval & g_cnsDQ
                 ' 日付はそのまま
                 ElseIf datatype = "Date" Then
                     'myField = g_cnsSH & dataval & g_cnsSH
                     myField = dataval
                 ' その他(Double,Empty,...)はそのまま
                 Else
                     myField = dataval
                 End If
                 
                 'データ格納
                 If j = 1 Then
                     '最初のデータ
                     myRecord = myField
                 Else
                     myRecord = myRecord & separator & myField
                 End If
             Next j
             
             'テキストファイル出力
             If myRecord <> "" Then
                 Print #fh, myRecord
             End If
         Next i
         Close #fh
     Next w
     MsgBox "ワークシートを書き出しました。" & vbNewLine & path & filenames, vbOKOnly, "処理終了"
     
     '変数開放
     Set dataval = Nothing
     Set myData = Nothing
 End Sub

ThisWorkbook.cls

 VERSION 1.0 CLASS
 BEGIN
   MultiUse = -1  'True
 END
 Attribute VB_Name = "ThisWorkbook"
 Attribute VB_GlobalNameSpace = False
 Attribute VB_Creatable = False
 Attribute VB_PredeclaredId = True
 Attribute VB_Exposed = True
 Private Const g_cnsMenuName = "SaveAsK3"
 
 Private Sub Workbook_AddinInstall()
     On Error Resume Next
     Call Workbook_AddinUninstall
     Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
     Menu.Caption = g_cnsMenuName
     Set SubMenu1 = Menu.Controls.Add
     SubMenu1.Caption = "すべてのワークシートをタブ区切りファイルとして保存"
     SubMenu1.OnAction = "SaveAsK3"
     Set SubMenu2 = Menu.Controls.Add
     SubMenu2.Caption = "すべてのワークシートをカンマ区切りファイルとして保存"
     SubMenu2.OnAction = "SaveAsK3_csv"
 End Sub
 
 Private Sub Workbook_AddinUninstall()
     On Error Resume Next
     Application.CommandBars("Worksheet Menu Bar").Controls(g_cnsMenuName).Delete
 End Sub

Excel AddIn 作成のメモ

  • マクロの本体は「標準モジュール」に記述する。
  • メニューバーへの追加・削除イベントハンドラは「ThisWorkBook」に記述する。
  • 「ThisWorkBook」のプロパティの「IsAddin」を「True」にするとアドインとして認識される。
    「False」にすると通常のExcelファイルとして編集できる。(保護されていない場合)
  • プロジェクト名を「VBAProject」から変更しない。変更するとモジュール内の関数を見つけられなくなる。
  • アドインの保存場所
    %AppData%\Microsoft\AddIns

VBE.png

正規表現にマッチする部分を強調するアドイン

  • HighlightRegEx.zip
    • HighlightRegEx.bas
      Attribute VB_Name = "Module1"
      Private Const defaultPattern = "\*[^\*]+\*"
      
      Sub HighlightRegEx()
        Dim pattern As String
        Dim selectedCells As Range
        Dim currentColor, selectedColor
        Dim isSetColor As Boolean
        Dim regEx, match
        Dim cell As Range
        pattern = InputBox("RegEx", "Highlight RegEx", defaultPattern)
        If pattern = "" Then
          Exit Sub
        End If
        Set selectedCells = Selection
        Selection(1).Select
        currentColor = Selection.Interior.color
        isSetColor = Application.Dialogs(xlDialogPatterns).Show
        selectedColor = Selection.Interior.color
        Selection.Interior.color = currentColor
        selectedCells.Select
        If isSetColor = False Then
          Exit Sub
        End If
        Set regEx = CreateObject("VBScript.RegExp")
        regEx.pattern = pattern
        regEx.Global = True
        For Each cell In selectedCells
          Set match = regEx.Execute(cell)
          If (match.Count > 0) Then
            For i = 0 To match.Count - 1
              cell.Characters(Start:=match(i).FirstIndex + 1, Length:=match(i).Length).Font.color = selectedColor
            Next
          End If
        Next cell
      End Sub
    • HighlightRegEx.cls
      VERSION 1.0 CLASS
      BEGIN
        MultiUse = -1  'True
      END
      Attribute VB_Name = "ThisWorkbook"
      Attribute VB_GlobalNameSpace = False
      Attribute VB_Creatable = False
      Attribute VB_PredeclaredId = True
      Attribute VB_Exposed = True
      
      Private Const g_cnsMenuName = "Highlight RegEx"
      
      Private IsOffice15 As Boolean
      
      Private Sub Workbook_AddinInstall()
          On Error Resume Next
          Call Workbook_AddinUninstall
          Call AddToolBar
          If Application.Version >= 15 Then
              IsOffice15 = True
          End If
      End Sub
      
      Private Sub Workbook_Open()
          If IsOffice15 = True Then
              Call AddToolBar
          End If
      End Sub
      
      Private Sub AddToolBar()
          Set Menu = Application.CommandBars("Worksheet Menu Bar").Controls.Add(Type:=msoControlPopup)
          Menu.Caption = g_cnsMenuName
          Set SubMenu1 = Menu.Controls.Add
          SubMenu1.Caption = "Highlight parts matching with RegEx pattern in selection"
          SubMenu1.OnAction = "HighlightRegEx"
      End Sub
      
      Private Sub Workbook_AddinUninstall()
          On Error Resume Next
          Application.CommandBars("Worksheet Menu Bar").Controls(g_cnsMenuName).Delete
      End Sub

リンク

指定範囲を文字列として連結する関数

リンク

Excel VBA でプラットフォーム情報の取得

 Sub showPlatform()
     Dim myOS As String
     Dim myVer As String
     myOS = Application.OperatingSystem
     myVer = Application.Version
     MsgBox "OS: " & myOS & vbNewLine & "Excel Version: " & myVer, vbOKOnly
 End Sub

Excel VBA で XML の読み取り

準備

  • Visual Basic Editor の「メニュー - ツール - 参照設定」で「Microsoft XML」にチェックを入れる。
    LibRefXML.png

ソース

  • LoadXML.zip
     Attribute VB_Name = "Module1"
     ' 初心者のための XML DOM ガイド
     ' http://msdn.microsoft.com/ja-jp/library/aa468547.asp
     
     Function LoadXML(Xml As String) As String
         Dim xDoc As MSXML2.DOMDocument
         Set xDoc = New MSXML2.DOMDocument
         xDoc.validateOnParse = False
         If xDoc.LoadXML(Xml) Then
             ' ドキュメントの読み込みに成功しました。
             ' 目的の作業を行います。
             LoadXML = ReadNode(xDoc.childNodes, 0)
             If Right(LoadXML, Len(vbCrLf)) = vbCrLf Then
                 LoadXML = Left(LoadXML, Len(LoadXML) - Len(vbCrLf))
             End If
         Else
             ' ドキュメントに読み込みに失敗しました。
             Dim xPE As MSXML2.IXMLDOMParseError
             Set xPE = xDoc.parseError
             With xPE
                 LoadXML = "エラー # : " & .errorCode & ": " & xPE.reason & _
                 "行 #: " & .Line & vbCrLf & _
                 "行位置 : " & .linepos & vbCrLf
             End With
             Set xPE = Nothing
         End If
         Set xDoc = Nothing
     End Function
     
     Function ReadNode(ByRef Nodes As MSXML2.IXMLDOMNodeList, ByVal Indent As Integer) As String
         ReadNode = ""
         Dim xNode As MSXML2.IXMLDOMNode
     
         For Each xNode In Nodes
             If xNode.nodeType = NODE_TEXT Then
                 ReadNode = ReadNode & Space$(Indent) & xNode.parentNode.nodeName & ": " & xNode.nodeValue & vbCrLf
                 'ReadNode = ReadNode & xNode.parentNode.nodeName & ":" & xNode.nodeValue & vbCrLf
             End If
     
             If xNode.hasChildNodes Then
                 ReadNode = ReadNode & ReadNode(xNode.childNodes, Indent + 2)
             End If
         Next xNode
     End Function

リンク

Access ファイル中のテーブルを列挙する

概要

  • Access ファイル(.mdb/.accdb)中のテーブル一覧を出力する。
  • ファイル名に加えてテーブル名も指定したときは、そのテーブルのカラム情報を出力する。

ソース

  • showTables.zip
    ' Access ファイル中のテーブルを列挙する。
    ' http://hardsoft.at.webry.info/200908/article_6.html
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms681520.aspx
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms678060.aspx
    ' http://msdn.microsoft.com/en-us/library/windows/desktop/ms675318.aspx
    
    Option Explicit
    Dim arg : Set arg = WScript.Arguments
    If arg.Count = 0 Then
    	WScript.Echo "引数に mdb または accdb ファイル を指定してください"
    	WScript.Quit
    End If
    
    Dim cn, cat, mdbfile
    mdbfile = arg(0)
    Set cn  = CreateObject("ADODB.Connection")
    With cn
    	mdbfile = trim(mdbfile)
    	If right(mdbfile,4) = ".mdb" Then
    		.Provider = "Microsoft.Jet.OLEDB.4.0"
    	ElseIf right(mdbfile,6) = ".accdb" Then
    		.Provider = "Microsoft.ACE.OLEDB.12.0"
    	End If
    	.Properties("Data Source") = mdbfile
    End With
    cn.Open
    
    Set cat = CreateObject("ADOX.Catalog")
    cat.ActiveConnection = cn
    
    Dim table, tablename, column, datatype, sTypename
    Select Case (arg.Count)
    Case 1
    	'WScript.Echo "Name" & vbTab & "Type"
    	For Each table In cat.Tables
    		If table.Type = "TABLE" Then
    			'WScript.Echo table.Name & vbTab & table.Type
    			WScript.Echo table.Name
    		End If
    	Next
    Case 2
    	Set datatype = CreateObject("Scripting.Dictionary")
    	datatype.add   2, "SmallInt"
    	datatype.add   3, "Integer"
    	datatype.add   5, "Double"
    	datatype.add   6, "Currency"
    	datatype.add   7, "DateTime"
    	datatype.add  11, "Boolean"
    	datatype.add  12, "Variant"
    	datatype.add  14, "Decimal"
    	datatype.add 200, "VarChar"
    	datatype.add 201, "LongVarChar"
    	datatype.add 202, "VarWChar"
    	datatype.add 203, "LongVarWChar"
    
    	tablename = arg(1)
    	WScript.Echo "Name" & vbTab & "Type" & vbTab & "Size"
    	Set table = cat.Tables(tablename)
    	For Each column In table.Columns
    		sTypename = column.Type
    		If datatype.Exists(sTypename) Then sTypename = datatype(sTypename)
    		WScript.Echo column.Name & vbTab & sTypename & vbTab & column.DefinedSize
    	Next
    End Select
    
    cn.Close
    
    ' EOF

リンク

データベース

VBScript/Databaseを参照。

Base64 エンコード/デコード

BASE64のサンプルコード