Office TANAKA - Excel VBA関数[目次]
Microsoft.VisualBasic 名前空間
VBAのヘルプで、このページは利用できません。と表示される :Office 2010(オフィス2010)の使い方
☆ Excelでお仕事!(Excel全般の解説サイト) ☆
テストエビデンス取得自動化の秘技(前編):Selenium VBAを使って自動でブラウザーを操作してスクショをExcelに張り付けてみた (1/4) - @IT


  1. VBAパスワードロックされたExcelファイルを開く。
  2. 次にxlsmファイルを新規作成する。
  3. xlsmファイルのVBAを開く。
  4. 標準モジュールにModule1を作成し以下のコードをコピペする。
Option Explicit


Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
(Destination As Long, Source As Long, ByVal Length As Long)

Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
ByVal lpProcName As String) As Long

Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean

Private Function GetPtr(ByVal Value As Long) As Long
GetPtr = Value
End Function

Public Sub RecoverBytes()
If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub

Public Function Hook() As Boolean
Dim TmpBytes(0 To 5) As Byte
Dim p As Long
Dim OriginProtect As Long

Hook = False

pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")

If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then

MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
If TmpBytes(0) <> &H68 Then

MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6

p = GetPtr(AddressOf MyDialogBoxParam)

HookBytes(0) = &H68
MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
HookBytes(5) = &HC3

MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
Flag = True
Hook = True
End If
End If
End Function

Private Function MyDialogBoxParam(ByVal hInstance As Long, _
ByVal pTemplateName As Long, ByVal hWndParent As Long, _
ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
If pTemplateName = 4070 Then
MyDialogBoxParam = 1
MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
hWndParent, lpDialogFunc, dwInitParam)
End If
End Function
  1. 同様にModule2を作成し、以下をコピペする。
Sub unprotected()
If Hook Then
MsgBox "VBA Project is unprotected!", vbInformation, "*****"
End If
End Sub
  1. unprotectedを実行。

メールドリブン outlookマクロ

Option Explicit

Private Sub Application_NewMailEx(ByVal EntryIDCollection As String)
Dim itm As Object
Dim msg As String
Dim IE As Object

Set itm = Application.Session.GetItemFromID(EntryIDCollection)
If LCase(TypeName(itm)) = "mailitem" Then
With itm.ReplyAll
    Set IE = CreateObject("InternetExplorer.Application")
    With IE
        .Navigate "http://lifework.hatenablog.com/category/VBA"
        .Visible = True
    End With
    Set IE = Nothing

End With
End If
End Sub


Option Explicit
Sub a()

Dim ie As Object
Set ie = CreateObject("InternetExplorer.Application")

ie.Visible = True
ie.Navigate ("http://www.google.co.jp/")

' ダウンロード待ち
Do While ie.Busy

' 結果出力
''Debug.Print ie.Document.Body.InnerHTML

Dim FileNumber As Integer
Dim Path As String

FileNumber = FreeFile
Path = "C:\eclipse\test.html"

Open Path For Output As #FileNumber

'' Print #FileNumber, "あいうえお";
Print #FileNumber, "取得日取得時";
Print #FileNumber, ie.Document.Body.InnerHTML;

Close #FileNumber

Set ie = Nothing
End Sub