Dee's WebLOG

コントロール配列かどうかを判別

Dee — 2004-06-10T21:11:54+09:00

Private Sub Form_Load()
Dim ctl As Control
For Each ctl In Me.Controls
    If TypeName(Controls(ctl.Name)) = "Object" Then
        Debug.Print ctl.Name & "(" & CStr(ctl.Index) & ")"
    Else
        Debug.Print ctl.Name
    End If
Next ctl
End Sub

'別解
Function iscontrolarray(ctl As Control) As Boolean
On Error GoTo iscontrolarray_err
    Dim i As Long
    i = ctl.Index
    iscontrolarray = True
Exit Function
iscontrolarray_err:
If Err.Number = 343 Then
    iscontrolarray = False
End If
End Function

FileSystemObjectフォルダ再帰検索

Dee — 2004-06-06T16:30:44+09:00

Option Explicit

Private Sub Command1_Click()

Dim fs As Object, fld As Object

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set fld = fs.GetFolder("C:\TEMP")

    DispFolders fld

    Set fld = Nothing

    Set fs = Nothing

End Sub

Private Sub DispFolders(oFolder As Object)

    Dim oSubFolder As Object

    Debug.Print oFolder.Path

    For Each oSubFolder In oFolder.SubFolders

        DispFolders oSubFolder

    Next

End Sub

ファイルのバージョン情報を取得

Dee — 2003-12-13T17:45:26+09:00

' ファイルのバージョン情報を取得
Option Explicit
Type VS_FIXEDFILEINFO
dwSignature As Long
dwStrucVersionl As Integer
dwStrucVersionh As Integer
dwFileVersionMSl As Integer
dwFileVersionMSh As Integer
dwFileVersionLSl As Integer
dwFileVersionLSh As Integer
dwProductVersionMSl As Integer
dwProductVersionMSh As Integer
dwProductVersionLSl As Integer
dwProductVersionLSh As Integer
dwFileFlagsMask As Long
dwFileFlags As Long
dwFileOS As Long
dwFileType As Long
dwFileSubtype As Long
dwFileDateMS As Long
dwFileDateLS As Long
End Type

Type CODEPAGE
lngLOW As Integer
lngHIGH As Integer
End Type

Declare Function GetFileVersionInfo Lib "Version.dll" Alias
"GetFileVersionInfoA" ( _
ByVal lptstrFilename As String, _
ByVal dwHandle As Long, _
ByVal dwLen As Long, _
lpData As Any) As Long

Declare Function GetFileVersionInfoSize Lib "Version.dll" Alias
"GetFileVersionInfoSizeA" ( _
ByVal lptstrFilename As String, _
lpdwHandle As Long) As Long

Declare Function VerQueryValue Lib "Version.dll" Alias "VerQueryValueA" ( _
pBlock As Any, _
ByVal lpSubBlock As String, _
lplpBuffer As Any, _
puLen As Long) As Long

Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" ( _
dest As Any, _
ByVal Source As Long, _
ByVal length As Long)

Function GetFileVer(exename As String) As String

'"Comments"'コメント
'"CompanyName"'社名
'"FileDescription"'説明
'"FileVersion"'ファイルバージョン
'"InternalName"'内部名
'"LegalCopyright"'著作権
'"LegalTrademarks"'商標
'"OriginalFilename"'正式ファイル名
'"PrivateBuild"'プライベートビルド情報
'"ProductName"'製品名
'"ProductVersion"'製品バージョン
'"SpecialBuild"'スペシャルビルド情報

Dim lngRet As Long
Dim lngDummy As Long
Dim bBuffer() As Byte
Dim lngLen As Long
Dim lpbuffer As Long
Dim ffi As VS_FIXEDFILEINFO
Dim strFileName As String
GetFileVer = ""
' strFileName に取得したいファイル名をセット
strFileName = exename

' サイズを取得
lngLen = GetFileVersionInfoSize(strFileName, lngDummy)
If lngLen < 1 Then
Exit Function
End If

' バイトの配列の領域取得
ReDim bBuffer(lngLen)

