~~#ls2~~

リンク

連想配列

<%@ 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オブジェクト

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.zip
アクティブなブックのすべてのシートをCSV(K3フォーマット)として書き出します。
ファイル名は、タブ区切りの場合は「シート名」+「.txt」、カンマ区切りの場合は「シート名」+「.csv」となります。
文字列は「"」でくくり、数値と日付はそのまま出力します。
書式設定が「文字列」になっているセルは、内容が数値/日付であってもダブルクォーテーションでくくられます。
既存ファイルは警告なしで上書きされます。
実行手順: メニューの「SaveAsK3」から「すべてのワークシートをタブ区切りファイルとして保存」または「すべてのワークシートをカンマ区切りファイルとして保存」を選択します。
表はA1から始まって連続している必要があります。
空行があるとその下は出力されません。
Win/Mac両対応
2008/05/29修正
- CSVではなくTSV(タブ区切り)をデフォルトにしました。
- 出力したパスとファイル名をレポートするようにしました。
- アドインとして使えるようにしました。アドインとして登録すると、メニューに「SaveAsK3」という項目が増えます。
2008/06/03修正
- メニューから、TSVかCSVかを選べるようにしました。
RFC 4180 - Common Format and MIME Type for Comma-Separated Values (CSV) Files
WikiPedia.ja:Comma-Separated_Values
Access Home Page by pPoy / 全シートをシート別に CSV ファイルとして出力
Excelでお仕事！ / 自由設定のCSVファイル出力
だるまのエクセルVBA / Microsoft Excel X for MacのVBAについて
Java：CSVパーサを作る（その２） - RFC4180対応前編: 愛ゆえにプログラムは美しい 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
```

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

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

リンク

Office TANAKA / Excel VBA Tips
Excel 2013のアドイン設定について - マイクロソフトコミュニティ
- Excel 2013 にて、追加したアドインが Excel 再起動後に消えていることへの対処方法。

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

JoinRangeText

リンク

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」にチェックを入れる。

ソース

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

リンク

連想配列

環境変数

FileSystemObjectオブジェクト

Webからのダウンロード

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

Excel AddIn 作成のメモ

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

リンク

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

リンク

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

Excel VBA で XML の読み取り

準備

ソース

リンク

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

概要

ソース

リンク

データベース

Base64 エンコード/デコード