VBA Script OLE Example

Sub IEWait(objIE As Object)
t = Timer
While objIE.Busy Or objIE.readyState <> 4
If Timer - t > 30 Then '30秒であきらめる
MsgBox "タイムアウトしました"
End
End If
Wend
End Sub

'IE Example
Sub Translate()
'Dim objIE As InternetExplorer
Dim objIE As Object
Dim RngURL As Range
Dim RngText As Range

On Error Resume Next
MsgBox "回線の状況により、処理に2分程度かかることがあります。"
Set RngURL = Range("ExciteURL")
Set RngText = Range("英文和訳")
RngText.Columns(2).ClearContents
Set objIE = CreateObject("InternetExplorer.Application")
'objIE.Visible = True
yURL = RngURL
With objIE
.Navigate yURL
Call IEWait(objIE)
End With
For i = 1 To 5
If RngText(i, 1).Value = "" Then Exit For
With objIE.Document.all
Set tmp = .Item("start")
.Item("before")(0).Value = RngText(i, 1).Value
.Item("start").Click
End With
Call IEWait(objIE)
RngText(i, 2).Value = objIE.Document.all.Item("after")(0).Value
Next
objIE.Quit
Errorexists = (Error() <> "")
On Error GoTo 0
If Errorexists Then
MsgBox "何らかの原因で正常に処理できませんでした"
Else
MsgBox "正常に処理が終了しました"
End If
End Sub


Sub FMJExample()
On Error Resume Next
'FMJのオブジェクトの変数
Dim FMAP As New FMPRO50Lib.Application
'Dim FMAP As Object
'Dim Docs As FMPRO50Lib.Documents
Dim Docs As Object
'Dim Doc As FMPRO50Lib.Document
Dim Doc As Object

'普通の変数
Dim RngFileName As Range
Dim RngScriptName As Range
Dim RngResult As Range
Dim tarDir As String
Dim t As Double

On Error Resume Next
'変数初期化
Set FMAP = CreateObject("FMPRO50Lib.Application")
Set Docs = FMAP.Documents
Set RngFileName = Range("ファイル名")
Set RngScriptName = Range("スクリプト名")
Set RngResult = Range("実行結果")
tarDir = ThisWorkbook.Path
RngResult.ClearContents

'FMJ開いてスクリプト実行して閉じる
FMAP.Visible = True
For i = 1 To 10
t = Timer
If RngFileName(i) = "" Then Exit For
'FMJ開く
On Error Resume Next
Set Doc = Docs.Open(tarDir & "\" & RngFileName(i), "")
Doc.Activate
ErrExists = (Error() <> "")
On Error GoTo 0
If ErrExists Then
RngResult(i, 2) = "ファイルがありません"
Else

'スクリプト実行
Doc.DoFMScript (RngScriptName(i))
If FMAP.ScriptStatus = 0 Then
RngResult(i, 2) = "スクリプトがありません"
Else
'スクリプトが終わるまで待つ
While FMAP.ScriptStatus <> 0
Wend

'閉じる
Doc.Close
End If
End If
RngResult(i, 1) = Timer - t
Next
FMAP.Quit
Errorexists = (Error() <> "")
On Error GoTo 0
If Errorexists Then
MsgBox "Error" & Errorexists
Else
MsgBox "Finished Successfully"
End If
End Sub

' Outlook Example
Sub GetSbj()
Dim olApp As Object
Dim NameSpc As Object
'Dim Fldr As Outlook.MAPIFolder
Dim Fldr As Object
'Dim mailitem As Outlook.mailitem
Dim mailitem As Object
Dim Rng As Range

On Error Resume Next
Set olApp = CreateObject("outlook.application")
Set NameSpc = olApp.GetNamespace("MAPI")
Set Fldr = NameSpc.GetDefaultFolder(6) '6=olFolderInbox:受信フォルダ
Set Rng = Range("SbjOut")
Rng.ClearContents
i = 1
For Each mailitem In Fldr.Items
Rng(i, 1) = mailitem.Subject
i = i + 1
If i > 5 Then Exit For
Next

Errorexists = (Error() <> "")
On Error GoTo 0
If Errorexists Then
MsgBox "Error" & Errorexists
Else
MsgBox "Finished Successfully"
End If
End Sub