' ファイルバージョン情報を取得
lngRet = GetFileVersionInfo(strFileName, 0&, lngLen, bBuffer(0))
lngRet = VerQueryValue(bBuffer(0), "\", lpbuffer, lngLen)

' バイトの処理
MoveMemory ffi, lpbuffer, Len(ffi)

' ファイルバージョン
GetFileVer = _
Format$(ffi.dwFileVersionMSh) & "." & _
Format$(ffi.dwFileVersionMSl) & _
Format$(ffi.dwFileVersionLSh) & "." & _
Format$(ffi.dwFileVersionLSl, "0000")

' ' 製品バージョン
' Debug.Print "ProductVersion = " & _
' Format$(ffi.dwProductVersionMSh) & "." & _
' Format$(ffi.dwProductVersionMSl) & "." & _
' Format$(ffi.dwProductVersionLSh) & "." & _
' Format$(ffi.dwProductVersionLSl)

End Function

レジストリの書き込み（WSH）

Dee — 2003-12-13T17:44:49+09:00

'レジストリの書き込み（WSH）
Set WSHShell = CreateObject("WScript.Shell")
WSHShell.RegWrite "HKEY_LOCAL_MACHINE\SOFTWARE\MICROSOFT\Jet\
3.5Engines\Debug\JETSHOWPLAN", "ON", "REG_SZ"
Set WSHShell = Nothing

レジストリの読み込み（WSH）

Dee — 2003-12-13T17:44:19+09:00

'レジストリの読み込み（WSH）
Function WSHRegRead(strKey As String)
Dim objWshShell As Object
Set objWshShell = CreateObject("WScript.Shell")
WSHRegRead = objWshShell.RegRead(strKey)
Set objWshShell = Nothing
End Function

?WSHRegRead("HKEY_LOCAL_MACHINE\Software\Netscape\Netscape Navigator\CurrentVersion")
4.75 (ja)

デスクトップへショートカットを作成する。

Dee — 2003-12-13T17:43:49+09:00

'デスクトップへショートカットを作成する。

WSH。
http://www.remus.dti.ne.jp/~y-mac/teclib/shortcut.htm
'フォーム上に必要なコントロール
'CommandButton1
'---------------------------------------------------------------------------
--------------------------
Private Sub Command1_Click()

　　Dim objWSSh As Object
　　Dim objCSCt As Object
　　Dim strDeskTop As String

　　Set objWSSh = CreateObject("WScript.Shell")

　　'デスクトップへのパスを取得
　　strDeskTop = objWSSh.SpecialFolders("Desktop")

　　'ショートカットを作成
　　Set objCSCt = objWSSh.CreateShortcut(strDeskTop & "\" & "電卓" & ".lnk")
　　objCSCt.TargetPath = "C:\WINNT\system32\CALC.EXE"
　　objCSCt.Save

　　MsgBox "電卓のショートカットを" & vbCrLf & "デスクトップに作成しました"

End Sub

VB6STKIT.DLLのfCreateShellLink関数を使用。
Private Declare Function fCreateShellLink Lib "VB6STKIT.dll" _
(ByVal lpstrFolderName As String _
, ByVal lpstrLinkName As String _
, ByVal lpstrLinkPath As String _
, ByVal lpstrLinkArgs As String _
, ByVal fPrivate As Long _
, ByVal sParent As String)

ドライヴ容量取得

Dee — 2003-12-13T17:42:50+09:00

'ドライヴ容量取得
Sub ShowDriveLetter(drvPath)
Dim fs, d, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set d = fs.GetDrive(fs.GetDriveName(drvPath))
s = "ドライブ " & d.DriveLetter & ": - "
s = s & d.VolumeName & vbCrLf
s = s & "空き容量: " & FormatNumber(d.FreeSpace / 1024, 0)
s = s & " KB"
MsgBox s
End Sub

Line Input と　TextStreamではどっちが速い？

Dee — 2003-12-13T17:41:56+09:00

'Line Input と　TextStreamではどっちが速い？
Function TextStreamReadWrite_LateBind(FileName As String)
Dim fs As Object, a As Object, i As Long, r_data As String, t As Long
'10万件書き出し
Debug.Print nowtime(): t = GetTickCount
r_data = "This is a test."
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(FileName, True)
For i = 1 To 100000
a.WriteLine r_data & Format$("000000", i)
Next i
a.Close
Set a = Nothing
'10万件の行末までスキップ＆読み出し
Debug.Print nowtime(), GetTickCount
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.OpenTextFile(FileName, 1, 0)
For i = 1 To 99999
a.SkipLine
Next i
r_data = a.ReadLine
a.Close
Debug.Print nowtime(), GetTickCount - t
Set fs = Nothing
Set a = Nothing
End Function
Function TextStreamReadWrite_EarlyBind(FileName As String)
Dim fs As New FileSystemObject, a As TextStream, i As Long, r_data As String, t As Long
'10万件書き出し
Debug.Print nowtime(): t = GetTickCount
r_data = "This is a test."
Set a = fs.CreateTextFile(FileName, True)
For i = 1 To 100000
a.WriteLine r_data & Format$("000000", i)
Next i
a.Close
Set a = Nothing
'10万件の行末までスキップ＆読み出し
Debug.Print nowtime(), GetTickCount
Set a = fs.OpenTextFile(FileName, 1, 0)
For i = 1 To 99999
a.SkipLine
Next i
r_data = a.ReadLine
a.Close
Debug.Print nowtime(), GetTickCount - t
Set fs = Nothing
Set a = Nothing

End Function
Function LineInputReadWrite(FileName As String)
Dim i As Long, r_data As String, t As Long
'10万件書き出し
Debug.Print nowtime(): t = GetTickCount
r_data = "This is a test."
Open FileName For Output As #1
For i = 1 To 100000
Print #1, r_data & Format$("000000", i)
Next i
Close #1
'10万件の行末までスキップ＆読み出し
Debug.Print nowtime(), GetTickCount
Open FileName For Input As #1
For i = 1 To 99999
Line Input #1, r_data
Next i
Line Input #1, r_data
Close #1
Debug.Print nowtime(), GetTickCount - t
End Function

Whats WebLOG

Dee — 2003-12-06T22:48:44+09:00

実は、自宅サーバ（Linux）でMovable Typeなぞいじってみていて、
公開でもしようかな．．．と思っていた矢先、
@niftyさんでこんなの作ってくれちゃったので、
喜んで使ってみてみたりしてるワケです（＾＾；