Home of site
Macroの杜
(OpenOffice.org/LibreOffice Basic編)
General No.5
###【 Continued from General No.4 】###
**********************【 Index 】**********************
JavaScript
Python
VBScript
[ FileSystemObject ]
[ 正規表現 ](正規表現による Visual Basic Scripting Edition (VBScript) の機能強化)
[ WshShell ]
[ Shell.Application ]
[ WScript.Network ]
[ WbemScripting.SWbemLocator ]
[ MS-Office ]
{{ General }}
{{ Other }}
[ Internet Explorer ]
**********************【 Macro Code 】**********************
JavaScript
GJS-)[General]JavaScript Macro(1)
Sub oJavaScriptMacro
Dim oMSPF as Object
Dim oSP as Object
Dim oScript as Object
oMSPF = GetDefaultContext.getValueByName( "/singletons/com.sun.star.script.provider.theMasterScriptProviderFactory")
oSP = oMSPF.createScriptProvider("")
' JavaScript Macro
oScript = oSP.getScript("vnd.sun.star.script:Library1.Macro1.js?language=JavaScript&location=user")
' Macro実行
oScript.invoke( array(),array(),array())
End Sub
'
' [ JavaScript Macro ]
' マイマクロ/Library1/Macro1.js
'C:\Users\[UserName]\AppData\Roaming\LibreOffice\3\user\Scripts\javascript\Library1\Macro1.js
//
// Hello World in JavaScript
importClass(Packages.javax.swing.JOptionPane);
JOptionPane.showMessageDialog(null, "Hello World in JavaScript");
GJS-)[General]JavaScript Macro(2) / 他DocumentのMacro
Sub oJavaScriptMacro
Dim oSP as Object
Dim oScript as Object
oSP = ThisComponent.ScriptProvider
' JavaScript Macro
oScript = oSP.getScript("vnd.sun.star.script:Library1.Macro1.js?language=JavaScript&location=user")
' Macro実行
oScript.invoke( array(),array(),array())
End Sub
'
' [ JavaScript Macro ]
' マイマクロ/Library1/Macro1.js
'C:\Users\[UserName]\AppData\Roaming\LibreOffice\3\user\Scripts\javascript\Library1\Macro1.js
//
// Hello World in JavaScript
importClass(Packages.javax.swing.JOptionPane);
JOptionPane.showMessageDialog(null, "Hello World in JavaScript");
GJS-)[General]VBAのEvaluate関数
Sub oEvaluateofVBA
Dim oStrEval as Double
Dim oDisp as String
oStrEval = Eval("1.5+2.6")
oDisp = "[ VBAのApplication.Evaluate ]" & Chr$(10) & _
" Eval(""1.5+2.6"") = " & oStrEval
msgbox oDisp,0,"Evaluate関数"
End Sub
'
Function Eval(oString as String) as Double
Dim oSP as Object
Dim oScript as Object
oSP = ThisComponent.ScriptProvider
' JavaScript Macro
oScript = oSP.getScript("vnd.sun.star.script:Library1.Evaluate1.js?language=JavaScript&location=user")
' Macro実行
Eval = oScript.invoke( array(oString),array(1),array(JsResult))
End Function
'
'
' [ JavaScript Macro ]
' マイマクロ/Library1/Evaluate1.js
//
// Evaluate
JsResult = eval(String(ARGUMENTS[0]));
//
'
' 上記Functionを設定していればUser定義関数としてCalcの関数として使える。(右図)
GJS-)[General]
Python
GPy-)[General]Python Macro(1)
Sub Python_Macro
Dim oMSPF as Object
Dim oSP as Object
Dim oScript as Object
oMSPF = GetDefaultContext.getValueByName( "/singletons/com.sun.star.script.provider.theMasterScriptProviderFactory")
oSP = oMSPF.createScriptProvider("")
' Python Macro
oScript = oSP.getScript("vnd.sun.star.script:test.py$oTest?language=Python&location=user")
' Macro実行
oScript.invoke( array(),array(),array())
End Sub
'
' [ Python Macro ]
' マイマクロ/test.py / def oTest():
'C:\Users\[UserName]\AppData\Roaming\LibreOffice\3\user\Scripts\python\test.py
#
#!
#coding: UTF-8
# python Marco
import itertools
import sys
import uno
import sys
import traceback
from com.sun.star.awt import Rectangle
def omsgbox(oMessage='',oBtnType=1,oTitle='Title',oMsgType='messbox'):
# """shows message."""
desktop = XSCRIPTCONTEXT.getDesktop()
frame = desktop.getCurrentFrame()
window = frame.getContainerWindow()
toolkit = window.getToolkit()
msgbox = toolkit.createMessageBox(window, Rectangle(), oMsgType, oBtnType, oTitle, oMessage)
return msgbox.execute()
def oTest():
try:
# Unfinite Iterator
oStr = 'ABC'
oLmt = 3
# oLmtの引数を省略すると無限Iteratorになる。
oIterObj = itertools.repeat(oStr, oLmt) # ABC ABC ABC
oIter = oIterObj.__iter__()
oDisp = unicode('[ Unifite Iterator ]\n','utf-8')
for i in oIter:
oDisp = oDisp + str(i) + '\n'
except:
oDisp = traceback.format_exc(sys.exc_info()[2])
finally:
omsgbox(oDisp,1)
GPy-)[General]Python Macro(2) / 他DocumentのMacro
Sub PythonMacro
Dim oSP as Object
Dim oScript as Object
oSP = ThisComponent.ScriptProvider
' Python Macro
oScript = oSP.getScript("vnd.sun.star.script:test.py$oTest?language=Python&location=user")
' Macro実行
oScript.invoke( array(),array(),array())
End Sub
'
' [ Python Macro ]
' マイマクロ/test.py / def oTest():
'C:\Users\[UserName]\AppData\Roaming\LibreOffice\3\user\Scripts\python\test.py
#
#!
#coding: UTF-8
# python Marco
import re
import uno
import sys
import traceback
from com.sun.star.awt import Rectangle
def omsgbox(oMessage='',oBtnType=1,oTitle='Title',oMsgType='messbox'):
# """shows message."""
desktop = XSCRIPTCONTEXT.getDesktop()
frame = desktop.getCurrentFrame()
window = frame.getContainerWindow()
toolkit = window.getToolkit()
msgbox = toolkit.createMessageBox(window, Rectangle(), oMsgType, oBtnType, oTitle, oMessage)
return msgbox.execute()
def oTest():
try:
oDisp = u('処理を続けますか?')
oAns = omsgbox(oDisp,2,'Normal Box','messbox')
oDisp = 'Return => ' + str(oAns)
except:
oDisp = traceback.format_exc(sys.exc_info()[2])
finally:
omsgbox(oDisp,1)
GPy-)[General]
VBScript
[ FileSystemObject ]
GVBSFs-)[General]File有無確認
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "C:\temp\OOoTest.csv"
If oFSObj.FileExists(oFile) then
MsgBox( oFile & " は存在します", 0, "File Exist")
else
MsgBox( oFile & " は存在しません", 0, "Caution !!")
End If
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Folder有無確認
Sub oFSObject()
Dim oFSObj as Object
Dim oFolder as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFolder = "C:\temp"
If oFSObj.FolderExists(oFolder) then
MsgBox( oFolder & " Folder は存在します", 0, "FileSystemObject")
else
MsgBox( oFolder & " Folder は存在しません", 0, "Caution !!")
End If
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Drive有無確認
Sub oFSObject()
Dim oFSObj as Object
Dim oDrive() as String
Dim oDisp as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oDrive = Array("A:","C:","D:")
oDisp = ""
for each oDrName in oDrive
if oFSObj.DriveExists(oDrName) then
oDisp = oDisp & oDrName & " Driveは存在します。" & Chr(10)
else
oDisp = oDisp & oDrName & " Driveは存在しません。" & Chr(10)
end if
next oDrName
'
set oFSObj = Nothing
msgbox oDisp,0,"End Code"
End Sub
GVBSFs-)[General]File名を抽出
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oFName as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "C:\temp\OOoTest.csv"
oFName = oFSObj.GetFileName(oFile)
'
oDisp = oFile & Chr(10) & " → " & oFName
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Exe FileのVresion取得
Sub oFSObject()
Dim oFSObj as Object
Dim oExeFile as String
Dim oVersion as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oExeFile = "C:\Program Files\Mozilla Firefox\firefox.exe"
oVersion = oFSObj.GetFileVersion(oExeFile)
'
oDisp = oExeFile & Chr(10) & " → Ver." & oVersion
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Current Folder + File Name
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oAbsFile as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "Dummy.txt"
oAbsFile = oFSObj.GetAbsolutePathName(oFile)
'
oDisp = oAbsFile
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Drive Name抽出
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oDriveName as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "c:\Temp\Dummy.txt"
oDriveName = oFSObj.GetDriveName(oFile)
'
oDisp = oFile & Chr(10) & " → " & oDriveName
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Base File Name抽出
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oBaseName as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "c:\Temp\Dummy.txt"
oBaseName = oFSObj.GetBaseName(oFile)
'
oDisp = oFile & Chr(10) & " → " & oBaseName
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]拡張子の抽出
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oExtentName as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "c:\Temp\MacroCalc.ods"
oExtentName = oFSObj.GetExtensionName(oFile)
'
oDisp = oFile & Chr(10) & " → " & oExtentName
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Parent Folder抽出
Sub oFSObject()
Dim oFSObj as Object
Dim oFile as String
Dim oParentName as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "c:\Temp\MacroCalc.ods"
oParentName = oFSObj.GetParentFolderName(oFile)
'
oDisp = oFile & Chr(10) & " → " & oParentName
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Windowsの特殊Folder取得
Sub oFSObject()
Dim oFSObj as Object
Dim oDisp as String
Dim oWinFldr as String
Dim oSysFldr as String
Dim oTmpFldr as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
'
oWinFldr = oFSObj.GetSpecialFolder(0)
oSysFldr = oFSObj.GetSpecialFolder(1)
oTmpFldr = oFSObj.GetSpecialFolder(2)
'
oDisp = "WindowsFolder / " & oWinFldr & Chr(10) & "SystemFolder / " & oSysFldr
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]Temporary File取得
Sub oFSObject()
Dim oFSObj as Object
Dim oDisp as String
Dim oTmpFile as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
'
oTmpFile = oFSObj.GetTempName()
'
oDisp = "Temp File Name / " & oTmpFile
msgbox oDisp,0,"FileSystemObject"
'
set oFSObj = Nothing
msgbox "Success",0,"End Code"
End Sub
GVBSFs-)[General]File Information取得( using FileSystemObject )
Sub oFSObject()
On Error Goto oBad
Dim oFSObj as Object
Dim oFile as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "C:\temp\Test_Access.xlsx"
If oFSObj.FileExists(oFile) then
Dim oFileObj as Object
Dim oName as String
Dim oFileType as String
Dim oSize as String
'
Dim oCreateObj as Object
Dim oCreate as Date
Dim oLastAccessObj as Object
Dim oLastAccess as Date
Dim oLastModifyObj as Object
Dim oLastModify as Date
'
set oFileObj = oFSObj.GetFile(oFile)
'
oName = oFileObj.Name
oFileType = oFileObj.Type
oSize = oFileObj.Size
'
oCreateObj = oFileObj.DateCreated
oCreate = CDate(oCreateObj.Value) ' oCreateObj.Value : Double Type
'
' LastModifiedされた時のAccess 日時 / CSV や Text Fileは DateLastModified と同じ
oLastAccessObj = oFileObj.DateLastAccessed
oLastAccess = CDate(oLastAccessObj.Value) ' oLastAccessObj.Value : Double Type
'
oLastModifyObj = oFileObj.DateLastModified
oLastModify = CDate(oLastModifyObj.Value) ' oLastModifyObj.Value : Double Type
'
oDisp = oFile & Chr$(10) & Chr$(10) & _
"File Name : " & oName & Chr$(10) & _
"File Type : " & oFileType & Chr$(10) & _
"File Size : " & oSize & Chr$(10) & _
"Created date of file : " & CStr(oCreate) & Chr$(10) & _
"Last accesed date of file : " & CStr(oLastAccess) & Chr$(10) & _
"Last modified date of file : " & CStr(oLastModify)
'
set oFileObj = Nothing
else
oDisp = oFile & Chr$(10) & " は存在しません"
End If
'
set oFSObj = Nothing
msgbox oDisp,0,"FileSystemObject"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSFs-)[General]Fileの読み取り専用を解除
Sub oFSObject()
On Error Goto oBad
Dim oFSObj as Object
Dim oFile as String
set oFSObj = CreateObject("Scripting.FileSystemObject")
oFile = "C:\temp\OOoTest.csv"
If oFSObj.FileExists(oFile) then
Dim oFileObj as Object
set oFileObj = oFSObj.GetFile(oFile)
'
If oFileObj.Attributes And 1 Then
oDisp = oFileObj.Name & " ： 読み取り専用です。" & Chr$(10)
'
' 読み取り専用を解除
oFileObj.Attributes = oFileObj.Attributes And &HFE
If oFileObj.Attributes And 1 Then
oDisp = oDisp & " → " & " 読み取り専用の解除に失敗しました。"
else
oDisp = oDisp & " → " & " 読み取り専用の解除しました。"
End If
else
oDisp = oFileObj.Name & " ： 読み取り専用ではありません。"
End If
else
oDisp = oFile & Chr$(10) & " は存在しません"
End If
'
set oFSObj = Nothing
msgbox oDisp,0,"FileSystemObject"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSFs-)[General]File( or Folder )の属性取得
Sub oFSObject()
On Error Goto oBad
Dim oFile1 as String, oFile2 as String, oFile3 as String, oFile4 as String, oFile5 as String
oFile1 = "C:\temp\OOoTest.csv"
oFile2 = "C:\temp\OOoTest_Readonly.csv"
oFile3 = "C:\temp\OOoTest_Hidden.csv"
oFile4 = "C:\temp\OOoTest_Comp.7z"
oFile5 = "C:\temp\Dummy.txt"
'
oDisp = ""
oDisp = oDisp & oFile1 & " → " & FileAttr(oFile1) & Chr$(10)
oDisp = oDisp & oFile2 & " → " & FileAttr(oFile2) & Chr$(10)
oDisp = oDisp & oFile3 & " → " & FileAttr(oFile3) & Chr$(10)
oDisp = oDisp & oFile4 & " → " & FileAttr(oFile4) & Chr$(10)
oDisp = oDisp & oFile5 & " → " & FileAttr(oFile5) & Chr$(10)
'
msgbox oDisp,0,"FileSystemObject"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
Function FileAttr( oFile as String) as String
Dim oFSObj as Object
Dim oFileObj as Object
set oFSObj = CreateObject("Scripting.FileSystemObject")
set oFileObj = oFSObj.GetFile(oFile)
'
select case oFileObj.Attributes
case 0
FileAttr = "Normal"
case 1
FileAttr = "ReadOnly"
case 2
FileAttr = "Hidden"
case 1+2
FileAttr = "ReadOnly + Hidden"
case 4
FileAttr = "System"
case 1+4
FileAttr = "ReadOnly + System"
case 2+4
FileAttr = "Hidden + System"
case 1+2+4
FileAttr = "ReadOnly + Hidden + System"
case 8
FileAttr = "Volume"
case 1+8
FileAttr = "ReadOnly + Volume"
case 2+8
FileAttr = "Hidden + Volume"
case 4+8
FileAttr = "System + Volume"
case 1+2+8
FileAttr = "ReadOnly + Hidden + Volume"
case 1+4+8
FileAttr = "ReadOnly + System + Volume"
case 1+2+4+8
FileAttr = "ReadOnly + Hidden + System + Volume"
case 16
FileAttr = "Directory"
case 1+16
FileAttr = "ReadOnly + Directory"
case 2+16
FileAttr = "Hidden + Directory"
case 4+16
FileAttr = "System + Directory"
case 8+16
FileAttr = "Volume + Directory"
case 1+2+16
FileAttr = "ReadOnly + Hidden + Directory"
case 1+4+16
FileAttr = "ReadOnly + System + Directory"
case 1+8+16
FileAttr = "ReadOnly + Volume + Directory"
case 1+2+4+16
FileAttr = "ReadOnly + Hidden + System + Directory"
case 1+2+8+16
FileAttr = "ReadOnly + Hidden + Volume + Directory"
case 1+2+4+8+16
case 32
FileAttr = "Archive"
case 1+32
FileAttr = "ReadOnly + Archive"
case 2+32
FileAttr = "Hidden + Archive"
case 4+32
FileAttr = "System + Archive"
case 8+32
FileAttr = "Volume + Archive"
case 16+32
FileAttr = "Directory + Archive"
case 1+2+32
FileAttr = "ReadOnly + Hidden + Archive"
case 1+4+32
FileAttr = "ReadOnly + System + Archive"
case 1+8+32
FileAttr = "ReadOnly + Volume + Archive"
case 1+16+32
FileAttr = "ReadOnly + Directory + Archive"
case 1+2+4+32
FileAttr = "ReadOnly + Hidden + System + Archive"
case 1+2+8+32
FileAttr = "ReadOnly + Hidden + Volume + Archive"
case 1+2+16+32
FileAttr = "ReadOnly + Hidden + Directory + Archive"
case 1+2+4+8+32
FileAttr = "ReadOnly + Hidden + System + Volume + Archive"
case 1+2+4+16+32
FileAttr = "ReadOnly + Hidden + System + Directory + Archive"
case 1+2+4+8+16+32
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Archive"
case 64
FileAttr = "Alias"
case 1+64
FileAttr = "ReadOnly + Alias"
case 2+64
FileAttr = "Hidden + Alias"
case 4+64
FileAttr = "System + Alias"
case 8+64
FileAttr = "Volume + Alias"
case 16+64
FileAttr = "Directory + Alias"
case 32+64
FileAttr = "Archive + Alias"
case 1+2+64
FileAttr = "ReadOnly + Hidden + Alias"
case 1+4+64
FileAttr = "ReadOnly + System + Alias"
case 1+8+64
FileAttr = "ReadOnly + Volume + Alias"
case 1+16+64
FileAttr = "ReadOnly + Directory + Alias"
case 1+32+64
FileAttr = "ReadOnly + Archive + Alias"
case 1+2+4+64
FileAttr = "ReadOnly + Hidden + System + Alias"
case 1+2+8+64
FileAttr = "ReadOnly + Hidden + Volume + Alias"
case 1+2+16+64
FileAttr = "ReadOnly + Hidden + Directory + Alias"
case 1+2+32+64
FileAttr = "ReadOnly + Hidden + Archive + Alias"
case 1+2+4+8+64
FileAttr = "ReadOnly + Hidden + System + Volume + Alias"
case 1+2+4+16+64
FileAttr = "ReadOnly + Hidden + System + Directory + Alias"
case 1+2+4+32+64
FileAttr = "ReadOnly + Hidden + System + Archive + Alias"
case 1+2+4+8+16+64
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Alias"
case 1+2+4+8+32+64
FileAttr = "ReadOnly + Hidden + System + Volume + Archive + Alias"
case 1+2+4+8+16+32+64
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Archive + Alias"
case 128
FileAttr = "Compress"
case 1+128
FileAttr = "ReadOnly + Compress"
case 2+128
FileAttr = "Hidden + Compress"
case 4+128
FileAttr = "System + Compress"
case 8+128
FileAttr = "Volume + Compress"
case 16+128
FileAttr = "Directory + Compress"
case 32+128
FileAttr = "Archive + Compress"
case 64+128
FileAttr = "Alias + Compress"
case 1+2+128
FileAttr = "ReadOnly + Hidden + Compress"
case 1+4+128
FileAttr = "ReadOnly + System + Compress"
case 1+8+128
FileAttr = "ReadOnly + Volume + Compress"
case 1+16+128
FileAttr = "ReadOnly + Directory + Compress"
case 1+32+128
FileAttr = "ReadOnly + Archive + Compress"
case 1+64+128
FileAttr = "ReadOnly + Alias + Compress"
case 1+2+4+128
FileAttr = "ReadOnly + Hidden + System + Compress"
case 1+2+8+128
FileAttr = "ReadOnly + Hidden + Volume + Compress"
case 1+2+16+128
FileAttr = "ReadOnly + Hidden + Directory + Compress"
case 1+2+32+128
FileAttr = "ReadOnly + Hidden + Archive + Compress"
case 1+2+4+8+128
FileAttr = "ReadOnly + Hidden + System + Volume + Compress"
case 1+2+4+16+128
FileAttr = "ReadOnly + Hidden + System + Directory + Compress"
case 1+2+4+32+128
FileAttr = "ReadOnly + Hidden + System + Archive + Compress"
case 1+2+4+64+128
FileAttr = "ReadOnly + Hidden + System + Alias + Compress"
case 1+2+4+8+16+128
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Compress"
case 1+2+4+8+32+128
FileAttr = "ReadOnly + Hidden + System + Volume + Archive + Compress"
case 1+2+4+8+64+128
FileAttr = "ReadOnly + Hidden + System + Volume + Alias + Compress"
case 1+2+4+8+16+32+128
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Archive + Compress"
case 1+2+4+8+16+64+128
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Alias + Compress"
case 1+2+4+8+16+32+64+128
FileAttr = "ReadOnly + Hidden + System + Volume + Directory + Archive + Alias + Compress"
end select
'
set oFileObj = Nothing
set oFSObj = Nothing
End Function
GVBSFs-)[General]
[ 正規表現 ]
GVBSRE-)[General]検索
Sub oVBSRegExp
Dim oRegExp As Object
oRegExp = CreateObject("VBScript.RegExp")
' 対象文字列のObjectの設定
oSchWord = "Office"
oRegExp.Pattern = oSchWord ' 検索文字
oRegExp.Ignorecase = True ' 大文字小文字を区別する <= falseは機能しない
oRegExp.Global = True ' 正規表現を文字列内のすべての可能なマッチに対してテストすべきかどうか
' 正規表現
Dim oWords as String
'
oWords = "OpenOffice.org / LibreOffice"
oRltSrch = oRegExp.Test(oWords)
'
oDisp = "対象 => " & oWords & Chr$(10) & "検索文字 => " & oSchWord & Chr$(10) & "結果 => " & oRltSrch
msgbox oDisp,0,"VBS 正規表現"
'
oRegExp = nothing
End Sub
GVBSRE-)[General]置換
Sub oVBSRegExp
Dim oRegExp As Object
oRegExp = CreateObject("VBScript.RegExp")
' 対象文字列のObjectの設定
oSchWord = "Office"
oRegExp.Pattern = oSchWord ' 検索文字
oRegExp.Ignorecase = True ' 大文字小文字を区別する <= falseは機能しない
oRegExp.Global = True ' 正規表現を文字列内のすべての可能なマッチに対してテストすべきかどうか
' 正規表現
Dim oWords as String
'
oWords = "OpenOffice.org / LibreOffice"
oRpleWord = "OFFICE"
oRltSrch = oRegExp.Replace(oWords, oRpleWord)
'
oDisp = "対象 => " & oWords & Chr$(10) & "検索文字 => " & oSchWord & Chr$(10) & "置換文字 => " & oRpleWord & Chr$(10) & "置換結果 => " & oRltSrch
msgbox oDisp,0,"VBS 正規表現"
'
oRegExp = nothing
End Sub
GVBSRE-)[General]Matche数
Sub oVBSRegExp
Dim oRegExp As Object
oRegExp = CreateObject("VBScript.RegExp")
' 対象文字列のObjectの設定
oSchWord = "Office"
oRegExp.Pattern = oSchWord ' 検索文字
oRegExp.Ignorecase = False ' 大文字小文字を区別する <= falseは機能しない
oRegExp.Global = True ' 正規表現を文字列内のすべての可能なマッチに対してテストすべきかどうか
' 正規表現
Dim oWords as String
'
oWords = "Openoffice.org / LibreOffice"
oRltSrch = oRegExp.Execute(oWords)
'
oDisp = "対象 => " & oWords & Chr$(10) & "検索文字 => " & oSchWord & Chr$(10) & "Matche数 => " & oRltSrch.count
msgbox oDisp,0,"VBS 正規表現"
'
oRegExp = nothing
End Sub
GVBSRE-)[General]MatcheしたItem取得
Sub oVBSRegExp
Dim oRegExp As Object
oRegExp = CreateObject("VBScript.RegExp")
' 対象文字列のObjectの設定
oSchWord = "[a-e]"
oRegExp.Pattern = oSchWord ' 検索文字
oRegExp.Ignorecase = False ' 大文字小文字を区別する <= falseは機能しない
oRegExp.Global = True ' 正規表現を文字列内のすべての可能なマッチに対してテストすべきかどうか
' 正規表現
Dim oWords as String
Dim oRltSrch as Object
Dim oCount as Integer
Dim i as Long
'
oWords = "OpenOffice.org / LibreOffice"
oRltSrch = oRegExp.Execute(oWords)
'
oCount = oRltSrch.count
msgbox "oCount => " & oCount
i = 0
msgbox "oRltSrch.Item(i) => " & oRltSrch.Item(i)
If oCount > 0 then
oMatcheItem = ""
for i = 0 to oCount-1
msgbox "i => " & i
' msgbox oRltSrch.Item(0) ' <= for中でoRltSrch.Item(0)を使うとCrashする。
' oMatcheItem = oMatcheItem & " " & oRltSrch.Item(i) & Chr$(10) ' ' <= for中でoRltSrch.Item(0)を使うとCrashする。
next
End If
msgbox "Success"
'oDisp = "対象 => " & oWords & Chr$(10) & "検索文字 => " & oSchWord & Chr$(10) & "[ Matche Item ]" & CHr$(10) & oMatcheItem
'msgbox oDisp,0,"VBS 正規表現"
'
oRegExp = nothing
End Sub
GVBSRE-)[General]
[ WshShell ]
GVBSWhS-)[General]Programの実行
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
oWSObj.Exec(oCmdLine)
'
set oWSObj = Nothing
msgbox "Success",0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]Programが終了するまで待機(1)
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
Dim oExecObj as Object
Dim nk as Long
Dim oLimit as Long
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
set oExecObj = oWSObj.Exec(oCmdLine)
'
nk = 0
oLimit = 10000
Do while oExecObj.Status = 0 and nk < oLimit
wait 1000
'
nk = nk + 1
if nk > oLimit then
Exit Do
end if
Loop
'
if nk > oLimit then
oDisp = "Loop制限です。"
else
oDisp = oCmdLine & " を終了しました。"
set oExecObj = Nothing
end if
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]Programが終了するまで待機(2)
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
oWSObj.Run(oCmdLine,1, true)
'
set oWSObj = Nothing
msgbox "Success",0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' object.Run( cmd, [WinStyle], [WaitOnReturn] )
' → Execと異なり、単純に起動させるだけなので、起動中のApplicationのStatusは分らない。
'
' cmd : Execute File ← Full Pathがbetter
'
' [ WinStyle ]
' 1 : Active / Normal Size ( Default )
' 2 : Active / Minimum Size
' 3 : Active / Maximum Size
' 4 : Inactive/ Normal Size
' 5 : Active / Same Size as last time ( According to the application )
' 7 : Inactive/ Minimum Size
'
' [ WaitOnReturn ]
' true : Wait until the end
GVBSWhS-)[General]Programを強制終了
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
Dim oExecObj as Object
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
set oExecObj = oWSObj.Exec(oCmdLine)
wait 3000 ' wait 3 sec
'
' 強制終了
oExecObj.Terminate
set oExecObj = Nothing
'
set oWSObj = Nothing
'
oDisp = "Success"
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]Programの終了Status取得
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
Dim oExecObj as Object
Dim nk as Long
Dim oLimit as Long
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
set oExecObj = oWSObj.Exec(oCmdLine)
'
nk = 0
oLimit = 10000
Do while oExecObj.Status = 0 and nk < oLimit
wait 1000
'
nk = nk + 1
if nk > oLimit then
Exit Do
end if
Loop
'
if nk > oLimit then
oDisp = "Loop制限です。"
else
Dim oExitCode as Long
oExitCode = oExecObj.ExitCode
oDisp = oCmdLine & " を終了しました。" & Chr$(10) & _
" 終了Status = " & oExitCode
set oExecObj = Nothing
end if
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]ProgramのProcess ID取得
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
Dim oExecObj as Object
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "notepad.exe"
'
' Execute natepad.exe
set oExecObj = oWSObj.Exec(oCmdLine)
'
msgbox "10 [sec] 以内に起動したProgramをActiveにして下さい。",0,"Active"
wait 10000 ' wait 10 [ sec ]
oWSObj.AppActivate(oExecObj.ProcessID)
oDisp = oCmdLine & " をActiveにしました。" & Chr$(10) & "Process ID = " & oExecObj.ProcessID
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]Current Folder取得
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCurFolder as String
set oWSObj = CreateObject("WScript.Shell")
'
oCurFolder = oWSObj.CurrentDirectory
oDisp = "[ Current Folder ] " & Chr$(10) & oCurFolder
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]Current Folder変更
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oChgFolder as String
Dim oCurFolder as String
set oWSObj = CreateObject("WScript.Shell")
'
oChgFolder = "C:\Temp"
oWSObj.CurrentDirectory = oChgFolder
'
oCurFolder = oWSObj.CurrentDirectory
oDisp = "[ Current Folder ] " & Chr$(10) & oCurFolder
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]時限付messagebox
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oTime as Long
Dim oAns as Long
set oWSObj = CreateObject("WScript.Shell")
'
oTime = 2
oAns = oWSObj.Popup(oTime & " [sec]以内のClickして下さい。", oTime, "時間内のClick？", vbOkCancel + vbQuestion)
'
' messagebox の FrameをClick ( OK Button や 「 × 」 以外 )
select case oAns
case -1
oDisp = oTime & " sec が経過したのでMessageBoxをCloseしました。"
case 1
oDisp = oTime & " sec 以内にClickされました。"
end select
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' [ 注意 ]
' OK Buttonしか反応しないことも多い。時間が長いとNG?
GVBSWhS-)[General]PCのCPU
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oOsBit as String
Dim oDisp as String
set oWSObj = CreateObject("WScript.Shell")
'
oOsBit = oWSObj.Environment("Process").Item("PROCESSOR_ARCHITECTURE")
oDisp = "[ CPU ]" & Chr$(10)
Select case UCase(oOsBit)
case "X86"
oDisp = oDisp & oOsBit & " / 32Bit CPU "
case "AMD64"
oDisp = oDisp & oOsBit & " / 64Bit CPU "
case "IA64"
oDisp = oDisp & oOsBit & " / 64Bit CPU "
case else
oDisp = oDisp & " → Unknown CPU"
End Select
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]動画再生( Windows Media Player )
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oCmdLine as String
set oWSObj = CreateObject("WScript.Shell")
oCmdLine = "C:\temp\Movie\MovieTest.mp4"
'
' Execute natepad.exe
oWSObj.Run(oCmdLine,1, true)
'
set oWSObj = Nothing
msgbox "Success",0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWhS-)[General]
[ Shell.Application ]
GVBSShAp-)[General]
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oPickFolder as String
Dim oDefFolder as String
Dim oDisp as String
Dim oNote as String
set oShellObj = CreateObject("Shell.Application")
'
oNote = "Folderを選択して下さい。" & Chr$(10) & "キャンセルは不可（Errorになります）"
oDefFolder = "C:\Temp\test\"
oPickFolder = oShellObj.BrowseForFolder(0, oNote, 0,oDefFolder)
'
oDisp = "選択されたFolderは" & Chr$(10) & Chr$(9) & oPickFolder & Chr$(10) & " です。( Defualtは " & oDefFolder & " )"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]Exploreを開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.Explore "C:\Temp\test"
wait 1000
'
oDisp = "Explorerが開きました。"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]File名を指定して実行 Windowを開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.FileRun
'
oDisp = "File名を指定して実行 Windowが開きました"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]File と Folderの検索 Windowを開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.FindFiles
wait 1000
'
oDisp = "File と Folderの検索 Windowが開きました"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]WindowsのHelpを開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.Help
wait 1000
'
oDisp = "WindowsのHelpが開きました"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]全てのWindowの最少化 / 最少化解除
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
' 全てのWindowの最少化
oShellObj.MinimizeAll
wait 3000 ' wait 3 [sec]
'
' 元のWindow Sizeに戻す( 最少化の解除 )
oShellObj.UndoMinimizeAll
'
oDisp = "Window の最少化→元のSize"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]日付と時刻の設定 Windowを開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.SetTime
wait 2000 ' wait 2 [sec]
'
oDisp = "日付と時刻の設定 Window が開きました。"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]Windowsの Shutdown画面を開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
oShellObj.ShutdownWindows
wait 2000 ' wait 2 [sec]
'
oDisp = "Windowｓ の Shutdown 画面が開きました。"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]Taskbar と Start Menuの設定画面を開く
Sub oShell_App()
On Error Goto oBad
Dim oShellObj as Object
Dim oDisp as String
set oShellObj = CreateObject("Shell.Application")
'
' Current Windowの最少化
oShellObj.TrayProperties
wait 2000 ' wait 2 [sec]
'
oDisp = "Taskbar と Start Menuの設定画面が開きました。"
'
set oShellObj = Nothing
msgbox oDisp,0,"Shell.Application"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]File Information取得( using Shell.Application )
Sub oWshShell()
On Error Goto oBad
Dim oWSObj as Object
Dim oFolderObj as Object
Dim oFileObj as Object
Dim oFoderName as String
Dim oChkFile as String
Dim oFileName as String
set oWSObj = CreateObject("Shell.Application")
'
oFoderName = "C:\temp"
oFileName = "oTextMacro.txt"
oChkFile = oFoderName & "\" & oFileName
'
oDisp = oChkFile & Chr$(10)
if FileExists(oChkFile) then
set oFolderObj = oWSObj.NameSpace(oFoderName)
set oFileObj = oFolderObj.ParseName(oFileName)
'
Dim oName as String
Dim oPath as String
Dim oFileType as String
Dim oParent as String
Dim oSize as String
Dim oMdfyDateObj as Object
Dim oMdfyDate as Date
Dim oHtml as Boolean
Dim oIsFldFile as Boolean
Dim oIsFolder as Boolean
DIm oIsLink as Boolean
oName = oFileObj.Name
oPath = oFileObj.Path
oFileType = oFileObj.Type
oParent = oFileObj.Parent
oSize = oFileObj.Size
'
oMdfyDateObj = oFileObj.ModifyDate
oMdfyDate = CDate(oMdfyDateObj.Value) ' oMdfyDateObj.Value ← Double
'
oHtml = oFileObj.IsBrowsable
oIsFldFile = oFileObj.IsFileSystem
oIsFolder = oFileObj.IsFolder
oIsLink = oFileObj.IsLink
'
oDisp = oDisp & Chr$(10) & "Name : " & oName & Chr$(10) & _
"Path : " & oPath & Chr$(10) & _
"File Type : " & oFileType & Chr$(10) & _
"Parent Folder : " & oParent & Chr$(10) & _
"File Size : " & oSize & " [ Byte ]" & Chr$(10) & _
"Modified Date : " & CStr(oMdfyDate) & Chr$(10) & Chr$(10) & _
"Html File ? → " & oHtml & Chr$(10) & _
"Folder or File ? → " & oIsFldFile & Chr$(10) & _
"Folder ? → " & oIsFolder & Chr$(10) & _
"Link ? → " & oIsLink
'
set oFolderObj = Nothing
set oFileObj = Nothing
else
oDisp = oDisp & "は存在しません。"
end if
'
set oWSObj = Nothing
msgbox oDisp,0,"WshShell"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSShAp-)[General]
[ WScript.Network ]
GVBSWsNt-)[General]Network Information取得
Sub oWshShell()
On Error Goto oBad
Dim oWNetObj as Object
Dim oDomain as String
Dim oComputer as String
Dim oUser as String
set oWNetObj = CreateObject("WScript.Network")
'
oDomain = oWNetObj.UserDomain
oComputer = oWNetObj.ComputerName
oUser = oWNetObj.UserName
'
oDisp = "Domain = " & oDomain & Chr$(10) & "Computer = " & oComputer & Chr$(10) & "User Name = " & oUser
'
set oWNetObj = Nothing
msgbox oDisp,0,"Network"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSWsNt-)[General]Default Printer設定
Sub oWshShell()
On Error Goto oBad
Dim oWNetObj as Object
Dim oDefautPrt as String
set oWNetObj = CreateObject("WScript.Network")
oDefautPrt = "Microsoft XPS Document Writer"
REM oDefautPrt = "Fax"
'
oWNetObj.SetDefaultPrinter oDefautPrt
oDisp = "Default Printerが" & Chr$(10) & oDefautPrt & Chr$(10) & "に設定されました。"
'
set oWNetObj = Nothing
msgbox oDisp,0,"Network"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' [ Note ]
' Default Printerの設定は出来るが、取得は出来ない。
GVBSWsNt-)[General]Printer List取得
Sub oWshShell()
On Error Goto oBad
Dim oWNetObj as Object
Dim oPrinters as Object
Dim oPort as String
Dim oPrtName as String
Set oWNetObj = CreateObject("WScript.Network")
Set oPrinters = oWNetObj.EnumPrinterConnections
'
oDisp = "[ Printer List ]" & Chr$(10)
for i = 0 to oPrinters.Count - 1 Step 2
oPort = oPrinters.Item(i) ' Refer to Note
oPrtName = oPrinters.Item(i+1)
oDisp = oDisp & oPort & " = " & oPrtName & Chr(10)
next i
'
Set oPrinters = Nothing
Set oWNetObj = Nothing
msgbox oDisp,0,"WScript.Network"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' [ Note ]
' Port値は正確では無い。正確な値を取得するにはレジストリをいじる必要がある模様。
'
' $$$ [ Reference site ] $$$
' 1) Blog site 「 513号室 」の保管庫(Excel：ActivePrinterへ設定するプリンタ名の列挙)より
' 2) Microsoft / TechNet " Find Printername and PrinterPort on VBScript "
GVBSWsNt-)[General]
[ WbemScripting.SWbemLocator ]
GVBWbLr-)[General]起動中のProcess数取得
Sub oWbSt_SwLr()
On Error Goto oBad
Dim oLocatorObj as Object, oSrv as Object, oExeQuery as Object
Dim oAppNum as Integer
Dim oDisp as String
set oLocatorObj = CreateObject("WbemScripting.SWbemLocator")
set oSrv = oLocatorObj.ConnectServer
'
set oExeQuery = oSrv.ExecQuery("Select * From Win32_Process")
oAppNum = oExeQuery.count
oDisp = "起動中のProcess数 は" & Chr$(10) & oAppNum & " です。"
'
set oExeQuery = Nothing
set oSrv = Nothing
set oLocatorObj = Nothing
'
msgbox oDisp,0,"WbemScripting"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBWbLr-)[General]特定Applicationの起動数取得
Sub oWbSt_SwLr()
On Error Goto oBad
Dim oLocatorObj as Object, oSrv as Object, oExeQuery as Object
Dim oAppNum as Integer
Dim oDisp as String
set oLocatorObj = CreateObject("WbemScripting.SWbemLocator")
set oSrv = oLocatorObj.ConnectServer
'
set oExeQuery = oSrv.ExecQuery("Select * From Win32_Process Where Caption='notepad.EXE'")
oAppNum = oExeQuery.count
'
If oAppNum = 0 then
oDisp = "NotePadは起動していません。"
else
oDisp = "NotesPadが " & oAppNum & " つ起動しています。"
End If
'
set oExeQuery = Nothing
set oSrv = Nothing
set oLocatorObj = Nothing
'
msgbox oDisp,0,"WbemScripting"
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' [ Note ]
' MS-Excel : EXCEL.EXE
' Internet Explore : iexplore.exe / 1つのIEでprocessは2つ
' Chrome : chrome.exe / 1つで複数のprocessを使っている。
[ MS-Office ]
{{ General }}
GVBSMsGn-)[General]Excel起動
Sub oMsOffice()
On Error Goto oBad
Dim oExcelObj as Object
Dim xlbook as Object
Dim oDisp as String
set oExcelObj = CreateObject("Excel.Application")
set xlbook = oExcelObj.Workbooks.Add
'
oExcelObj.Visible = true
'
oDisp = "MS-Excel が起動しました"
msgbox oDisp,0,"MS-Office"
'
xlbook.Close(false)
oExcelObj.Quit
'
set xlbook = Nothing
set oExcelObj = Nothing
'
oDisp = "Success"
msgbox oDisp,0,"MS-Office"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSMsGn-)[General]Word起動
Sub oMsOffice()
On Error Goto oBad
Dim oWordObj as Object
Dim oErrFlag as Integer
Dim oDisp as String
oErrFlag = 0
set oWordObj = CreateObject("Word.Application")
oErrFlag = 999
'
oWordObj.Visible = true
'
oDisp = "MS-Word が起動しました"
msgbox oDisp,0,"MS-Office"
'
oWordObj.Quit(wdDoNotSaveChanges)
set oWordObj = Nothing
oErrFlag = 0
'
oDisp = "Success"
msgbox oDisp,0,"MS-Office"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
'
if oErrFlag = 999 then
oWordObj.Quit(wdDoNotSaveChanges)
set oWordObj = Nothing
end if
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSMsGn-)[General]VBA実行
Sub ExcelVBAMacro()
Dim oExcelName as String
Dim oExcelDoc as Object
Dim oArgToExcel as String
Dim oProp(0) as New com.sun.star.beans.PropertyValue
Dim oSP as Object
Dim oScript as Object
'
oExcelName = ConvertToUrl("c:\temp\Excel2007Test.xlsm")
' Excel Document
oProp(0).Name = "Hidden"
oProp(0).Value = false
oExcelDoc = StarDesktop.loadComponentFromURL(oExcelName,"_default",0, oProp())
'
oArgToExcel = "Execute From LibreOfice!!"
'
oSP = oExcelDoc.ScriptProvider
' VBA Macro
oScript = oSP.getScript("vnd.sun.star.script:VBAProject.Module1.ExcelMacro?language=Basic&location=document")
' Macro実行
oScript.invoke( array(oArgToExcel),array(),array())
'
' Excel Close
oExcelDoc.close(true)
End Sub
'
' [ VBA ]
Sub ExcelMacro(Optional oArg As String)
Dim oCellString As String
Dim oDisp As String
oCellString = Workbooks("Excel2007Test.xlsm").Worksheets("sheet1").Range("B2").Text
oDisp = oCellString & Chr(10) & oArg
MsgBox oDisp, 0, "Excel Macro"
End Sub
{{ Other }}
GVBSMsGn-)[General]
[ Internet Explorer ]
GVBSIe-)[General]Internet Explorer起動(VBS)
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl = "http://oooug.jp/"
'
oIEObj.Navigate( oUrl )
oIEObj.Visible = True
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]IE起動2
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
'
set oIEObj = CreateObject("InternetExplorer.Application")
'
oIEObj.GoHome
oIEObj.Visible = True
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]IE終了
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
'
set oIEObj = CreateObject("InternetExplorer.Application")
'
oIEObj.GoHome
oIEObj.Visible = True
'
wait 1000
oIEObj.Quit
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]読込み完了確認(1)
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl1 as String
Dim oUrl2 as Variant
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl1 = "http://oooug.jp/"
oUrl2 = "http://www.libreoffice.org/"
'
oIEObj.Visible = True
oIEObj.Navigate( oUrl1 ) ' URL : String
'
Dim nk as Long
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
oIEObj.Navigate2( oUrl2 ) ' URL : Variant
'
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]読込み完了確認(2)
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl1 as String
Dim oUrl2 as Variant
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl1 = "http://oooug.jp/"
oUrl2 = "http://www.libreoffice.org/"
'
oIEObj.Visible = True
oIEObj.Navigate( oUrl1 ) ' URL : String
'
Dim nk as Long
Do until oIEObj.ReadyState = 4 or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
oIEObj.Navigate2( oUrl2 ) ' URL : Variant
'
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
'
' [ ReadyState ]
' 0 : 初期化中 / 前回のページデータのクリア時
' 1 : 表示データ読み込み中
' 2 : 表示データ読み込み完了
' 3 : データの表示中
' 4 : 全てのデータが表示終了
GVBSIe-)[General]戻る / 進む / 中止
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl1 as String
Dim oUrl2 as Variant
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl1 = "http://oooug.jp/"
oUrl2 = "http://www.libreoffice.org/"
'
oIEObj.Visible = True
oIEObj.Navigate( oUrl1 ) ' URL : String
'
Dim nk as Long
nk = 0
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
oIEObj.Navigate2( oUrl2 ) ' URL : Variant
nk = 0
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
msgbox("Click → Go Back",0,"IE")
oIEObj.GoBack()
nk = 0
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
msgbox("Click → Go Foward",0,"IE")
oIEObj.GoForward()
nk = 0
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
' Bad URL → Stop
oIEObj.Navigate( "http://oooug.jpp/" )
oIEObj.Stop
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Current siteのURL取得
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
'
set oIEObj = CreateObject("InternetExplorer.Application")
'
oIEObj.GoHome
oIEObj.Visible = True
'
Dim nk as Long
nk = 0
Do until oIEObj.ReadyState = 4 or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
Dim oUrl as String
Dim oDisp as String
oUrl = oIEObj.LocationURL()
'
oDisp = "Current URL" & Chr$(10) & "→ " & oURL
'
msgbox oDisp,0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Current siteのTitle Name取得
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
'
set oIEObj = CreateObject("InternetExplorer.Application")
'
oIEObj.GoHome
oIEObj.Visible = True
'
Dim nk as Long
nk = 0
Do until oIEObj.ReadyState = 4 or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
Dim oUrlName as String
Dim oDisp as String
oUrlName = oIEObj.LocationName()
'
oDisp = "Title of Current Site" & Chr$(10) & "→ " & oUrlName
'
msgbox oDisp,0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Screen updates
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl = "http://oooug.jp/"
'
oIEObj.Navigate( oUrl )
oIEObj.Visible = True
'
wait 5000
oIEObj.Refresh() ' Screen updates
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Windowの位置とSize設定
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl = "http://oooug.jp/"
'
oIEObj.Navigate( oUrl )
oIEObj.Visible = True
'
oIEObj.Width = 400
oIEObj.Height = 300
oIEObj.Top = 100
oIEObj.Left = 100
'
oIEObj.Resizable = False
'
msgbox "Success",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]WindowのFull Screen表示
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl = "http://oooug.jp/"
'
oIEObj.Navigate( oUrl )
oIEObj.Visible = True
'
' Full Screen
oIEObj.FullScreen = true
msgbox "Full Screen表示中です",0,"IE"
'
oIEObj.FullScreen = false
msgbox "Noraml 表示です",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Adress Bar表示/非表示
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl1 as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl1 = "http://oooug.jp/"
'
oIEObj.Visible = True
oIEObj.Navigate( oUrl1 ) ' URL : String
'
oIEObj.Width = 400
oIEObj.Height = 200
oIEObj.Top = 100
oIEObj.Left = 100
'
Dim nk as Long
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
oIEObj.AddressBar = false ' .MenuBar 及び .ToolBar はIE9では関係無し
oIEObj.Refresh()
msgbox "Adress Bar非表示です。",0,"IE"
'
oIEObj.AddressBar = true
oIEObj.Refresh()
msgbox "Adress Bar表示です。",0,"IE"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]Site Source取得( Body部のTextのみ )
Sub oIE_VBS()
On Error Goto oBad
Dim oIEObj as Object
Dim oUrl1 as String
'
set oIEObj = CreateObject("InternetExplorer.Application")
oUrl1 = "http://www.google.co.jp/"
'
oIEObj.Visible = True
oIEObj.Navigate( oUrl1 ) ' URL : String
'
oIEObj.Width = 400
oIEObj.Height = 200
oIEObj.Top = 100
oIEObj.Left = 100
'
Dim nk as Long
Do until oIEObj.Busy = false or nk > 10000
wait 1000
nk = nk+1
Loop
'
if nk > 10000 then
msgbox("Loop制限です",0,"Loop Limit")
Exit Sub
end if
'
Dim oDisp as String
Dim oSiteSrc as String
oSiteSrc = oIEObj.Document.Body.innerText ' 取得を失敗するSiteもある / innerHtml は不可
'
oIEObj.Quit
set oIEObj = Nothing
'
oDisp = "[ Site Source ]" & Chr$(10) & " *** [ " & oUrl1 & " ] ***" & Chr(10) & Chr$(10) & oSiteSrc
msgbox oDisp,0,"Site Source"
'
Exit Sub
oBad:
Dim oErLine As Integer
Dim oErNum As Integer
Dim oErMsg As String
oErLine = Erl
oErNum = Err
oErMsg = Error
Msgbox("Error Line No. " & Chr$(9) & " : " & oErLine & Chr$(10) _
& "Error Number " & Chr$(9) & " : " & oErNum &Chr$(10 ) _
& "Error Message" & Chr$(9) & " : " & oErMsg , 0, "Error Message")
End Sub
GVBSIe-)[General]
