ごおお さん
2006年 01月 13日 14時 18分 44秒
こんにちわ。
今定期的に自動実行されるVBSを作っています。
このページをいろいろ参考にさせていただきました。
ありがとうございます。
一つ自己解決できないところがあったので、
もしよかったら教えてください＞＜
自動実行されるVBSのなかで
Set objIE = CreateObject("InternetExplorer.application")
でIEを立ち上げています。そのときにフォーカスが新しく立ち上がったIE
に移ってしまいます。
そのIEでは自動で処理をしてquitするので、そちらにはフォーカスを移し
たくないのですが、そのようなIEの操作の仕方は可能でしょうか？
ばんのしゃーによかばんた さん
2006年 01月 09日 16時 48分 03秒
今度は、viewsource:プロトコルです。
定義は、filerun:プロトコルと同様です。
>ばんのしゃーによかばんた さん 2005年 09月 07日 19時 26分 37秒
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim URL
Dim Protocol
Dim wShell
Dim Shell
Dim ie
Dim fVC
URL=WScript.Arguments.Item(0)
Protocol=Left(URL,11)
If LCase(Protocol)<>"viewsource:" Then
WScript.Echo "Invalid Protocol:",Protocol
WScript.Quit
End If
URL=Mid(URL,12)
If MsgBox(URL,vbExclamation+vbOkCancel,"viewsource:URL Really OK ?")=vbCancel Then
WScript.Quit
End If
Set wShell=CreateObject("WScript.Shell")
Set Shell=CreateObject("Shell.Application")
Set ie=WScript.CreateObject("InternetExplorer.Application","IE_")
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.designMode="On"
ie.Navigate URL
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Left=ie.Document.parentWindow.screen.width
ie.Visible=True
Do While Not Shell.Windows().Item() Is ie
WScript.Sleep 100
Loop
wShell.SendKeys "%(VC)"
Do While Not fVC
WScript.Sleep 100
Loop
ie.Quit
WScript.Quit
Sub IE_StatusTextChange(Text)
If Text="このページのソース (HTML) を表示します。" Then fVC=True
End Sub
――――――――――――――――――――――――――――――――――――――
こういうIEのメニュー操作がSendKeysでなくExecWBで出来れば便利なのですが。。。
SendKeysなので、待ち合わせに苦労します。
ばんのしゃーによかばんた さん
2006年 01月 09日 16時 47分 43秒
IEで「名前を付けて保存」するときのフォルダは、前回保存したフォルダです。
これは、便利なようで、不便なときもあります。
例えば、ローカルのHTMLファイルを開いて、保存し直そうとしても、
同じフォルダにはなりません。これには少々苛々します。
そこで、保存先を同じフォルダに変えるスクリプトです。
「お気に入り」や｢リンク」に入れて使います。
IEから実行すると、現在表示中のファイルのフォルダを次の保存先にします。
エクスプローラから実行すると、現在表示中のフォルダを次の保存先にします。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim Shell
Dim ie
Dim Path
Dim wShell
Const Key="HKCU\Software\Microsoft\Internet Explorer\Main\Save Directory"
Set Shell=CreateObject("Shell.Application")
Set ie=Shell.Windows().Item()
If ie Is Nothing Then
ElseIf ie.ReadyState<>4 Then
ElseIf ie.Busy Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderView") Then
Path=ie.Document.Folder.Self.Path
ElseIf TypeName(ie.Document)="HTMLDocument" Then
Path=Mid(ie.Document.URLUnencoded,Len("file://")+1)
Path=Left(Path,InStrRev(Path,"\"))
End If
If IsEmpty(Path) Then
WScript.Echo "Error!"
WScript.Quit
End If
Set wShell=CreateObject("WScript.Shell")
wShell.RegWrite Key,Path,"REG_SZ"
WScript.Quit
――――――――――――――――――――――――――――――――――――――
ところで、一般に、If ie.Busy Then は、If ie.ReadyState<>4 Then より後に
チェックしたほうがよさそうです。
ie.Busyは参照しただけでエラーになることがあります。
ばんのしゃーによかばんた さん
2006年 01月 09日 16時 47分 22秒
ダブルクリックで常に決まったアプリを起動するのではなく、
毎回、右クリックメニューでアプリを選択したいってことはありませんか？
そんなとき、ダブルクリックで右クリックメニューを表示させる方法です。
デフォルトVerbに登録します。WScript.EXE SecondChoice.VBS "%1"
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim Path
Dim fso
Dim File
Dim wShell
Dim Shell
Dim ie
Dim FolderItem
Dim bStatusTextChange
Dim fStatusTextChange
Path=WScript.Arguments.Item(0)
Set fso=CreateObject("Scripting.FileSystemObject")
Set File=fso.GetFile(Path)
Set wShell=CreateObject("WScript.Shell")
Set Shell=CreateObject("Shell.Application")
Set ie=Shell.Windows().Item()
If ie Is Nothing Then
ElseIf ie.ReadyState<>4 Then
ElseIf ie.Busy Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderView")=0 Then
ElseIf ie.Document.Folder.Self.Path<>File.ParentFolder.Path Then
ElseIf ie.Document.SelectedItems().Count<>1 Then
ElseIf ie.Document.SelectedItems().Item(0).Path=File.Path Then
wShell.SendKeys "+{F10}"
WScript.Quit
End If
Set ie=WScript.CreateObject("InternetExplorer.Application","IE_")
ie.Height=0
ie.Width=0
ie.Navigate File.ParentFolder.Path
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set FolderItem=ie.Document.Folder.Items().Item(File.Name)
'MsgBox FolderItem.Name
ie.Document.SelectItem FolderItem,1+16
ie.Visible=True
Do While Not Shell.Windows().Item() Is ie
WScript.Sleep 100
Loop
bStatusTextChange=fStatusTextChange
wShell.SendKeys "+{F10}{Down}"
Do While fStatusTextChange=bStatusTextChange
WScript.Sleep 100
Loop
ie.Visible=False
Do While TypeName(ie)="IWebBrowser2"
ie.Quit
WScript.Sleep 1000
Loop
Sub IE_StatusTextChange(Text)
fStatusTextChange=fStatusTextChange+1
End Sub
――――――――――――――――――――――――――――――――――――――
本当は、SendKeysではなく、
Name=ie.Document.PopupItemMenu(FolderItem)
を使いたかったのですが、何故か使えません。どうして？
なので、メニューが閉じたことが検出できないのです。
ここで使っている新開発の待ち合わせ方法は他にも使えそうです。
IE/Explorerがアクティブになるのを待つ。AppActivateよりお勧め。
ie.Visible=True
Do While Not Shell.Windows().Item() Is ie
WScript.Sleep 100
Loop
メニューが開くのを待つ。{Down}でStatusTextChangeが発生する。
bStatusTextChange=fStatusTextChange
wShell.SendKeys "+{F10}{Down}"
Do While fStatusTextChange=bStatusTextChange
WScript.Sleep 100
Loop
ie.Visible=False
Sub IE_StatusTextChange(Text)
fStatusTextChange=fStatusTextChange+1
End Sub
メニュー処理の終了を待つ。メニュー処理中はQuitが無効。
Do While TypeName(ie)="IWebBrowser2"
ie.Quit
WScript.Sleep 1000
Loop
フォーカスが他のIE/Explorerに移るのを待つ。
Do While Shell.Windows().Item() Is ie
WScript.Sleep 100
Loop
ちゃっぴ さん
2006年 01月 09日 13時 17分 57秒
IIS の Metabase に書き込んだ情報の Byte 数増加の件ですが、
Image から復元させたところ、問題が再現しなくなりました。
何なんだろ…
どうもお騒がせしました…
ちゃっぴ さん
2006年 01月 09日 00時 52分 01秒
あ、環境を書き忘れました・・・(ーー;)
Windows Xp Professional IIS 5.1 での現象です。
IIS Resource Kit は 2003 のを使用しています。
ちゃっぴ さん
2006年 01月 09日 00時 42分 41秒
なんかいろいろやっていたら、MetaBase Explorer が
表示されなくなりました。
しょうがいない、Image からまた復旧させるか…
> WScipt.Echo
WSCRIPT.ECHO の間違いです。
# 本質とは関係ありませんが…
ADSI IIS Provider を通して、IIS の Metabase を操作したとき、
なぜか Byte が 2 Byte 増えるのは相変わらずなぞですので、
ご存知の方、どうかご教授願います。
ちゃっぴ さん
2006年 01月 08日 23時 57分 24秒
IIS の Default Root を C Drive 以外の Directory に変更する
ADSI を用いた Script 作成中に気づいたこと。
なんか、文字列と Byte が一致しません。
IIS Metabase Explorer (IIS Resource Kit) で覗くと
ところにより、2 Byte 多くなっているようです。
# Trim とか NullChar 削除してもダメなのが…
【Source】
Const ForReading = &H1&
Const MD_BACKUP_NEXT_VERSION = &HFFFFFFFF
Const MD_BACKUP_HIGHEST_VERSION = &HFFFFFFFE
Const MD_BACKUP_FORCE_BACKUP = &H4&
Const MD_BACKUP_SAVE_FIRST = &H2&
Const IMPORT_TEXT_PATH = ""
Private objIIS ' As IISExt.IISComputer
Sub test()
Dim objWshNetwork ' As IWshRuntimeLibrary.WshNetwork
Dim objFSO ' As IWshRuntimeLibrary.FileSystemObject
Dim objImportText ' As IWshRuntimeLibrary.TextStream
Dim strHostname ' As String
Dim strIISADsPath ' As String
Dim strImportText ' As String
Dim vntRowArray ' As Variant
Dim vntRowBuf ' As Variant
Dim vntColArray ' As Variant
Dim lngReturn ' As Long
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objImportText = objFSO.OpenTextFile( _
IMPORT_TEXT_PATH, ForReading)
strImportText = objImportText.ReadAll
objImportText.Close
Set objImportText = Nothing
Set objFSO = Nothing
vntRowArray = Split(strImportText, vbCrLf)
If Err.Number <> 0 Then
WScipt.Echo "Read Text Error"
Exit Sub
End If
Set objWshNetwork = CreateObject("WScript.Network")
strHostname = objWshNetwork.ComputerName
Set objWshNetwork = Nothing
strIISADsPath = "IIS://" & strHostname
Set objIIS = GetObject(strIISADsPath)
objIIS.Backup "", MD_BACKUP_NEXT_VERSION, _
MD_BACKUP_FORCE_BACKUP Or MD_BACKUP_SAVE_FIRST
If Err.Number <> 0 Then
WScipt.Echo "Metabase Backup Error"
Exit Sub
End If
On Error Resume Next
For Each vntRowBuf In vntRowArray
If vntRowBuf <> "" Then
vntColArray = Split(vntRowBuf, vbTab)
lngReturn = lngReturn + ModifyMetaData( _
strIISADsPath & "/" & vntColArray(0), _
vntColArray(1), _
LTRIM(vntColArray(2)))
'Left(vntColArray(2), InStrRev(vntColArray(2), vbNullChar) - 1))
End If
Next
If Err.Number <> 0 Or lngReturn <> 0 Then
objIIS.Restore "", MD_BACKUP_HIGHEST_VERSION, 0
WScript.Echo "Change MetaBase Error"
End If
Set objIIS = Nothing
End Sub
Function ModifyMetaData( _
strADsPath, _
strPropName, _
strModifyValue)
Dim objTarget ' As ActiveDs.IADs
'On Error Resume Next
Set objTarget = GetObject(strADsPath)
With objTarget
.Put strPropName, strModifyValue
.SetInfo
End With
If Err.Number = 0 Then
ModifyMetaData = 0
Else
ModifyMetaData = -1
WScript.Echo "Failed" & vbTab & strADsPath & vbTab & strPropName & vbTab & strModifyValue
End If
On Error GoTo 0
Set objTarget = Nothing
End Function
IMPORT_TEXT_PATH には、こんな Tab 区切りの Text を指定しています。
W3SVC
LogFileDirectory
D:\LogFiles
W3SVC/1/Root
Path
D:\Inetpub\wwwroot
W3SVC/1/ROOT/Scripts
Path
D:\Inetpub\Scripts
MSFTPSVC
LogFileDirectory
D:\LogFiles
MSFTPSVC/1/ROOT
Path
D:\Inetpub\ftproot
SmtpSvc
LogFileDirectory
D:\LogFiles
SmtpSvc/1
QueueDirectory
D:\Inetpub\mailroot\Queue
SmtpSvc/1
PickupDirectory
D:\Inetpub\mailroot\Pickup
SmtpSvc/1
DropDirectory
D:\Inetpub\mailroot\Drop
SmtpSvc/1
BadMailDirectory
D:\Inetpub\mailroot\Badmail
SmtpSvc/1
LogFileDirectory
D:\LogFiles
これって、Bug じゃないですか？
ばんのしゃーによかばんた さん
2006年 01月 08日 15時 46分 00秒
>ばんのしゃーによかばんた さん 2006年 01月 04日 16時 12分 00秒
>
>旧作のZIP.VBSも、置換のエラーを回避するように直しました。
この記事、先頭に改行を余分に入れているのですが、これがないと、
fso.OpenTextFile(file,,,vbUseDefault).ReadAll()
がShift JISなのにUnicodeと誤判定して文字化けするのです。
｢障害」だとは思いますが、全く以って役立たずな機能です。
そこで、代替策。
BOM=fso.OpenTextFile(file).Read(2)
fUNICODE=False
If Len(BOM)>1 Then If Asc(Mid(BOM,1,1))=&HFF And Asc(Mid(BOM,2,1))=&HFE Then fUNICODE=True
fso.OpenTextFile(file,,,fUNICODE).ReadAll()
ばんのしゃーによかばんた さん
2006年 01月 08日 15時 45分 38秒
CABのGUI強化策の第３弾です。
ZIPファイルの「圧縮 (zip 形式) フォルダ.ZFSendToTarget」に相当します。
ファイル(複数可)を「送る」で、CABファイルを作成/追加/置換します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim optind
Dim fso
Dim CABfile
Dim dic
Dim Path
Dim File
Dim MakeCab
Dim Shell
Dim zFolder
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim tFolderItem
If WScript.Arguments.Count<1 Then
WScript.Echo "Usage: Start MakeCAB.VBS files..."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
CABfile=WScript.Arguments(0)
If UCase(fso.GetExtensionName(CABfile))="CAB" Then
optind=1
Else
CABfile=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetBaseName(CABfile)&".CAB")
End If
If WScript.Arguments.Count<optind+1 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
CABfile=fso.GetAbsolutePathName(CABfile)
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind To WScript.Arguments.Count-1
Path=WScript.Arguments.Item(optind)
File=LCase(fso.GetFileName(Path))
If dic.Exists(File) Then
WScript.Echo File,"- Duplicate Names."
WScript.Quit
End If
If Not fso.FileExists(Path) Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Path=fso.GetAbsolutePathName(Path)
dic.Add File,Path
Next
Set MakeCab=CreateObject("MakeCab.MakeCab.1")
If fso.FileExists(CABfile) Then
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
tFolderName=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(fso.GetFileName(zFolderItem.Path))) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
Set zFolder=Nothing
Shell.NameSpace(ssfBITBUCKET).MoveHere CABfile
Do While fso.FileExists(CABfile)
WScript.Sleep 100
Loop
MakeCab.CreateCab (CABfile),False,False,False
For Each tFolderItem In tFolder.Items()
MakeCab.AddFile tFolderItem.Path,fso.GetFileName(tFolderItem.Path)
Next
fso.DeleteFolder tFolderName
Else
MakeCab.CreateCab (CABfile),False,False,False
End If
For Each File In dic
MakeCab.AddFile (dic.Item(File)),(File)
Next
MakeCab.CloseCab
ばんのしゃーによかばんた さん
2006年 01月 07日 17時 35分 11秒
ZIPの場合は、ファイルをZIPファイルにドロップしたり、
フォルダビューにファイルを貼り付けたり、出来ますが、
CABの場合は、そういうことが出来ません。
そこで、CABのGUI強化策の第２弾です。
しかし、なぜか、CABファイルにドロップハンドラを登録することが出来ません。
WSHのドロップハンドラをCLSID\{...}\ShellEx\DropHandlerに入れてみたのですが、
効きません。なぜなんでしょうね？
仕方がないので、これまたリンクで代替します。
ファイル(複数可)を「コピー」しておいて、
CABファイルを選択してリンクから起動するか、(スクリプトをリンクに登録しておいて)
CABファイルのフォルダビューを開いてリンクから起動するか、
CABファイルをスクリプトにドロップするか、
CABファイルを送るか、(スクリプトをSendToに登録しておいて)
します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim CABfile
Dim Shell
If WScript.Arguments.Count=0 Then
Call ParentProcess()
ElseIf WScript.Arguments.Count=1 And LCase(Right(WScript.Arguments.Item(0),4))=".cab" Then
Call ParentProcess()
Else
Call ChildProcess()
End If
WScript.Quit
Sub ChildProcess()
Dim k:k=0
Dim args():ReDim args(WScript.Arguments.Count-1)
For k=0 To WScript.Arguments.Count-1
args(k)=WScript.Arguments(k)
Next
Call PutClipByMsIE(Join(args,vbCrLf))
End Sub
Sub ParentProcess()
Dim Folder
Dim FolderItem
Dim Verb
Dim k
Dim Text
Dim ie
Set Shell=CreateObject("Shell.Application")
If WScript.Arguments.Count Then
CABfile=WScript.Arguments.Item(0)
Else
Set ie=Shell.Windows().Item()
If ie.Busy Then
ElseIf ie.ReadyState<>4 Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderView")=0 Then
ElseIf LCase(Right(ie.Document.Folder.Self.Path,4))=".cab" Then
CABfile=ie.Document.Folder.Self.Path
ElseIf ie.Document.SelectedItems().Count=1 Then
CABfile=ie.Document.SelectedItems().Item(0).Path
End If
If IsEmpty(CABfile) Then
WScript.Echo "貼り付け先CABファイルが選択されていません。"
WScript.Quit
End If
End If
Set Folder=Shell.NameSpace(Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\")))
Set FolderItem=Folder.Items().Item(WScript.ScriptName)
For Each Verb In FolderItem.Verbs()
If Verb.Name="貼り付け(&P)" Then Exit For
Next
If IsEmpty(Verb) Then
WScript.Echo "貼り付け元ファイルがありません。"
WScript.Quit
End If
Verb.DoIt
For k=1 To 100
WScript.Sleep 100
Text=GetCLipByMsIE()
If Text<>"" Then Exit For
Next
If Text="" Then
WScript.Echo "Failed. Timed Out."
WScript.Quit
End If
Call CreateCab(Split(Text,vbCrLf))
End Sub
Sub CreateCAB(Files)
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim fso
Dim dic
Dim Path
Dim File
Dim MakeCab
Dim Shell
Dim zFolder
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim tFolderItem
If UBound(Files)<0 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
Set dic=CreateObject("Scripting.Dictionary")
For Each Path In Files
File=LCase(fso.GetFileName(Path))
If dic.Exists(File) Then
WScript.Echo File,"- Duplicate Names."
WScript.Quit
End If
If Not fso.FileExists(Path) Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Path=fso.GetAbsolutePathName(Path)
dic.Add File,Path
Next
Set MakeCab=CreateObject("MakeCab.MakeCab.1")
If fso.FileExists(CABfile) Then
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
tFolderName=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(fso.GetFileName(zFolderItem.Path))) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
Set zFolder=Nothing
Shell.NameSpace(ssfBITBUCKET).MoveHere CABfile
Do While fso.FileExists(CABfile)
WScript.Sleep 100
Loop
MakeCab.CreateCab (CABfile),False,False,False
For Each tFolderItem In tFolder.Items()
Path=tFolderItem.Path
File=fso.GetFileName(Path)
MakeCab.AddFile (Path),(File)
Next
fso.DeleteFolder tFolderName
Else
MakeCab.CreateCab (CABfile),False,False,False
End If
For Each File In dic
MakeCab.AddFile (dic.Item(File)),(File)
Next
MakeCab.CloseCab
End Sub
Function GetCLipByMsIE()
Const OLECMDID_PASTE = 13
Const OLECMDEXECOPT_DODEFAULT = 0
Dim ie
Set ie=CreateObject("InternetExplorer.Application")
'ie.Visible=true
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.write "<html><body><textarea id=txt></textarea></body></html>"
ie.Document.all.txt.focus
Call ie.ExecWB(OLECMDID_PASTE,OLECMDEXECOPT_DODEFAULT)
GetCLipByMsIE=ie.document.all.txt.Value
ie.Quit
End Function
Function PutClipByMsIE(Text)
Const OLECMDID_COPY = 12
Const OLECMDID_SELECTALL = 17 '(&H11)
Const OLECMDEXECOPT_DODEFAULT = 0
Dim ie
Set ie=CreateObject("InternetExplorer.Application")
'ie.Visible=true
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.Body.InnerText=Text
ie.ExecWB OLECMDID_SELECTALL,OLECMDEXECOPT_DODEFAULT
ie.ExecWB OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT
ie.Quit
End Function
ばんのしゃーによかばんた さん
2006年 01月 07日 17時 34分 46秒
CABのGUIはZIPに比べて貧弱です。CABのフォルダビューでは、「削除」も出来ません。
そこで、CABのGUI強化策の第1弾。CABのフォルダビューで「削除」を可能にします。
選択して、これまた「送る」も出来ないので、代わりに、｢リンク」から起動します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim Shell
Dim ie
Dim zFolder
Dim CABfile
Dim fso
Dim dic
Dim zFolderItem
Dim Path
Dim File
Dim tFolderName
Dim tFolder
Dim tFolderItem
Dim MakeCab
Set Shell=CreateObject("Shell.Application")
Set ie=Shell.Windows().Item()
If ie.Busy Then
ElseIf ie.ReadyState<>4 Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderView") Then
Set zFolder=ie.Document.Folder
End If
If IsEmpty(zFolder) Then
WScript.Echo "Not Explorer."
WScript.Quit
End If
CABfile=zFolder.Self.Path
Set fso=CreateObject("Scripting.FileSystemObject")
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
If ie.Document.SelectedItems().Count=0 Then
WScript.Echo "No Selection."
WScript.Quit
End If
Set dic=CreateObject("Scripting.Dictionary")
For Each zFolderItem In ie.Document.SelectedItems()
dic.Add LCase(fso.GetFileName(zFolderItem.Path)),1
Next
tFolderName=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(fso.GetFileName(zFolderItem.Path))) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
Shell.NameSpace(ssfBITBUCKET).MoveHere CABfile
Do While fso.FileExists(CABfile)
WScript.Sleep 100
Loop
Set MakeCab=CreateObject("MakeCab.MakeCab.1")
MakeCab.CreateCab (CABfile),False,False,False
For Each tFolderItem In tFolder.Items()
Path=tFolderItem.Path
File=fso.GetFileName(Path)
MakeCab.AddFile (Path),(File)
Next
MakeCab.CloseCab
fso.DeleteFolder tFolderName
AKA さん
2006年 01月 07日 06時 38分 40秒
日本全国で5,6人はいると思われるDW7ファンの方々、お待たせ致しました！(って待ってないか・・・(^^;))
DW7.03の登場です。
今回も新機能をいくつか追加しましたが、最も重要なのはCのポインタ型変数と同等の機能、すなわち、AddressOfにOSなどDW以外のモジュールが作成した既存の構造体のアドレスを入れることができるようになった点です。もともとPeek/Pokeがあるので既存の構造体にアクセスすること自体は可能だったわけですが、構造体オブジェクトとして扱うことができるので格段に便利になりました。この点ではVBをしのぐ機能と言えるでしょう。ただし記法上ではほとんど何も変わっていないように見えるので注意してご覧ください。
DW7.03
http://winscript.s41.xrea.com/wiki/index.php?plugin=attach&pcmd=open&file=DW95703.ZIP&refer=%5B%5B%A5%A2%A5%C3%A5%D7%A5%ED%A1%BC%A5%C0%A1%BC%5D%5D
さらに今回はもう一つの非常に重要なアイテムを公開します。
WIN32API.VBSです。
これはWin32APIの定数および関数と構造体の定義を書いたVBSです。VBにおける、WIN32API.TXTからの定義をすでにコードモジュール内に貼り付けたような形のもの、と言えます。
使い方は、そのままExecuteGlobalを行ってメインVBSに結合させます。
ここで、ファイル内容をExecuteGlobalするためにはファイル内容を読みだすルーチンがなければならないわけですが、DW7.03にそれをサポートするメソッド「fc」を組み込みました。
ので、Cの#includeディレクティブのような感覚で簡単に結合ができます。
WIN32API.VBSは、いろんなVBSからインクルードできるようにC:\UTLとかC:\VBSとかそういう特別なフォルダに入れておくといいと思います。
ExecuteGlobalが済めばWIN32API.VBSに書いてある定数、関数、構造体は使い放題です。よかったよかった。
サンプルは、WSHのプロセスのメモリ情報を表示するものです。(CSCRIPTでMOREして使ってください)
サンプルではWIN32API.VBSの他に、DUMP.VBSと、MEMINFO.VBSというライブラリ化したVBSが使われています。fcを使えばこうしたVBSのライブラリ化が簡単にできるようになります。
ただ・・・WIN32API.VBSにWin32APIのすべてを入れることはできません。書くのが大変で・・・(^^;) CのヘッダやWIN32API.TXTからオートコンバートとかできたらいいんですが・・・
しかし、仮にすべてを入れたとするとExecuteGlobalが終わるまで数分かかるかも。というかメモリを使いすぎてOS全体がのろくなったりして・・・(^^;;)
使わない関数はいらない、という人などは、WIN32API.VBSから部分的にコピって使ってください。
なお、WIN32API.VBSにはまだまだ関数も構造体も少ないですが、とりあえず私が「あれあったらいいな」と思ったものは追加していきますので、リクエスト等もお願いします。新バージョンのWIN32API.VBSや差分をアップしてくれてもいいです。
Win32APIを使わない、という人でもfcを使えばVBSのライブラリ化が楽にできますのでDW7.03を試してみてください。
よさげなライブラリを作った人は公開してくださいね。
WIN32API.VBS
http://winscript.s41.xrea.com/wiki/index.php?plugin=attach&pcmd=open&file=WAPI000.ZIP&refer=%5B%5B%A5%A2%A5%C3%A5%D7%A5%ED%A1%BC%A5%C0%A1%BC%5D%5D
'<<MAIN.VBS>>
' スクリプティングホストのメモリ空間の情報を表示します。
Set g_dw = CreateObject("DynamicWrapper")
ExecuteGlobal g_dw.fc("WIN32API.VBS")
ExecuteGlobal g_dw.fc("DUMP.VBS")
ExecuteGlobal g_dw.fc("MEMINFO.VBS")
CommandLineStringAddress = g_dw.GetCommandLineA
Text = "Command Line = """ & g_dw.PeekAString(CommandLineStringAddress) & """"
hInstance = g_dw.GetModuleHandleA(vbNullString)
Text = Text & vbCrLf & "hInstance = " & HexN(hInstance, 8)
ModuleFileName = String(MAX_PATH, "?")
g_dw.GetModuleFileNameA hInstance, ModuleFileName, MAX_PATH
Text = Text & vbCrLf & "Process Main Module File Name = """ & ModuleFileName & """"
Set mbi = g_dw.MEMORY_BASIC_INFORMATION
g_dw.VirtualQuery hInstance, mbi.AddressOf, mbi.SizeOf
Text = Text & vbCrLf & "AlcBase " & " " & "Base " & " " & "Size " & " " & "Protect "
Text = Text & vbCrLf & HexN(mbi.AllocationBase, 8) & " " & HexN(mbi.BaseAddress, 8) & " " & HexN(mbi.RegionSize, 8) & " " & HexN(mbi.Protect, 8)
Text = Text & vbCrLf
Text = Text & vbCrLf & GetDump(mbi.BaseAddress, &H100)
WScript.Echo Text & vbCrLf
WScript.Echo GetMemoryInfo()
WScript.Quit
'<<DUMP.VBS>>
' Function GetDump(Addr, Length)
' メモリアドレスAddrからLengthバイトをダンプした結果の文字列を返します。
Option Explicit
Function GetDump(Addr, Length)
Dim Text
Text = ""
Dim I
For I = 0 To Length - 1 Step 16
Text = Text & HexN(Addr + I, 8) & " "
Dim J
For J = 0 To 7
Text = Text & HexN(g_dw.Peek(Addr + I + J), 2) & " "
Next
Text = Text & " "
For J = 8 To 15
Text = Text & HexN(g_dw.Peek(Addr + I + J), 2) & " "
Next
Text = Text & " "
For J = 0 To 15
Dim CharCode
CharCode = g_dw.Peek(Addr + I + J)
If CharCode < &H20 Or &H7F <= CharCode Then
CharCode = AscB(".")
End If
Text = Text & Chr(CharCode)
Next
Text = Text & vbCrLf
Next
If Right(Text, 2) = vbCrLf Then
Text = Left(Text, Len(Text) - 2)
End If
GetDump = Text
End Function
'<<MEMINFO.VBS>>
' Function GetMBIInfo(mbi)
' MEMORY_BASIC_INFORMATION構造体mbiから情報を整形した結果の文字列を返します。
' Function GetMemoryInfo()
' カレントプロセスのメモリ情報の文字列を返します。
' Function GetMZInfo(mbi)
' MEMORY_BASIC_INFORMATION構造体mbiの示す仮想メモリにおけるEXEヘッダの情報の文字列を返します。当該メモリがEXEヘッダでない場合""を返します。
Option Explicit
Function GetMemoryInfo()
Dim mbi
Set mbi = g_dw.MEMORY_BASIC_INFORMATION
Dim Address
Address = 0
Dim Text
Text = "AlcBase " & " " & "Base " & " " & "Size " & " " & "Protect " & vbCrLf
Do While True
If g_dw.VirtualQuery(Address, mbi.AddressOf, mbi.SizeOf) <> mbi.SizeOf Then
Exit Do
End If
If mbi.Type And MEM_COMMIT <> 0 Then
Text = Text & GetMBIInfo(mbi) & vbCrLf
If (mbi.Protect And &HFF) <> 0 And (mbi.Protect And &HFF) <> PAGE_NOACCESS Then
Dim MZInfo
MZInfo = GetMZInfo(mbi)
If Len(MZInfo) <> 0 Then
Text = Text & MZInfo & vbCrLf
End If
End If
End If
Address = Address + mbi.RegionSize
Loop
GetMemoryInfo = Text
End Function
Function GetMBIInfo(mbi)
Dim Text
Text = HexN(mbi.AllocationBase, 8) & " " & HexN(mbi.BaseAddress, 8) & " " & HexN(mbi.RegionSize, 8) & " " & HexN(mbi.Protect, 8)
If (mbi.Protect And PAGE_GUARD) <> 0 Then
Text = Text & " " & "PAGE_GUARD"
End If
Select Case mbi.Protect And &HFF
Case 0
Dim PName
PName = ""
Case PAGE_NOACCESS
PName = "PAGE_NOACCESS"
Case PAGE_READONLY
PName = "PAGE_READONLY"
Case PAGE_READWRITE
PName = "PAGE_READWRITE"
Case PAGE_WRITECOPY
PName = "PAGE_WRITECOPY"
Case PAGE_EXECUTE
PName = "PAGE_EXECUTE"
Case PAGE_EXECUTE_READ
PName = "PAGE_EXECUTE_READ"
Case PAGE_EXECUTE_READWRITE
PName = "PAGE_EXECUTE_READWRITE"
Case PAGE_EXECUTE_WRITECOPY
PName = "PAGE_EXECUTE_WRITECOPY"
Case Else
PName = "?"
End Select
Text = Text & " " & PName
GetMBIInfo = Text
End Function
Function GetMZInfo(mbi)
Dim dwOldProtect
Set dwOldProtect = g_dw.DWORD
Dim bRes
If (mbi.Protect And PAGE_GUARD) <> 0 Then
If g_dw.VirtualProtect(mbi.BaseAddress, mbi.RegionSize, mbi.Protect And Not PAGE_GUARD, dwOldProtect.AddressOf) = 0 Then
WScript.Echo "VirtualProtect() Error"
WScript.Quit
End If
End If
GetMZInfo = ""
If g_dw.PeekShort(mbi.BaseAddress) = AscB("M") + AscB("Z") * 256 Then
Dim hModule
hModule = mbi.BaseAddress
Dim ModuleName
ModuleName = String(MAX_PATH, "?")
g_dw.GetModuleFileNameA hModule, ModuleName, MAX_PATH
Dim ExeHeader
Set ExeHeader = g_dw.IMAGE_DOS_HEADER
ExeHeader.AddressOf = hModule
Dim PEHeader
Set PEHeader = g_dw.IMAGE_FILE_HEADER
PEHeader.AddressOf = hModule + ExeHeader.e_lfanew + 4
Dim SectionHeader
Set SectionHeader = g_dw.IMAGE_SECTION_HEADER
SectionHeader.AddressOf = PEHeader.AddressOf + PEHeader.SizeOf + PEHeader.SizeOfOptionalHeader
Dim SectionInfo
SectionInfo = ""
Dim I
For I = 1 To PEHeader.NumberOfSections
Dim SectionName
SectionName = ""
Dim J
For J = 0 To SectionHeader.MemberSize("Name") - 1
Dim C
C = SectionHeader.Name(J)
If C = 0 Then
Exit For
End If
SectionName = SectionName & Chr(C)
Next
SectionInfo = SectionInfo & " " & HexN(hModule + SectionHeader.VirtualAddress, 8) & " " & HexN(SectionHeader.VirtualSize, 8) & " """ & SectionName & """" & vbCrLf
SectionHeader.AddressOf = SectionHeader.AddressOf + SectionHeader.SizeOf
Next
GetMZInfo = " " & """" & ModuleName & """" & vbCrLf & SectionInfo
End If
If (mbi.Protect And PAGE_GUARD) <> 0 Then
If g_dw.VirtualProtect(mbi.BaseAddress, mbi.RegionSize, dwOldProtect.Value, dwOldProtect.AddressOf) = 0 Then
WScript.Echo "VirtualProtect() Error"
WScript.Quit
End If
End If
End Function
'<<WIN32API.VBS>> (部分。フルセットはアップローダにあります)
Option Explicit
Dim g_dw
Set g_dw = CreateObject("DynamicWrapper")
'--- Basis
Const C_NULL = 0
Const C_FALSE = 0
Const INVALID_HANDLE_VALUE = -1
Const MAX_PATH = 260
g_dw.Register "KERNEL32", "SetLastError", "i=l", "r=l"
g_dw.Register "KERNEL32", "GetLastError", "r=l"
g_dw.RegisterStruct "DWORD", "l", "Value"
g_dw.RegisterStruct "WORD", "t", "Value"
g_dw.RegisterStruct "BYTE", "c", "Value"
g_dw.RegisterStruct "LONG", "l", "Value"
g_dw.RegisterStruct "SHORT", "t", "Value"
g_dw.RegisterStruct "CHAR", "c", "Value"
'--- Module
g_dw.Register "KERNEL32", "GetModuleHandleA", "i=s", "r=l"
g_dw.Register "KERNEL32", "GetModuleFileNameA", "i=lrl", "r=l"
g_dw.Register "KERNEL32", "LoadLibraryA", "i=s", "r=l"
g_dw.Register "KERNEL32", "FreeLibrary", "i=l", "r=l"
g_dw.Register "KERNEL32", "GetProcAddress", "i=ls", "r=l"
g_dw.RegisterName "GetProcAddressOrdinal", "KERNEL32", "GetProcAddress", "i=ll", "r=l"
'--- Virtual
Const PAGE_NOACCESS = 1
Const PAGE_READONLY = 2
Const PAGE_READWRITE = 4
Const PAGE_WRITECOPY = 8
Const PAGE_EXECUTE = &H10
Const PAGE_EXECUTE_READ = &H20
Const PAGE_EXECUTE_READWRITE = &H40
Const PAGE_EXECUTE_WRITECOPY = &H80
Const PAGE_GUARD = &H100
Const PAGE_NOCACHE = &H200
Const PAGE_WRITECOMBINE = &H400
Const MEM_COMMIT = &H1000
Const MEM_RESERVE = &H2000
Const MEM_DECOMMIT = &H4000
Const MEM_RELEASE = &H8000
Const MEM_FREE = &H10000
Const MEM_PRIVATE = &H20000
Const MEM_MAPPED = &H40000
Const MEM_RESET = &H80000
Const MEM_TOP_DOWN = &H100000
Const MEM_WRITE_WATCH = &H200000
Const MEM_PHYSICAL = &H400000
Const MEM_4MB_PAGES = &H80000000
g_dw.RegisterStruct "MEMORY_BASIC_INFORMATION", "lllllll", "BaseAddress", "AllocationBase", "AllocationProtect", "RegionSize", "State", "Protect", "Type"
g_dw.Register "KERNEL32", "VirtualQuery", "i=lll", "r=l"
g_dw.Register "KERNEL32", "VirtualProtect", "i=llll", "r=l"
g_dw.Register "KERNEL32", "VirtualAllocEx", "i=lllll", "r=l"
'--- Process & Thread
g_dw.Register "KERNEL32", "GetCommandLineA", "r=l"
g_dw.Register "KERNEL32", "ExitProcess", "i=l", "r=l"
g_dw.Register "KERNEL32", "TerminateProcess", "i=ll", "r=l"
g_dw.Register "KERNEL32", "GetExitCodeProcess", "i=ll", "r=l"
Const PROCESS_TERMINATE = 1
Const PROCESS_CREATE_THREAD = 2
Const PROCESS_SET_SESSIONID = 4
Const PROCESS_VM_OPERATION = 8
Const PROCESS_VM_READ = &H10
Const PROCESS_VM_WRITE = &H20
Const PROCESS_DUP_HANDLE = &H40
Const PROCESS_CREATE_PROCESS = &H80
Const PROCESS_SET_QUOTA = &H100
Const PROCESS_SET_INFORMATION = &H200
Const PROCESS_QUERY_INFORMATION = &H400
Const STANDARD_RIGHTS_REQUIRED = &HF0000
Const SYNCHRONIZE = &H100000
'Const PROCESS_ALL_ACCESS = STANDARD_RIGHTS_REQUIRED Or SYNCHRONIZE Or &HFFF
Const PROCESS_ALL_ACCESS = &H1F0FFF
g_dw.Register "KERNEL32", "OpenProcess", "i=lll", "r=l"
g_dw.Register "KERNEL32", "ReadProcessMemory", "i=lllll", "r=l"
g_dw.Register "KERNEL32", "WriteProcessMemory", "i=lllll", "r=l"
g_dw.RegisterStruct "SECURITY_ATTRIBUTES", "lll", "nLength", "lpSecurityDescriptor", "bInheritHandle"
g_dw.RegisterStruct "PROCESS_INFORMATION", "llll", "hProcess", "hThread", "dwProcessId", "dwThreadId"
Const STARTF_USESHOWWINDOW = 1
Const STARTF_USESIZE = 2
Const STARTF_USEPOSITION = 4
Const STARTF_USECOUNTCHARS = 8
Const STARTF_USEFILLATTRIBUTE = &H10
Const STARTF_RUNFULLSCREEN = &H20' // ignored for non-x86 platforms
Const STARTF_FORCEONFEEDBACK = &H40
Const STARTF_FORCEOFFFEEDBACK = &H80
Const STARTF_USESTDHANDLES = &H100
g_dw.RegisterStruct "STARTUPINFOA", "llllllllllllllllll", "cb", "lpReserved", "lpDesktop", "lpTitle", "dwX", "dwY", "dwXSize", "dwYSize", "dwXCountChars", "dwYCountChars", "dwFillAttribute", "dwFlags", "wShowWindow", "cbReserved2", "lpReserved2", "hStdInput", "hStdOutput", "hStdError"
g_dw.Register "KERNEL32", "CreateProcessA", "i=llllllllll", "r=l"
g_dw.Register "KERNEL32", "CreateThread", "i=llllll", "r=l"
g_dw.Register "KERNEL32", "CreateRemoteThread", "i=lllllll", "r=l"
'--- Toolhelp
g_dw.Register "KERNEL32", "CreateToolhelp32Snapshot", "i=uu", "r=l"
Const TH32CS_SNAPMODULE = 8
Const MAX_MODULE_NAME32 = 255
g_dw.RegisterStruct "MODULEENTRY32", "lllllllls256s260", "dwSize", "th32ModuleID", "th32ProcessID", "GlblcntUsage", "ProccntUsage", "modBaseAddr", "modBaseSize", "hModule", "szModule", "szExePath"
g_dw.Register "KERNEL32", "Module32First", "i=uu", "r=l"
g_dw.Register "KERNEL32", "Module32Next", "i=uu", "r=l"
Const TH32CS_SNAPPROCESS = 2
g_dw.RegisterStruct "PROCESSENTRY32", "llllllllls260", "dwSize", "cntUsage", "th32ProcessID", "th32DefaultHeapID", "th32ModuleID", "cntThreads", "th32ParentProcessID", "pcPriClassBase", "dwFlags", "szExeFile"
g_dw.Register "KERNEL32", "Process32First", "i=ll", "r=l"
g_dw.Register "KERNEL32", "Process32Next", "i=ll", "r=l"
Const TH32CS_SNAPTHREAD = 4
g_dw.RegisterStruct "THREADENTRY32", "lllllll", "dwSize", "cntUsage", "th32ThreadID", "th32OwnerProcessID", "tpBasePri", "tpDeltaPri", "dwFlags"
g_dw.Register "KERNEL32", "Thread32First", "i=ll", "r=l"
g_dw.Register "KERNEL32", "Thread32Next", "i=ll", "r=l"
'--- MessageBox
Const MB_OK = 0
Const MB_OKCANCEL = 1
Const MB_ABORTRETRYIGNORE = 2
Const MB_YESNOCANCEL = 3
Const MB_YESNO = 4
Const MB_RETRYCANCEL = 5
g_dw.Register "USER32", "MessageBoxA", "i=lssl", "r=l"
'--- EXE Header
g_dw.RegisterStruct "IMAGE_DOS_HEADER", "ttttttttttttttw4ttw10l", _
"e_magic", _
"e_cblp", _
"e_cp", _
"e_crlc", _
"e_cparhdr", _
"e_minalloc", _
"e_maxalloc", _
"e_ss", _
"e_sp", _
"e_csum", _
"e_ip", _
"e_cs", _
"e_lfarlc", _
"e_ovno", _
"e_res", _
"e_oemid", _
"e_oeminfo", _
"e_res2", _
"e_lfanew"
g_dw.RegisterStruct "IMAGE_FILE_HEADER", "ttllltt", _
"Machine", _
"NumberOfSections", _
"TimeDateStamp", _
"PointerToSymbolTable", _
"NumberOfSymbols", _
"SizeOfOptionalHeader", _
"Characteristics"
Const IMAGE_SIZEOF_SHORT_NAME = 8
g_dw.RegisterStruct "IMAGE_SECTION_HEADER", "s8llllllttl", _
"Name", _
"VirtualSize", _
"VirtualAddress", _
"SizeOfRawData", _
"PointerToRawData", _
"PointerToRelocations", _
"PointerToLinenumbers", _
"NumberOfRelocations", _
"NumberOfLinenumbers", _
"Characteristics"
Function HexN(Value, ColCnt)
HexN = Right(String(ColCnt - 1, "0") & Hex(Value), ColCnt)
End Function 'HexN
うっし〜 さん
2006年 01月 06日 23時 08分 22秒
うあ。書き込んでいる間に回答が････。
>新米MCPさん
おお。そういうことだったのですか。Setが抜けていたとは･･････。
助言を受けまして希望通りの動作確認が取れました。
本当にありがとうございます。
うっし〜 さん
2006年 01月 06日 23時 02分 36秒
>魔界の仮面弁士さん
なるほど。ただ残念ながらDCは常にDictionaryとして扱うようにしているので
問題ないはずですが、オブジェクトの判定はつけたほうがよさそうですね。
ありがとうございます。
ちなみに私が書いたソースの
'Dim tmpDC, tmpItems, i
'tmpDC = obj.GetBDC(0)
の部分のコメント外すと分かるのですが、
GetBDC = arrTmp(inNum).GetDC()
の行で怒られてしまうのです。
魔界の仮面弁士さんのコードに置き換えても同様に怒られてしまいました。
やはりDictionaryオブジェクトを別のクラスから利用するということは無理
なのでしょうか･････。
新米MCP さん
2006年 01月 06日 22時 56分 09秒
>うっし〜 さん 2006年 01月 06日 20時 45分 13秒
出遅れた…。
すでに魔界の仮面弁士さんのご指摘がありましたが、くやしいから投稿しちゃう。
21行目
>tmpDC = obj.GetBDC(0)
45行目
>GetBDC = arrTmp(inNum).GetDC()
89行目
>GetDC = DC
これらは前にSetをつけてください。
23行目
> WScript.echo tmpDC.Items(i)
Keyのコレクションは引数なしでobject.Items()ですから、
WScript.echo tmpDC.Items()(i)
これでご希望の動きをすると思います。
（WinXP Pro SP2で検証）
魔界の仮面弁士 さん
2006年 01月 06日 22時 42分 34秒
》うっし〜 さん 2006年 01月 06日 20時 45分 13秒
> Public Function GetDC()
> GetDC = DC
> End Function
この部分は、
Public Function GetDC()
If IsObject(DC) Then
Set GetDC = DC
Else
GetDC = DC
End If
End Function
では無いでしょうか。
# 変数 DC が常に Dictionary になっているのであれば、
# IsObject 判定無しで、いきなり Set しても大丈夫かも。
うっし〜 さん
2006年 01月 06日 20時 45分 13秒
初めまして。うっし〜といいます。
VBScriptでどうしてもうまくいかないところがあり、助言 or 解決方法を頂けな
いかと思い、書き込ませて頂きました。
＜環境＞ W2K SP4 + WSH Ver5.6
以下のようなソースにおいて、親クラス(AClass)から子クラス(BClass)の
Dictionaryオブジェクトを取得したいと考えているのですが、不正なプロパティ
と言われてしまい、うまくいきません。
オブジェクトを取得するためにはどのようにしたら良いのでしょうか？
=====================================================================
Option Explicit
Dim obj
Set obj = New AClass
'// 設定
obj.SetStrAName("Class_A") '// 親Class作成
obj.AddTmp("Class_B0") '// 子Class1作成
Call obj.AddBDC(0, "Key0", "Item0") '// Key0を設定
Call obj.AddBDC(0, "Key1", "Item1") '// Key1を設定
obj.AddTmp("Class_B1") '// 子Class2作成
Call obj.AddBDC(1, "KeyA", "ItemA") '// Key0を設定
'// データ確認
WScript.echo obj.GetStrAName()
WScript.echo obj.GetBDCName(0)
WScript.echo obj.GetBDCName(1)
'// Dictionaryオブジェクトを取得してKeyやItemを見たい
'Dim tmpDC, tmpItems, i
'tmpDC = obj.GetBDC(0)
'For i = 0 To tmpDC.Count - 1
' WScript.echo tmpDC.Items(i)
'Next
WScript.Quit
'----------
Class AClass
Private strAName, arrTmp()
Public Function GetStrAName()
GetStrAName = strAName
End Function
Public Sub SetStrAName(ByVal inString)
strAName = inString
End Sub
Public Sub AddBDC(ByVal inIndex, ByVal inKey, ByVal inItem)
Call arrTmp(inIndex).AddDC(inKey, inItem)
End Sub
Public Function GetBDC(ByVal inNum)
GetBDC = arrTmp(inNum).GetDC()
End Function
Public Function GetBDCName(ByVal inIndex)
GetBDCName = arrTmp(inIndex).GetStrBName()
End Function
Private Sub SetBDCName(ByVal inIndex, ByVal inName)
Call arrTmp(inIndex).SetStrBName(inName)
End Sub
Public Sub AddTmp(ByVal inName)
Dim i
i = UBound(arrTmp)
ReDim Preserve arrTmp(i + 1)
Set arrTmp(i + 1) = New BClass
Call SetBDCName(i + 1, inName)
End Sub
Private Sub Class_Initialize()
ReDim arrTmp(-1) '// 初期化
End Sub
Private Sub Class_Terminate
End Sub
End Class
'----------
Class BClass
Private strBName, DC
Public Function GetStrBName()
GetStrBName = strBName
End Function
Public Sub SetStrBName(ByVal inString)
strBName = inString
End Sub
Public Sub AddDC(ByVal inKey, ByVal inItem)
DC.Add inKey, inItem
End Sub
Public Function GetDC()
GetDC = DC
End Function
Private Sub Class_Initialize()
Set DC = CreateObject("Scripting.Dictionary")
End Sub
Private Sub Class_Terminate()
End Sub
End Class
ばんのしゃーによかばんた さん
2006年 01月 06日 16時 11分 31秒
>ばんのしゃーによかばんた さん 2005年 01月 28日 16時 49分 34秒
>CABファイルを作成/解凍/リストするコマンド。
これもパワーアップしました。再作成で追加/置換/削除を可能に。
リストでは、サイズをバイト単位に。名前欄はショートカットの拡張子も表示。
部分解凍はバグ修正。
CABではParseName(Name)やItems().Item(Name)が効かないので面倒です。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim arg
Dim optind
Const Usage="Usage: CScript.exe CAB.VBS [-c|-d|-e|-v] CABfile [files...]"
If WScript.Arguments.Count<1 Then
WScript.Echo Usage
WScript.Quit
End If
arg=WScript.Arguments(optind)
If Left(arg,1)="-" Then
Select Case LCase(arg)
Case "-c","-a"
optind=optind+1
Call CreateCAB()
Case "-d"
optind=optind+1
Call DeleteCAB()
Case "-e","-x"
optind=optind+1
Call ExtractCAB()
Case "-v","-l"
optind=optind+1
Call ListCAB()
Case Else
WScript.Echo "Invalid option -",arg&vbLf&Usage
WScript.Quit
End Select
Else
If WScript.Arguments.Count=1 Then
Call ListCAB()
Else
Call CreateCAB()
End If
End If
WScript.Quit
Sub CreateCAB()
Dim fso
Dim CABfile
Dim dic
Dim Path
Dim File
Dim MakeCab
Dim Shell
Dim zFolder
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim tFolderItem
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
CABfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind+1 To WScript.Arguments.Count-1
Path=WScript.Arguments.Item(optind)
File=LCase(fso.GetFileName(Path))
If dic.Exists(File) Then
WScript.Echo File,"- Duplicate Names."
WScript.Quit
End If
If Not fso.FileExists(Path) Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Path=fso.GetAbsolutePathName(Path)
dic.Add File,Path
Next
Set MakeCab=CreateObject("MakeCab.MakeCab.1")
If fso.FileExists(CABfile) Then
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
tFolderName=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(fso.GetFileName(zFolderItem.Path))) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
Set zFolder=Nothing
Shell.NameSpace(ssfBITBUCKET).MoveHere CABfile
Do While fso.FileExists(CABfile)
WScript.Sleep 100
Loop
MakeCab.CreateCab (CABfile),False,False,False
For Each tFolderItem In tFolder.Items()
MakeCab.AddFile tFolderItem.Path,fso.GetFileName(tFolderItem.Path)
Next
fso.DeleteFolder tFolderName
Else
MakeCab.CreateCab (CABfile),False,False,False
End If
For Each File In dic
MakeCab.AddFile (dic.Item(File)),(File)
Next
MakeCab.CloseCab
End Sub
Sub DeleteCAB()
Dim fso
Dim CABfile
Dim dic
Dim Shell
Dim zFolder
Dim zFolderItem
Dim Path
Dim File
Dim tFolderName
Dim tFolder
Dim tFolderItem
Dim MakeCab
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
CABfile=WScript.Arguments(optind)
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
If Not fso.FileExists(CABfile) Then
WScript.Echo "Not Found -",CABfile
WScript.Quit
End If
CABfile=fso.GetAbsolutePathName(CABfile)
Set dic=CreateObject("Scripting.Dictionary")
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
For Each zFolderItem In zFolder.Items()
dic.Add LCase(fso.GetFileName(zFolderItem.Path)),1
Next
For optind=optind+1 To WScript.Arguments.Count-1
Path=WScript.Arguments.Item(optind)
File=LCase(Path)
If dic.Exists(File) Then
dic.Remove File
Else
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Next
tFolderName=fso.BuildPath(fso.GetParentFolderName(CABfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
File=LCase(fso.GetFileName(zFolderItem.Path))
If dic.Exists(File) Then
tFolder.CopyHere zFolderItem
End If
Next
Set zFolder=Nothing
Shell.NameSpace(ssfBITBUCKET).MoveHere CABfile
Do While fso.FileExists(CABfile)
WScript.Sleep 100
Loop
Set MakeCab=CreateObject("MakeCab.MakeCab.1")
MakeCab.CreateCab (CABfile),False,False,False
For Each tFolderItem In tFolder.Items()
Path=tFolderItem.Path
File=fso.GetFileName(Path)
MakeCab.AddFile (Path),(File)
Next
fso.DeleteFolder tFolderName
MakeCab.CloseCab
End Sub
Sub ListCAB()
Dim fso
Dim CABfile
Dim Shell
Dim zFolder
Dim zFolderItem
Dim k
Dim COL:COL=4
Dim Cols
ReDim Cols(COL)
Dim Rows
Dim j
If WScript.Arguments.Count<optind+1 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
CABfile=WScript.Arguments(optind)
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
If Not fso.FileExists(CABfile) Then
WScript.Echo "Not Found -",CABfile
WScript.Quit
End If
CABfile=fso.GetAbsolutePathName(CABfile)
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
ReDim rows(zFolder.Items.Count)
For k=0 To COL
Cols(k)=zFolder.GetDetailsOf(,k)
Next
j=0
Rows(j)=Join(Cols,vbTab)
For Each zFolderItem In zFolder.Items
For k=0 To COL
Select Case k
Case 0
Cols(k)=fso.GetFileName(zFolderItem.Path)
Case 1
Cols(k)=zFolderItem.ExtendedProperty("Size")
Case Else
Cols(k)=zFolder.GetDetailsOf(zFolderItem,k)
End Select
Next
j=j+1
Rows(j)=Join(Cols,vbTab)
Next
WScript.Echo Join(Rows,vbLf)
End Sub
Sub ExtractCAB()
Dim fso
Dim Shell
Dim CABfile
Dim zFolder
Dim zFolderItem
Dim dFolder
Dim dic
Dim Path
Dim File
If WScript.Arguments.Count<optind+1 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
CABfile=WScript.Arguments(optind)
If UCase(fso.GetExtensionName(CABfile))<>"CAB" Then
WScript.Echo "Invalid Extension Name -",fso.GetFileName(CABfile)
WScript.Quit
End If
If Not fso.FileExists(CABfile) Then
WScript.Echo "Not Found -",CABfile
WScript.Quit
End If
CABfile=fso.GetAbsolutePathName(CABfile)
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(CABfile)
Set dFolder=Shell.NameSpace(fso.GetAbsolutePathName(""))
If WScript.Arguments.Count<optind+2 Then
dFolder.CopyHere zFolder.Items
Else
Set dic=CreateObject("Scripting.Dictionary")
For Each zFolderItem In zFolder.Items()
dic.Add LCase(fso.GetFileName(zFolderItem.Path)),False
Next
For optind=optind+1 To WScript.Arguments.Count-1
Path=WScript.Arguments.Item(optind)
File=LCase(Path)
If dic.Exists(File) Then
dic.Item(File)=True
Else
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Next
For Each zFolderItem In zFolder.Items()
File=LCase(fso.GetFileName(zFolderItem.Path))
If dic.Item(File) Then
dFolder.CopyHere zFolderItem
End If
Next
End If
End Sub
――――――――――――――――――――――――――――――――――――――
ところで、MakeCab.MakeCabの用途不明のメソッド
Sub CopyFile(CabName, FileNameInCab)
は何でしょうね。
ひろすけ さん (hiro@kambara.info)
2006年 01月 06日 05時 13分 19秒
たびたびすみません、ひろすけです。
先ほどの質問ですが、項目を新規追加したら解決できました。
CareLessな質問をしてお騒がせしました。
また、宜しくお願いします
ひろすけ さん (hironori_kanbara@kambara.info)
2006年 01月 06日 04時 00分 28秒
こんばんは、ひろすけといいます。
<環境>Win2000pro + WSH
タスクで1日に一回自動的にreStartを行いたくregedt32.exeにて下記の変更を
試みました。しかし"DefaultPassWord"の項目が見当たらなく変更できません。
以前に、セキュリティー強化のため何かを変更した記憶がありますが、覚えてないのです。どなたか、アドバイスを宜しくお願いします。
<レジストリ−の項目>
HKLM\SOFTWARE\Microsoft\Windows NT
\CurrentVersion\Winlogon\AutoAdminLogon ← [ありました]
HKLM\SOFTWARE\Microsoft\Windows NT
\CurrentVersion\Winlogon\DefaultUserName ← [ありました]
HKLM\SOFTWARE\Microsoft\Windows NT
\CurrentVersion\Winlogon\DefaultPassWord ← [ありません]
P.s.
別件で下記も探しましたが、みあたりません
HKLM\SOFTWARE\Microsoft\Windows NT
\CurrentVersion\Winlogon\DontDisplayLastUserName
ひろすけ さん (hironori_kanbara@yahoo.co.jp)
2006年 01月 04日 18時 24分 53秒
はたさんへ
ひろすけです。
ありがとうございます。うまくいきました。
今後とも宜しくお願いします。
ばんのしゃーによかばんた さん
2006年 01月 04日 16時 12分 17秒
再追加修正。性能/待ち合わせコストを考慮すると、
>>ばんのしゃーによかばんた さん 2005年 12月 27日 14時 42分 14秒
>>Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
>>Do While ie.Busy Or ie.ReadyState<>4
>> WScript.Sleep 100
>>Loop
>>ie.Document.designMode="On"
ie.Navigate tPath
>Do While ie.Busy Or ie.ReadyState<>4
> WScript.Sleep 100
>Loop
>>ie.Document.charset="shift_jis"
>>ie.ExecWB 3,0
>>ie.Document.designMode="Off"
>>ie.Visible=True
>>Do While TypeName(ie)="IWebBrowser2"
>> WScript.Sleep 100
>>Loop
>>fso.DeleteFile tPath
という手順がよいようです。
ばんのしゃーによかばんた さん
2006年 01月 04日 16時 12分 00秒
旧作のZIP.VBSも、置換のエラーを回避するように直しました。
置換の場合は、先に削除します。ダイアログが余分で出ますが、
エラーになるよりは、ましです。
また、これで、待ち合わせが可能になったので、Shell.Applicationで済みます。
一方、展開では、Shell.Applicationだと一時ディレクトリのゴミが残るので、
Hidden IEに変えました。ほんとにややこしいこってす。
また、リストでは、元のサイズをバイト単位に変えました。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim arg
Dim optind
Const Usage="Usage: CScript.exe ZIP.VBS [-d|-e|-v] ZIPfile [files...]"
If WScript.Arguments.Count()<1 Then
WScript.Echo Usage
WScript.Quit
End If
arg=WScript.Arguments(optind)
If Left(arg,1)="-" Then
Select Case LCase(arg)
Case "-a","-c"
optind=optind+1
Call MakeZIP()
Case "-d"
optind=optind+1
Call DeleteZIP()
Case "-e","-x"
optind=optind+1
Call ExtractZIP()
Case "-v","-l"
optind=optind+1
Call ListZIP()
Case Else
WScript.Echo "Invalid option:",arg&vbLf&Usage
WScript.Quit
End Select
ElseIf optind=WScript.Arguments.Count()-1 Then
Call ListZIP()
Else
Call MakeZIP()
End If
WScript.Quit
Sub MakeZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim ZIPdata:ZIPdata="PK" & Chr(5) & Chr(6) & String(18,0)
Dim zFolder
Dim zFolderItem
Dim Path
Dim File
Dim sFolder
Dim sFolderItem
Dim Ans
Dim Count
If WScript.Arguments.Count()<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
If Not fso.FileExists(ZIPfile) Then
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
End If
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(ZIPfile)
For optind=optind+1 To WScript.Arguments.Count()-1
Path=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
File=fso.GetFileName(Path)
Set sFolder=Shell.NameSpace(fso.GetParentFolderName(Path))
Set sFolderItem=sFolder.ParseName(File)
If sFolderItem Is Nothing Then
WScript.Echo WScript.Arguments.Item(optind),"- Not Found."
WScript.Quit
End If
Do
Set zFolderItem=zFolder.ParseName(File)
If zFolderItem Is Nothing Then
Count=zFolder.Items().Count
zFolder.CopyHere sFolderItem
Do While zFolder.Items().Count=Count
WScript.Sleep 100
Loop
Exit Do
Else
Ans=MsgBox("このフォルダには既に次のファイルが存在します:"&vbLf&vbLf&_
""""&File&""""&vbLf&vbLf&"既存のファイルと置き換えますか?",_
vbYesNoCancel+vbQuestion,"ファイル置換の確認")
Select Case Ans
Case vbYes
zFolderItem.InvokeVerb("delete")
Case vbNo
Exit Do
Case vbCancel
WScript.Quit
End Select
End If
Loop
Next
End Sub
Sub ListZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim zFolder
Dim zFolderItem
Dim k
Dim COL:COL=8
Dim Columns
ReDim Columns(COL)
Dim Rows
Dim j
If WScript.Arguments.Count()<optind+1 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set zFolder=Shell.NameSpace(ZIPfile)
ReDim Rows(zFolder.Items().Count)
For k=0 To COL
Columns(k)=zFolder.GetDetailsOf(,k)
Next
j=0
Rows(j)=Join(Columns,vbTab)
For Each zFolderItem In zFolder.Items()
For k=0 To COL
If k=5 Then
Columns(k)=zFolderItem.Size
Else
Columns(k)=zFolder.GetDetailsOf(zFolderItem,k)
End If
Next
j=j+1
Rows(j)=Join(Columns,vbTab)
Next
WScript.Echo Join(Rows,vbLf)
End Sub
Sub DeleteZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim zFolder
Dim zFolderItem
If WScript.Arguments.Count()<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set zFolder=Shell.NameSpace(ZIPfile)
For optind=optind+1 To WScript.Arguments.Count()-1
Set zFolderItem=zFolder.ParseName(WScript.Arguments.Item(optind))
If zFolderItem Is Nothing Then
WScript.Echo WScript.Arguments.Item(optind),"- Not Found."
WScript.Quit
End If
' zFolderItem.InvokeVerb("delete")
zFolderItem.InvokeVerb("削除(&D)")
Next
End Sub
Sub ExtractZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim ie
Dim zFolder
Dim zFolderItem
Dim dFolder
If WScript.Arguments.Count()<optind+1 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate ZIPfile
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set zFolder=ie.Document.Folder
Set dFolder=Shell.NameSpace(fso.GetAbsolutePathName(""))
If WScript.Arguments.Count<optind+2 Then
dFolder.CopyHere zFolder.Items()
Else
For optind=optind+1 To WScript.Arguments.Count()-1
Set zFolderItem=zFolder.ParseName(WScript.Arguments.Item(optind))
If zFolderItem Is Nothing Then
WScript.Echo WScript.Arguments(optind),"- Not Found."
WScript.Quit
End If
dFolder.CopyHere zFolderItem
Next
End If
ie.Quit
End Sub
はた さん
2006年 01月 04日 15時 53分 18秒
恥ずかしながら、ACCESSのスペルが間違っておりました。
訂正します。
はた さん
2006年 01月 04日 15時 40分 32秒
ひろすけさん
Acsessの日付型ということですのでもしかして＃がいるのかも
" WHERE(hizuke=#2006/01/03#)"
でどうでしょう？
ADO経由はやったことがないのでなんともいえませぬが...
ひろすけ さん (hiro@kambara.info)
2006年 01月 03日 20時 57分 04秒
ひろすけといいます。4年ぶりに投稿させて頂きます。
<環境:Win2000pro + WHS + ACCESS2000>
データソース(ODBC)のシステムDNSに"ABC"
とACCESSのファイル(test.mdb)を登録てあります。
test.mdbの項目は下記の通りです
test_tb → テーブル
hizuke[DATE] → 2006/01/03(1件のデータがあります）
下記を記述するとどうしてもあるはずのレコードを
カウントしてくれません。どのようにしたらカウントしてくれるのですか？
どなたかアドバイスお願いします。
-------------- test.vbs ------------
Dim abc_rdb,recCntSQL,recCntRes
Dim recCnt_int
Set abc_rdb=WScript.CreateObject("ADODB.Connection")
abc_rdb.Open "ABC"
recCntSQL="SELECT COUNT(*) AS recCnt FROM test_tb" & _
" WHERE(hizuke=2006/01/03)"
Set recCntRes=abc_rdb.Execute(recCntSQL)
recCnt_int=recCntRes("recCnt")
recCntRes.Close
msgbox(recCnt_int)
abc_rdb.Close
Wscript.Quit
ばんのしゃーによかばんた さん
2006年 01月 03日 15時 18分 20秒
>ばんのしゃーによかばんた さん 2005年 12月 29日 16時 27分 02秒
これも、「一時ディレクトリ」のゴミを残すので、Shell.Applicationから
hidden IEに変えました。しかし、ちょっと難しかったので、再掲します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const FOF_ALLOWUNDO=&H40
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim ZIPdata:ZIPdata="PK" & Chr(5) & Chr(6) & String(18,0)
Dim arg
Dim optind
Dim Test:Test=0
Const Usage="Usage: CScript.exe ReZIP.VBS [-d] ZIPfile files..."
If WScript.Arguments.Count<2 Then
WScript.Echo Usage
WScript.Quit
End If
arg=WScript.Arguments(optind)
If Left(arg,1)="-" Then
Select Case LCase(arg)
Case "-a","-c"
optind=optind+1
Call MakeZIP()
Case "-d"
optind=optind+1
Call DeleteZIP()
Case Else
WScript.Echo "Invalid option -",arg&vbLf&Usage
WScript.Quit
End Select
Else
Call MakeZIP()
End If
WScript.Quit
Sub MakeZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim dic
Dim Path
Dim File
Dim ie
Dim zFolder
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim Count
Dim sFolder
Dim sFolderItem
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
File=LCase(fso.GetFileName(Path))
If dic.Exists(File) Then
WScript.Echo File,"- Duplicate Names."
WScript.Quit
End If
If Not fso.FileExists(Path) Then
WScript.Echo WScript.Arguments.Item(optind),"- Not Found."
WScript.Quit
End If
dic.Add File,Path
Next
If fso.FileExists(ZIPfile) Then
Set zFolder=Shell.NameSpace(ZIPfile)
For Each File In dic
Set zFolderItem=zFolder.ParseName(File)
If Not zFolderItem Is Nothing Then
tFolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder tFolderName
Exit For
End If
Next
Else
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set zFolder=Shell.NameSpace(ZIPfile)
End If
If Not IsEmpty(tFolderName) Then
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate ZIPfile
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set zFolder=ie.Document.Folder
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(zFolderItem.Path)) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
ie.Navigate fso.GetParentFolderName(ZIPfile)
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set zFolder=ie.Document.Folder
Set zFolderItem=zFolder.Items().Item(fso.GetFileName(ZIPfile))
Shell.NameSpace(ssfBITBUCKET).MoveHere zFolderItem,FOF_ALLOWUNDO
Do While fso.FileExists(ZIPfile)
WScript.Sleep 100
Loop
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set zFolder=Shell.NameSpace(ZIPfile)
zFolder.CopyHere tFolder.Items()
Count=tFolder.Items().Count
Do While zFolder.Items().Count<>Count
If Test Then WScript.Echo 2,zFolder.Items().Count,Count
WScript.Sleep 100
Loop
End If
For Each File In dic
Set sFolder=Shell.NameSpace(fso.GetParentFolderName(dic.Item(File)))
Set sFolderItem=sFolder.Items().Item(File)
zFolder.CopyHere sFolderItem
Next
Count=Count+dic.Count
Do While zFolder.Items().Count<>Count
If Test Then WScript.Echo 3,zFolder.Items().Count,Count
WScript.Sleep 100
Loop
If Not IsEmpty(tFolderName) Then
fso.DeleteFolder tFolderName
ie.Quit
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
End If
End Sub
Sub DeleteZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim ie
Dim zFolder
Dim dic
Dim Path
Dim File
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim Count
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate ZIPfile
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set zFolder=ie.Document.Folder
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetFileName(WScript.Arguments.Item(optind))
File=LCase(Path)
If dic.Exists(File) Then
WScript.Echo Path,"- Duplicate Names."
WScript.Quit
End If
Set zFolderItem=zFolder.ParseName(File)
If zFolderItem Is Nothing Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
dic.Add File,Path
Next
tFolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For Each zFolderItem In zFolder.Items()
If dic.Exists(LCase(zFolderItem.Path)) Then
Else
tFolder.CopyHere zFolderItem
End If
Next
ie.Navigate fso.GetParentFolderName(ZIPfile)
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set zFolder=ie.Document.Folder
Set zFolderItem=zFolder.Items().Item(fso.GetFileName(ZIPfile))
Shell.NameSpace(ssfBITBUCKET).MoveHere zFolderItem,FOF_ALLOWUNDO
Do While fso.FileExists(ZIPfile)
WScript.Sleep 100
Loop
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set zFolder=Shell.NameSpace(ZIPfile)
zFolder.CopyHere tFolder.Items()
Count=tFolder.Items().Count
Do While zFolder.Items().Count<>Count
If Test Then WScript.Echo 2,zFolder.Items().Count,Count
WScript.Sleep 100
Loop
fso.DeleteFolder tFolderName
ie.Quit
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
End Sub
ばんのしゃーによかばんた さん
2006年 01月 03日 15時 17分 41秒
>ばんのしゃーによかばんた さん 2005年 12月 16日 18時 38分 57秒
>スクリプトから、IEの終了を検知するのに、
>TypeName(ie)がIWebBrowser2からObjectに変化するのを利用した場合、
>うまく行かないケースがあります。
の回避策です。
>IEの起動順序を逆にするとうまく行きます。
を利用します。
Set ix=CreateObject("InternetExplorer.Application")
Set ie=CreateObject("InternetExplorer.Application")
ix.Quit
ie.Visible=True
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
MsgBox "Ended."
ダミーのIEを先に起こします。
――――――――――――――――――――――――――――――――――――――
追加修正。
>ばんのしゃーによかばんた さん 2005年 12月 27日 14時 42分 14秒
>Set ie=CreateObject("InternetExplorer.Application")
>ie.Navigate tPath
>Do While ie.Busy Or ie.ReadyState<>4
> WScript.Sleep 100
>Loop
>ie.Document.designMode="On"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
>ie.Document.charset="shift_jis"
>ie.ExecWB 3,0
>ie.Document.designMode="Off"
>ie.Visible=True
>Do While TypeName(ie)="IWebBrowser2"
> WScript.Sleep 100
>Loop
>fso.DeleteFile tPath
普通、こんなところで待ち合わせが必要とは思わないよー。
designModeプロパティのドキュメントにも書いてないよー。
なので、注意。
ばんのしゃーによかばんた さん
2006年 01月 02日 13時 17分 58秒
ZIPファイルを一時フォルダに展開やZIPファイル再作成なんぞ、せずとも、
もっとスマートに、ダイアログやエラーなしに置換や削除が出来ます。
なぜかMoveHereは無効(=CopyHere)なので、Cut&Pasteを使います。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim ZIPdata:ZIPdata="PK" & Chr(5) & Chr(6) & String(18,0)
Dim arg
Dim optind
Const Usage="Usage: CScript.exe ExZIP.VBS [-d] ZIPfile files..."
If WScript.Arguments.Count<2 Then
WScript.Echo Usage
WScript.Quit
End If
arg=WScript.Arguments(optind)
If Left(arg,1)="-" Then
Select Case LCase(arg)
Case "-a","-c"
optind=optind+1
Call MakeZIP()
Case "-d"
optind=optind+1
Call DeleteZIP()
Case Else
WScript.Echo "Invalid option:",arg&vbLf&Usage
WScript.Quit
End Select
Else
Call MakeZIP()
End If
WScript.Quit
Sub MakeZIP()
Dim fso
Dim ie
Dim Shell
Dim ZIPfile
Dim Path
Dim File
Dim zFolder
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim sFolder
Dim sFolderItem
Dim Count
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
If fso.FileExists(ZIPfile) Then
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate ZIPfile
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set zFolder=ie.Document.Folder
Else
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set Shell=CreateObject("Shell.Application")
Set zFolder=Shell.NameSpace(ZIPfile)
End If
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
File=LCase(fso.GetFileName(Path))
If Not fso.FileExists(Path) Then
WScript.Echo WScript.Arguments.Item(optind),"- Not Found."
WScript.Quit
End If
Set zFolderItem=zFolder.ParseName(File)
If Not zFolderItem Is Nothing Then
If IsEmpty(tFolderName) Then
tFolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
End If
Count=zFolder.Items().Count
' tFolder.MoveHere zFolderItem
zFolderItem.InvokeVerb "cut"
tFolder.Self.InvokeVerb "paste"
Do While zFolder.Items().Count=Count
WScript.Sleep 100
Loop
End If
Set sFolder=Shell.NameSpace(fso.GetParentFolderName(Path))
Set sFolderItem=sFolder.Items().Item(File)
Count=zFolder.Items().Count
zFolder.CopyHere sFolderItem
Do While zFolder.Items().Count=Count
WScript.Sleep 100
Loop
Next
If Not IsEmpty(tFolderName) Then
fso.DeleteFolder tFolderName
End If
ie.Quit
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
'MsgBox "IE ended."
End Sub
Sub DeleteZIP()
Dim fso
Dim Shell
Dim ie
Dim ZIPfile
Dim zFolder
Dim Path
Dim File
Dim zFolderItem
Dim tFolderName
Dim tFolder
Dim Count
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
If Not fso.FileExists(ZIPfile) Then
WScript.Echo "ZIP file not found. -",ZIPfile
WScript.Quit
End If
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate ZIPfile
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set zFolder=ie.Document.Folder
tFolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder tFolderName
Set tFolder=Shell.NameSpace(tFolderName)
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetFileName(WScript.Arguments.Item(optind))
File=LCase(Path)
Set zFolderItem=zFolder.ParseName(File)
If zFolderItem Is Nothing Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
Count=zFolder.Items().Count
' tFolder.MoveHere zFolderItem
zFolderItem.InvokeVerb "cut"
tFolder.Self.InvokeVerb "paste"
Do While zFolder.Items().Count=Count
WScript.Sleep 100
Loop
Next
fso.DeleteFolder tFolderName
Set Shell=Nothing
ie.Quit
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
'MsgBox "IE ended."
End Sub
――――――――――――――――――――――――――――――――――――――
ごみ箱を使うとダイアログが出るので、代わりに一時フォルダを使います。
ばんのしゃーによかばんた さん
2006年 01月 02日 13時 17分 33秒
>ばんのしゃーによかばんた さん 2005年 12月 29日 16時 27分 02秒
>ZIPへのCopyHereは非同期なので、前作では、Hidden Explorerを使ってましたが、
>ここでは、待合せをすることで、Shell.Applicationで済ますことができました。
ところが、どっこい、逆方向のZIPからFSへのCopyHere、つまり、展開では、
ユーザのテンポラリフォルダに「〜.ZIP の一時ディレクトリ n」が作成されます。
IE/ExplorerでCopyHereしたときは、削除されるのですが、Shell.Applicationで
CopyHereしたときは、削除されず、ゴミが残ります。
なので、やっぱり、ここはHidden IEでやるべし。
事程左様にShell.Applicationは複雑ですね。
ここで整理しておくと、
アプリで、Shell.Application/IE/Explorer、の３通り
方法で、CopyHere/MoveHere/Copy&Paste/Cut&Paste、の４通り
待ち合わせで、不要/必要/できない、の３通り、の組み合わせがありますが、
OS内部で実際に使われている仕様だけが使い方に合わせて実装されているので、
この中から使える方法を探す必要があります。
>ばんのしゃーによかばんた さん 2005年 12月 31日 16時 43分 25秒
>前者では異文字がNEやNRCに変換されます。そこが違います。
typo。NCR
ばんのしゃーによかばんた さん
2005年 12月 31日 16時 43分 46秒
ZIP作成専用では、CopyHereでなく、SentToの「圧縮 (zip 形式) フォルダ」に「送る」
方式をシミュレートする方法もあります。
複数ファイルを指定すると、先頭に指定したファイルの拡張子をZIPに変えて、
そのフォルダに作成または追加/置換されます。その辺の技は以下を参照。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim File
Dim Files
Dim FolderName
Dim k,p
Files=Array()
If WScript.Arguments.Count() Then
For Each File In WScript.Arguments
Push Files,File
Next
Else
Do While Not WScript.StdIn.AtEndOfStream
Push Files,WScript.StdIn.ReadLine()
Loop
End If
For k=0 To UBound(Files)
p=InStrRev(Files(k),"\")
If p Then
If Left(Files(k),p)<>FolderName Then
If FolderName="" Then
FolderName=Left(Files(k),p)
Else
WScript.Echo "Folders differs."&vbLf&FolderName&vbLf&Left(Files(k),p)
WScript.Quit
End If
End If
Files(k)=Mid(Files(k),p+1)
End If
Next
Sub Push(Items,Item)
ReDim Preserve Items(UBound(Items)+1)
Items(UBound(Items))=Item
End Sub
Const ssfSENDTO=9
'shell:SendTo
Dim fso
Dim wShell
Dim n
Dim ie
Dim Shell
Dim sFolder
Dim sFolderItem
Dim Count
Dim ZIPfile
Set fso=CreateObject("Scripting.FileSystemObject")
FolderName=fso.GetAbsolutePathName(FolderName)
Set wShell=CreateObject("WScript.Shell")
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate FolderName
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Shell=ie.Document.Application
Set sFolder=ie.Document.Folder
For Each File In Files
ie.Document.SelectItem sFolder.Items().Item(File),1
Next
For Each File In Files
ie.Document.SelectItem sFolder.Items().Item(File),1+16
ZIPfile=fso.BuildPath(FolderName,fso.GetBaseName(File)&".ZIP")
Exit For
Next
ie.Document.SelectedItems().InvokeVerbEx "copy"
For Each sFolderItem In ie.Document.SelectedItems()
ie.Document.SelectItem sFolderItem,0
Next
If fso.FileExists(ZIPfile) Then
Shell.NameSpace(ssfSENDTO).Items().Item("圧縮 (zip 形式) フォルダ.ZFSendToTarget").InvokeVerb "paste"
Set sFolderItem=sFolder.Items().Item(fso.GetFileName(ZIPfile))
Else
Count=sFolder.Items().Count
Shell.NameSpace(ssfSENDTO).Items().Item("圧縮 (zip 形式) フォルダ.ZFSendToTarget").InvokeVerb "paste"
Do While sFolder.Items().Count=Count
WScript.Sleep 100
Loop
Set sFolderItem=sFolder.Items().Item(sFolder.Items().Count-1)
End If
Select Case 0
Case 1
sFolderItem.InvokeVerb "properties"
ie.Quit
Case 2
ie.Document.SelectItem sFolderItem,1
ie.Visible=True
Case 3
ie.Navigate ZIPfile
ie.Visible=True
Case 4
File=sFolderItem.Name
WScript.Echo File
ie.Quit
Case Else
If IsEmpty(Count) Then
ie.Navigate ZIPfile
ie.Visible=True
Else
ie.Quit
End If
End Select
WScript.Quit
――――――――――――――――――――――――――――――――――――――
InvokeVerb "paste" は、非同期です。
新規作成の場合は、先日のフォルダの新規ファイル作成を監視する新技を使って、
待ち合わせが出来ます。既存の場合は、追加だけなら、待ち合わせ可能ですが、
置換があると、待ち合わせは困難です。そこでIEをなんとか延命させます。
その延命策に幾つか選択肢を用意しました。適宜選択してください。
この中で興味深いのは、FolderItem.InvokeVerb "properties"は非同期なのに、
ie.Quitしても、プロパティページを閉じるまで、待ち合わせするみたいです。
ばんのしゃーによかばんた さん
2005年 12月 31日 16時 43分 25秒
また、訂正。
そのときは出来たように思うのですが、今やるとできません。勘違いかな。
>ばんのしゃーによかばんた さん 2005年 12月 27日 14時 42分 14秒
>元ファイルに反映する必要がなければ、ExecWB行は不要。
ExecWB行は必要なようです。
なので、以下も訂正。
>ばんのしゃーによかばんた さん 2005年 12月 28日 18時 46分 47秒
>IEのメモリ上でHTMLを変更しても「名前を付けて保存」できなかったのですが、
>今度の小技を使うとできます。
「名前を付けて保存」のほうは、相変わらず、出来ませんが、
「ソースの表示」のほうでは、出来るようになります。
それだけなら、
ie.Document.write ie.Document.documentElement.outerHTML
したのと同じですが、後者では異文字が?に変換されるのに対し、
前者では異文字がNEやNRCに変換されます。そこが違います。
AKA さん
2005年 12月 31日 07時 40分 22秒
ダメか・・・すいません。書きなおします。
のやつは消してください。
<<EKMAIN.VBS>>
'
' メモ帳を立ち上げ、かな漢字変換を行います。
'
' ただし、AppActivateの後で他のアプリがアクティブになるとダメ。
' それと、元からかな漢字変換ONになっているとOFFにすることになるのでダメ。
'
'Sub Main
ExecuteFile "ENAKANJI.VBS"
Set ws = CreateObject("WScript.Shell")
ws.Run "NOTEPAD"
EnableKanji
ws.AppActivate "無題 - メモ帳"
WScript.Sleep 100
ws.SendKeys "{KANJI}"
ws.SendKeys "ii"
ws.SendKeys "{F6}"
ws.SendKeys "kanji"
ws.SendKeys "{CONVERT}"
ws.SendKeys "?"
ws.SendKeys "{F7}"
ws.SendKeys "{ENTER}"
WScript.Sleep 1000
ws.SendKeys "{KANJI}"
WScript.Quit
'End Sub 'Main
Sub ExecuteFile(tmpFname)
Set tmpFs = CreateObject("Scripting.FileSystemObject")
Set tmpTs = tmpFs.OpenTextFile(tmpFname)
tmpStr = tmpTs.ReadAll
If Right(tmpStr, 1) = Chr(&H1A) Then
tmpStr = Left(tmpStr, Len(tmpStr) - 1)
End If
ExecuteGlobal tmpStr
tmpTs.Close
Set tmpTs = Nothing
Set tmpFs = Nothing
End Sub
<<ENAKANJI.VBS>>
'
' Sub EnableKanji
' メモリ上のWSHOM.OCXにパッチをあて、
' SendKeysで{KANJI}などが使えるようにします。
'
Const C_FALSE = 0
Const C_NULL = 0
Const MEM_COMMIT = &H1000
Const PAGE_READONLY = 2
Const PAGE_READWRITE = 4
Set dw = CreateObject("DynamicWrapper")
dw.Register "KERNEL32.DLL", "GetModuleHandleA", "i=s", "r=l"
dw.Register "KERNEL32.DLL", "VirtualQuery", "i=lll", "r=l"
dw.Register "KERNEL32.DLL", "VirtualProtect", "i=llll", "r=l"
dw.RegisterStruct "MEMORY_BASIC_INFORMATION", "lllllll", "BaseAddress", "AllocationBase", "AllocationProtect", "RegionSize", "State", "Protect", "Type"
dw.RegisterStruct "DWORD", "l", "Value"
Sub EnableKanji
Set TmpWS = CreateObject("WScript.Shell")
TmpHMod = dw.GetModuleHandleA("WSHOM.OCX")
TmpPat = Array(Asc("E"), Asc("N"), Asc("T"), Asc("E"), Asc("R"))
TmpPatLen = 5
TmpAddressOfEnterString = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfEnterString
If TmpAddressOfEnterString = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
TmpPat = Array(TmpAddressOfEnterString And &HFF, (TmpAddressOfEnterString \ 256) And &HFF, (TmpAddressOfEnterString \ 256 \ 256) And &HFF, (TmpAddressOfEnterString \ 256 \ 256 \ 256) And &HFF)
TmpPatLen = 4
TmpAddressOfTableTop = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfTableTop
If TmpAddressOfTableTop = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
TmpPat = Array(&H68, TmpAddressOfTableTop And &HFF, (TmpAddressOfTableTop \ 256) And &HFF, (TmpAddressOfTableTop \ 256 \ 256) And &HFF, (TmpAddressOfTableTop \ 256 \ 256 \ 256) And &HFF)
TmpPatLen = 5
TmpAddressOfPushingCode = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfPushingCode
If TmpAddressOfPushingCode = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
If dw.Peek(TmpAddressOfPushingCode - 2) = &H6A Then
Select Case dw.Peek(TmpAddressOfPushingCode - 1)
Case &H33
WScript.Echo "Already Enabled"
Case &H29
'WScript.Echo "Found"
Set TmpMbi = dw.MEMORY_BASIC_INFORMATION
If dw.VirtualQuery(TmpAddressOfPushingCode, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
WScript.Echo "VirtualQuery() error"
WScript.Quit
End If
Set TmpOldProtect = dw.DWORD
If dw.VirtualProtect(TmpMbi.BaseAddress, TmpMbi.RegionSize, PAGE_READWRITE, TmpOldProtect.AddressOf) = C_FALSE Then
WScript.Echo "VirtualProtect() error"
WScript.Quit
End If
dw.Poke TmpAddressOfPushingCode - 1, &H33
If dw.VirtualProtect(TmpMbi.BaseAddress, TmpMbi.RegionSize, TmpOldProtect.Value, TmpOldProtect.AddressOf) = C_FALSE Then
WScript.Echo "VirtualProtect() error"
WScript.Quit
End If
Case Else
WScript.Echo "Not Found"
End Select
Else
WScript.Echo "Not Found"
End If
End Sub 'EnableKanji
Function SearchPatternInModule(TmphMod, TmpPat, TmpPatLen)
Set TmpMbi = dw.MEMORY_BASIC_INFORMATION
If dw.VirtualQuery(TmphMod, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
WScript.Echo "VirtualQuery() error"
WScript.Quit
End If
Do While True
If TmpMbi.State = MEM_COMMIT Then
TmpAddress = SearchPattern(TmpMbi.BaseAddress, TmpMbi.RegionSize, TmpPat, TmpPatLen)
If TmpAddress <> 0 Then
SearchPatternInModule = TmpAddress
Exit Do
End If
End If
If dw.VirtualQuery(TmpMbi.BaseAddress + TmpMbi.RegionSize, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
SearchPatternInModule = 0
Exit Do
End If
If TmpMbi.AllocationBase <> TmphMod Then
SearchPatternInModule = 0
Exit Do
End If
Loop
Set TmpMbi = Nothing
End Function 'SearchPatternInModule
Function SearchPattern(TmpMemAddr, TmpMemLen, TmpPat, TmpPatLen)
For TmpI = 0 To TmpMemLen - 1
If dw.Peek(TmpMemAddr + TmpI) = TmpPat(0) Then
If TmpMemLen - TmpI < TmpPatLen Then
SearchPattern = 0
Exit Function
End If
For TmpJ = 1 To TmpPatLen - 1
If dw.Peek(TmpMemAddr + TmpI + TmpJ) <> TmpPat(TmpJ) Then
Exit For
End If
Next
If TmpJ = TmpPatLen Then
SearchPattern = TmpMemAddr + TmpI
Exit Function
End If
End If
Next
SearchPatern = 0
End Function 'SearchPattern
AKA さん
2005年 12月 31日 07時 34分 58秒
NHKスペシャルの半導体もので、ある有名な技術者の言葉。
「技術に関しては必ず少数派が正しい。なぜなら多数派には革新はないからだ」
さて。
SendKeysで「半角/全角」や「変換」キーを使えるようにする「動的」パッチャーです。ファイルではなく、メモリを書き換えます。
DW7を使っています。
これは以前私が2chに貼り付けた、実行ファイル版(.COM)のパッチャー(ファイルを書き換えるやつ)を動的かつ、VBSに書き直したものです。
まあそんなに使う局面があるかは疑問ですが、一応こういうこともできる、ということで・・・
なお、実行してもすぐに文字が出ないかもしれませんが、しばらく待ってみてください(^^;)
パッチ位置を探すのに時間がかかってしまっていますが、こういうのは本来機械語でやるべきだと思うので、いずれDynamicWrapperにメモリサーチを搭載するかも。
<<EKMAIN.VBS>>
'
' メモ帳を立ち上げ、かな漢字変換を行います。
'
' ただし、AppActivateの後で他のアプリがアクティブになるとダメ。
' それと、元からかな漢字変換ONになっているとOFFにすることになるのでダメ。
'
'Sub Main
ExecuteFile "ENAKANJI.VBS"
Set ws = CreateObject("WScript.Shell")
ws.Run "NOTEPAD"
EnableKanji
ws.AppActivate "無題 - メモ帳"
WScript.Sleep 100
ws.SendKeys "{KANJI}"
ws.SendKeys "ii"
ws.SendKeys "{F6}"
ws.SendKeys "kanji"
ws.SendKeys "{CONVERT}"
ws.SendKeys "?"
ws.SendKeys "{F7}"
ws.SendKeys "{ENTER}"
WScript.Sleep 1000
ws.SendKeys "{KANJI}"
WScript.Quit
'End Sub 'Main
Sub ExecuteFile(tmpFname)
Set tmpFs = CreateObject("Scripting.FileSystemObject")
Set tmpTs = tmpFs.OpenTextFile(tmpFname)
tmpStr = tmpTs.ReadAll
If Right(tmpStr, 1) = Chr(&H1A) Then
tmpStr = Left(tmpStr, Len(tmpStr) - 1)
End If
ExecuteGlobal tmpStr
tmpTs.Close
Set tmpTs = Nothing
Set tmpFs = Nothing
End Sub
<<ENAKANJI.VBS>>
'
' Sub EnableKanji
' メモリ上のWSHOM.OCXにパッチをあて、
' SendKeysで{KANJI}などが使えるようにします。
'
Const C_FALSE = 0
Const C_NULL = 0
Const MEM_COMMIT = &H1000
Const PAGE_READONLY = 2
Const PAGE_READWRITE = 4
Set dw = CreateObject("DynamicWrapper")
dw.Register "KERNEL32.DLL", "GetModuleHandleA", "i=s", "r=l"
dw.Register "KERNEL32.DLL", "VirtualQuery", "i=lll", "r=l"
dw.Register "KERNEL32.DLL", "VirtualProtect", "i=llll", "r=l"
dw.RegisterStruct "MEMORY_BASIC_INFORMATION", "lllllll", "BaseAddress", "AllocationBase", "AllocationProtect", "RegionSize", "State", "Protect", "Type"
dw.RegisterStruct "DWORD", "l", "Value"
Sub EnableKanji
Set TmpWS = CreateObject("WScript.Shell")
TmpHMod = dw.GetModuleHandleA("WSHOM.OCX")
TmpPat = Array(Asc("E"), Asc("N"), Asc("T"), Asc("E"), Asc("R"))
TmpPatLen = 5
TmpAddressOfEnterString = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfEnterString
If TmpAddressOfEnterString = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
TmpPat = Array(TmpAddressOfEnterString And &HFF, (TmpAddressOfEnterString \ 256) And &HFF, (TmpAddressOfEnterString \ 256 \ 256) And &HFF, (TmpAddressOfEnterString \ 256 \ 256 \ 256) And &HFF)
TmpPatLen = 4
TmpAddressOfTableTop = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfTableTop
If TmpAddressOfTableTop = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
TmpPat = Array(&H68, TmpAddressOfTableTop And &HFF, (TmpAddressOfTableTop \ 256) And &HFF, (TmpAddressOfTableTop \ 256 \ 256) And &HFF, (TmpAddressOfTableTop \ 256 \ 256 \ 256) And &HFF)
TmpPatLen = 5
TmpAddressOfPushingCode = SearchPatternInModule(TmpHMod, TmpPat, TmpPatLen)
'WScript.Echo TmpAddressOfPushingCode
If TmpAddressOfPushingCode = 0 Then
WScript.Echo "Not Found"
WScript.Quit
End If
If dw.Peek(TmpAddressOfPushingCode - 2) = &H6A Then
Select Case dw.Peek(TmpAddressOfPushingCode - 1)
Case &H33
WScript.Echo "Already Enabled"
Case &H29
'WScript.Echo "Found"
Set TmpMbi = dw.MEMORY_BASIC_INFORMATION
If dw.VirtualQuery(TmpAddressOfPushingCode, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
WScript.Echo "VirtualQuery() error"
WScript.Quit
End If
Set TmpOldProtect = dw.DWORD
If dw.VirtualProtect(TmpMbi.BaseAddress, TmpMbi.RegionSize, PAGE_READWRITE, TmpOldProtect.AddressOf) = C_FALSE Then
WScript.Echo "VirtualProtect() error"
WScript.Quit
End If
dw.Poke TmpAddressOfPushingCode - 1, &H33
If dw.VirtualProtect(TmpMbi.BaseAddress, TmpMbi.RegionSize, TmpOldProtect.Value, TmpOldProtect.AddressOf) = C_FALSE Then
WScript.Echo "VirtualProtect() error"
WScript.Quit
End If
Case Else
WScript.Echo "Not Found"
End Select
Else
WScript.Echo "Not Found"
End If
End Sub 'EnableKanji
Function SearchPatternInModule(TmphMod, TmpPat, TmpPatLen)
Set TmpMbi = dw.MEMORY_BASIC_INFORMATION
If dw.VirtualQuery(TmphMod, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
WScript.Echo "VirtualQuery() error"
WScript.Quit
End If
Do While True
If TmpMbi.State = MEM_COMMIT Then
TmpAddress = SearchPattern(TmpMbi.BaseAddress, TmpMbi.RegionSize, TmpPat, TmpPatLen)
If TmpAddress <> 0 Then
SearchPatternInModule = TmpAddress
Exit Do
End If
End If
If dw.VirtualQuery(TmpMbi.BaseAddress + TmpMbi.RegionSize, TmpMbi.AddressOf, TmpMbi.SizeOf) = C_FALSE Then
SearchPatternInModule = 0
Exit Do
End If
If TmpMbi.AllocationBase <> TmphMod Then
SearchPatternInModule = 0
Exit Do
End If
Loop
Set TmpMbi = Nothing
End Function 'SearchPatternInModule
Function SearchPattern(TmpMemAddr, TmpMemLen, TmpPat, TmpPatLen)
For TmpI = 0 To TmpMemLen - 1
If dw.Peek(TmpMemAddr + TmpI) = TmpPat(0) Then
If TmpMemLen - TmpI < TmpPatLen Then
SearchPattern = 0
Exit Function
End If
For TmpJ = 1 To TmpPatLen - 1
If dw.Peek(TmpMemAddr + TmpI + TmpJ) <> TmpPat(TmpJ) Then
Exit For
End If
Next
If TmpJ = TmpPatLen Then
SearchPattern = TmpMemAddr + TmpI
Exit Function
End If
End If
Next
SearchPatern = 0
End Function 'SearchPattern
>>ばんのしゃーによかばんた さん 2005年 12月 17日 17時 23分 15秒
>オープンしてる訳ではないので、同じような存在確認をやってるのでしょうか。
IEが直接存在確認をしているわけではなく、エクスプローラが自らを通じたファイル削除を監視しているようです。
ちなみにIE5の場合は消されませんよ？
>>ばんのしゃーによかばんた さん 2005年 12月 22日 16時 07分 18秒
>これも、「VT_BYREF+VT_VARIANT」問題かな。
ばんのしゃーによかばんたさんはVT_BYREF | VT_VARIANTに何か問題があると思っているみたいですが、全く問題はありません。引き数に値を返すために必要な仕様です。
問題はオートメーションの意味がよくわかっていないエクスプローラやIEのプログラマの方にあります。
>>管理人さん
Wikiのアップローダなのですが、作者の一行コメントがファイル名の隣に並ぶリスト状の表示形式にできないでしょうか？ 我ながら何のファイルだかわかりにくくて・・・(^^;)
ばんのしゃーによかばんた さん
2005年 12月 29日 16時 27分 02秒
ZIPと言えば、
>ばんのしゃーによかばんた さん 2005年 01月 28日 19時 59分 05秒
>スクリプトからZIPファイルを自由自在に操作するサンプルアプリケーションです。
>オープンな課題は、置換と削除のときにプロンプトが出ること。
>回避方法は一旦一時フォルダを作って展開して作り直すことですが。。。
という風にやってみました。
これを使うと、大小文字の違いでエラーになって、GUIで削除できなくなる問題を
回避できます。
あと、残っている課題はディレクトリ。私は使わないので必要ないのだけど。。。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const ssfBITBUCKET=10'shell:RecycleBinFolder::{645FF040-5081-101B-9F08-00AA002F954E}
Dim ZIPdata:ZIPdata="PK" & Chr(5) & Chr(6) & String(18,0)
Dim arg
Dim optind
Dim Test:Test=0
If WScript.Arguments.Count<2 Then
WScript.Echo "Usage: CScript.exe ReZIP.VBS [-d] ZIPfile files..."
WScript.Quit
End If
arg=WScript.Arguments(optind)
Select Case LCase(arg)
Case "-a","-c"
optind=optind+1
Call MakeZIP()
Case "-d"
optind=optind+1
Call DeleteZIP()
Case Else
Call MakeZIP()
End Select
WScript.Quit
Sub MakeZIP()
Dim fso
Dim Shell
Dim n
Dim ie
Dim ZIPfile
Dim dic
Dim Path
Dim File
Dim dFolder
Dim FolderItem
Dim FolderName
Dim Folder
Dim Count
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetAbsolutePathName(WScript.Arguments.Item(optind))
File=LCase(fso.GetFileName(Path))
If dic.Exists(File) Then
WScript.Echo File,"- Duplicate Names."
WScript.Quit
End If
If Not fso.FileExists(Path) Then
WScript.Echo WScript.Arguments.Item(optind),"- Not Found."
WScript.Quit
End If
dic.Add File,Path
Next
If fso.FileExists(ZIPfile) Then
Set dFolder=Shell.NameSpace(ZIPfile)
For Each File In dic
Set FolderItem=dFolder.ParseName(File)
If Not FolderItem Is Nothing Then
FolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder FolderName
Exit For
End If
Next
Else
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set dFolder=Shell.NameSpace(ZIPfile)
End If
If Not IsEmpty(FolderName) Then
Set Folder=Shell.NameSpace(FolderName)
For Each FolderItem In dFolder.Items()
If dic.Exists(LCase(FolderItem.Path)) Then
Else
Folder.CopyHere FolderItem
End If
Next
Shell.NameSpace(ssfBITBUCKET).MoveHere dFolder.Items().Item()
Do While fso.FileExists(ZIPfile)
WScript.Sleep 100
Loop
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set dFolder=Shell.NameSpace(ZIPfile)
dFolder.CopyHere Folder.Items()
Count=Folder.Items().Count
Do While dFolder.Items().Count<>Count
If Test Then WScript.Echo 2,dFolder.Items().Count,Count
WScript.Sleep 100
Loop
End If
For Each File In dic
Set Folder=Shell.NameSpace(fso.GetParentFolderName(dic.Item(File)))
Set FolderItem=Folder.Items().Item(File)
dFolder.CopyHere FolderItem
Next
Count=Count+dic.Count
Do While dFolder.Items().Count<>Count
If Test Then WScript.Echo 3,dFolder.Items().Count,Count
WScript.Sleep 100
Loop
If Not IsEmpty(FolderName) Then
fso.DeleteFolder FolderName
End If
End Sub
Sub DeleteZIP()
Dim fso
Dim Shell
Dim ZIPfile
Dim Folder
Dim dic
Dim Path
Dim File
Dim FolderItem
Dim FolderName
Dim tFolder
Dim Count
If WScript.Arguments.Count<optind+2 Then
WScript.Echo "Arguments Missing."
WScript.Quit
End If
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(WScript.Arguments(optind))
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set Folder=Shell.NameSpace(ZIPfile)
Set dic=CreateObject("Scripting.Dictionary")
For optind=optind+1 To WScript.Arguments.Count-1
Path=fso.GetFileName(WScript.Arguments.Item(optind))
File=LCase(Path)
If dic.Exists(File) Then
WScript.Echo Path,"- Duplicate Names."
WScript.Quit
End If
Set FolderItem=Folder.ParseName(File)
If FolderItem Is Nothing Then
WScript.Echo Path,"- Not Found."
WScript.Quit
End If
dic.Add File,Path
Next
FolderName=fso.BuildPath(fso.GetParentFolderName(ZIPfile),fso.GetTempName)
fso.CreateFolder FolderName
Set tFolder=Shell.NameSpace(FolderName)
For Each FolderItem In Folder.Items()
If dic.Exists(LCase(FolderItem.Path)) Then
Else
tFolder.CopyHere FolderItem
End If
Next
Shell.NameSpace(ssfBITBUCKET).MoveHere Folder.Items().Item()
Do While fso.FileExists(ZIPfile)
WScript.Sleep 100
Loop
fso.CreateTextFile(ZIPfile,False).Write ZIPdata
Set Folder=Shell.NameSpace(ZIPfile)
Folder.CopyHere tFolder.Items()
Count=tFolder.Items().Count
Do While Folder.Items().Count<>Count
If Test Then WScript.Echo 2,Folder.Items().Count,Count
WScript.Sleep 100
Loop
fso.DeleteFolder FolderName
End Sub
――――――――――――――――――――――――――――――――――――――
ZIP to ZIPへのコピーは、(GUIでも)サポートされていないので、
ZIP to FS + FS to ZIPとせざるを得ません。
ZIPへのCopyHereは非同期なので、前作では、Hidden Explorerを使ってましたが、
ここでは、待合せをすることで、Shell.Applicationで済ますことができました。
ばんのしゃーによかばんた さん
2005年 12月 28日 18時 47分 01秒
エクスプローラのKB単位サイズカラム問題のスクリプト的解決の第４弾です。
一連のスクリプト作成の動機となった元々の課題を直接的に解決します。
ZIPファイル内のファイルがZIPファイル外の親フォルダ内のファイルと比べて、
サイズと更新日時に違いがあるかどうかを調べます。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim fso
Dim Shell
Dim ZIPfile
Dim zFolder
Dim zFolderItem
Dim xFolder
Dim xFolderItem
Dim Rows
If WScript.Arguments.Count<>1 Then
WScript.Echo "No Arguments !"
WScript.Quit
End If
ZIPfile=WScript.Arguments.Item(0)
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
ZIPfile=fso.GetAbsolutePathName(ZIPfile)
If UCase(fso.GetExtensionName(ZIPfile))<>"ZIP" Then
WScript.Echo "Invalid Extension Name -",fso.GetExtensionName(ZIPfile)
WScript.Quit
End If
Set zFolder=Shell.NameSpace(ZIPfile)
Set xFolder=zFolder.ParentFolder
Rows=Array("Name
Size(In)
Size(Out)
Date(In)
Date(Out)")
For Each zFolderItem In zFolder.Items
Set xFolderItem=xFolder.ParseName(zFolderItem.Path)
If xFolderItem Is Nothing Then
Push Rows,Join(Array(zFolderItem.Path,zFolderItem.Size,"",zFolder.GetDetailsOf(zFolderItem,7),""),vbTab)
Else
If zFolderItem.Size<>xFolderItem.Size Or zFolder.GetDetailsOf(zFolderItem,7)<>xFolder.GetDetailsOf(xFolderItem,3) Then
Push Rows,Join(Array(zFolderItem.Path,zFolderItem.Size,xFolderItem.Size,zFolder.GetDetailsOf(zFolderItem,7),xFolder.GetDetailsOf(xFolderItem,3)),vbTab)
End If
End If
Next
If UBound(Rows) Then
WScript.Echo Join(Rows,vbLf)
Else
WScript.Echo fso.GetFileName(ZIPfile)&" is fresh."
End If
WScript.Quit
Sub Push(Items,Item)
ReDim Preserve Items(UBound(Items)+1)
Items(UBound(Items))=Item
End Sub
――――――――――――――――――――――――――――――――――――――
CRC-32も比較したほうがいいのかな。
でも、スクリプトで簡単に外のファイルのCRC-32を得る方法ってあります？
ばんのしゃーによかばんた さん
2005年 12月 28日 18時 46分 47秒
>ばんのしゃーによかばんた さん 2005年 12月 27日 14時 43分 03秒
IEのメモリ上でHTMLを変更しても「名前を付けて保存」できなかったのですが、
今度の小技を使うとできます。
先のスクリプトを以下のように変更します。
Set ie=CreateObject("InternetExplorer.Application")
ie.AddressBar=False
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.designMode="On"
ie.Document.charset="shift_jis"
ie.Document.title=FolderItem.Path
ie.Document.parentWindow.defaultStatus="プロパティページを作成しています..."
ie.Visible=True
ie.Document.designMode="Off"
ie.Document.parentWindow.defaultStatus="プロパティページが作成されました"
End Function
ばんのしゃーによかばんた さん
2005年 12月 27日 14時 43分 35秒
エクスプローラのKB単位サイズカラム問題のスクリプト的解決の第３弾です。
エクスプローラのサイズカラムを代替します。
ただし、スクリプトでカラムを直接操作するのは無理なので、
Infotipの設定で何とかならんものかと思ったのですが、
自動的にKB単位に変換されるようなので、直接ステータスバーを書き換えます。
エクスプローラを開いて「お気に入り」などから起動します。
ファイルの選択に合わせて、ステータスバーにバイト単位で表示します。
スクリプトはステータスバーを閉じると終了します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim Shell
Dim ix
Dim sfv
Dim Document
Set Shell=CreateObject("Shell.Application")
Set ix=Shell.Windows().Item()
Set sfv=CreateObject("Shell.FolderView")
'Set sfv=CreateObject("Shell.FolderView.1")
Call WScript.ConnectObject(sfv,"SFV_")
Set Document=ix.Document
Call sfv.SetFolderView(Document)
Call SelectionChanged()
Do While TypeName(ix)<>"Object"
If Not ix.StatusBar Then
ix.StatusText=WScript.ScriptName&" Ended..."
Exit Do
End If
Call SetFolderView()
WScript.Sleep 1000
Loop
WScript.Quit
Sub SetFolderView()
On Error Resume Next
If Not Document Is ix.Document Then
Set Document=ix.Document
Call sfv.SetFolderView(Document)
End If
End Sub
Sub SFV_SelectionChanged()
Call SelectionChanged()
End Sub
Sub SelectionChanged()
Dim FolderItem
Dim Size
Set FolderItem=ix.Document.FocusedItem
Rem VarType(Size) 21(Integer?) or 0(Empty)
Size=FolderItem.ExtendedProperty("Size")
If IsEmpty(Size) Then
Else
Size=CStr(Size)
'ごみ箱 cluster size
If FolderItem.Size Then Size=FolderItem.Size
'CAB 0
End If
ix.StatusText=FormatNumber(Size,0)&" Bytes "&Left(ix.StatusText,InStr(ix.StatusText,vbNullChar)-1)
End Sub
――――――――――――――――――――――――――――――――――――――
この版はSFVを使うので2000/XP用です。
98/MEでも需要はありますか？ SFVを使わないバージョンもあるにはあります。。。
※しかしまぁ、事ほど左様にWindowsの問題はスクリプトの母ですね。
それだけ問題が多いってことでもありますが。。。
ばんのしゃーによかばんた さん
2005年 12月 27日 14時 43分 03秒
エクスプローラのKB単位サイズカラム問題のスクリプト的解決の第２弾です。
プロパティページを代替します。拡張プロパティやZoneIDなども表示します。
ファイルなど選択してから「お気に入り」などから起動します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim fso
Dim Shell
Dim arg
Dim ParentFolder
Dim FileName
Dim Folder
Dim FolderItem
Dim ie
Set fso=CreateObject("Scripting.FileSystemObject")
Set Shell=CreateObject("Shell.Application")
For Each arg In WScript.Arguments
arg=fso.GetAbsolutePathName(arg)
ParentFolder=fso.GetParentFolderName(arg)
If ParentFolder<>"" Then
FileName=fso.GetFileName(arg)
Else
ParentFolder=17
FileName=arg
End If
Set Folder=Shell.NameSpace(ParentFolder)
If Folder Is Nothing Then
WScript.Echo ParentFolder,"Not Found."
Else
Set FolderItem=Folder.ParseName(FileName)
If FolderItem Is Nothing Then
WScript.Echo FileName,"Not Found."
Else
Call xProp(FolderItem,Folder)
End If
End If
Next
If WScript.Arguments.Count=0 Then
Set ie=Shell.Windows().Item()
If ie Is Nothing Then
ElseIf ie.Busy Then
ElseIf ie.ReadyState<>4 Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderViewDual")=0 Then
ElseIf ie.Document.SelectedItems.Count Then
Set Folder=ie.Document.Folder
Set FolderItem=ie.Document.SelectedItems.Item(0)
Call xProp(FolderItem,Folder)
End If
End If
WScript.Quit
Function xProp(FolderItem,Folder)
If UCase(fso.GetBaseName(WScript.FullName))="CSCRIPT" Then
Call cProp(FolderItem,Folder)
Else
Call wProp(FolderItem,Folder)
End If
End Function
Function wProp(FolderItem,Folder)
Dim ie
Dim k
Dim COL:COL=50
Dim Document
Dim oTABLE
Dim Name
Dim Value
Dim TextFile
Set ie=CreateObject("InternetExplorer.Application")
ie.ToolBar=False
ie.StatusBar=False
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
Set Document=ie.Document
Document.charset="shift_jis"
Document.title=FolderItem.Path
ie.Visible=True
Document.body.innerHTML="<table id='oTABLE' border=1></table>"
Set oTABLE=Document.all.oTABLE
'"InfoTip"="prop:Type;DocAuthor;DocTitle;DocSubject;DocComments;Write;Size"
insertRow oTABLE,"p","Path",FolderItem.Path
insertRow oTABLE,"x","Directory",FolderItem.ExtendedProperty("Directory")
insertRow oTABLE,"p","Name",FolderItem.Name
insertRow oTABLE,"x","Name",FolderItem.ExtendedProperty("Name")
insertRow oTABLE,"p","Size",FolderItem.Size
insertRow oTABLE,"x","Size",FolderItem.ExtendedProperty("Size")
insertRow oTABLE,"p","ModifyDate",FolderItem.ModifyDate
insertRow oTABLE,"x","Write",FolderItem.ExtendedProperty("Write")
insertRow oTABLE,"x","Create",FolderItem.ExtendedProperty("Create")
insertRow oTABLE,"x","Access",FolderItem.ExtendedProperty("Access")
insertRow oTABLE,"p","Type",FolderItem.Type
insertRow oTABLE,"x","Type",FolderItem.ExtendedProperty("Type")
insertRow oTABLE,"x","Attributes",FolderItem.ExtendedProperty("Attributes")
For k=-1 To COL
Name=Folder.GetDetailsOf(,k)
If k=-1 Then Name=Replace("Type;DocAuthor;DocTitle;DocSubject;DocComments;Write;Size",";",vbCrLf)
Value=Folder.GetDetailsOf(FolderItem,k)
If Name<>"" Or Value<>"" Then
insertRow oTABLE,k,Name,Value
End If
Next
If fso.FileExists(FolderItem.Path&":Zone.Identifier") Then
Set TextFile=fso.OpenTextFile(FolderItem.Path&":Zone.Identifier")
Name=TextFile.ReadLine()
Value=TextFile.ReadLine()
insertRow oTABLE,"z",Name,Value
End If
End Function
Function cProp(FolderItem,Folder)
Dim k
Dim COL:COL=50
Dim Name
Dim Value
Dim TextFile
WScript.Echo "p","Path",FolderItem.Path
WScript.Echo "x","Directory",FolderItem.ExtendedProperty("Directory")
WScript.Echo "p","Name",FolderItem.Name
WScript.Echo "x","Name",FolderItem.ExtendedProperty("Name")
WScript.Echo "p","Size",FolderItem.Size
WScript.Echo "x","Size",FolderItem.ExtendedProperty("Size")
WScript.Echo "p","ModifyDate",FolderItem.ModifyDate
WScript.Echo "x","Write",FolderItem.ExtendedProperty("Write")
WScript.Echo "x","Create",FolderItem.ExtendedProperty("Create")
WScript.Echo "x","Access",FolderItem.ExtendedProperty("Access")
WScript.Echo "p","Type",FolderItem.Type
WScript.Echo "x","Type",FolderItem.ExtendedProperty("Type")
WScript.Echo "x","Attributes",FolderItem.ExtendedProperty("Attributes")
For k=-1 To COL
Name=Folder.GetDetailsOf(,k)
Value=Folder.GetDetailsOf(FolderItem,k)
If Name<>"" Or Value<>"" Then
WScript.Echo k,Name,Value
End If
Next
If fso.FileExists(FolderItem.Path&":Zone.Identifier") Then
Set TextFile=fso.OpenTextFile(FolderItem.Path&":Zone.Identifier")
Name=TextFile.ReadLine()
Value=TextFile.ReadLine()
WScript.Echo "z",Name,Value
End If
End Function
Sub insertRow(oTABLE,k,Name,Value)
Dim oTR
Dim oTD
Set oTR=oTABLE.insertRow
Set oTD=oTR.insertCell
oTD.InnerText=k
Set oTD=oTR.insertCell
oTD.InnerText=Name
Set oTD=oTR.insertCell
oTD.InnerText=Value
End Sub
ばんのしゃーによかばんた さん
2005年 12月 27日 14時 42分 14秒
早速、訂正。
>ばんのしゃーによかばんた さん 2005年 12月 26日 16時 36分 59秒
>新開発の小技を使ってみました。これは何をしているんだろう？という箇所です。
>これだと、
>\が\に表示され、
>「名前を付けて保存」でshift_jisで保存され、
ここまではよいけれど。
>shift_jisで文字化けもしない、
>という3条件が簡単に実現できます。
早とちり。
(c)コピーライトや(R)登録商標などはfsoのwriteで自動変換されるんですよね。
忘れてた。TMトレードマークだと駄目。これでテストしないといけなかった。
しかし、ちょっと閃いて、以下のようにしたら、今度はよいようです。
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate tPath
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.designMode="On"
ie.Document.charset="shift_jis"
ie.ExecWB 3,0
ie.Document.designMode="Off"
ie.Visible=True
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
fso.DeleteFile tPath
ExecWBの3はこれです。Const OLECMDID_SAVE=3
HTMLファイルの文字コード変換は、これでダイアログなしに実行できますね。
元ファイルに反映する必要がなければ、ExecWB行は不要。
つまり、SaveAsのエンコードの指定をスクリプトでやるときに利用できます。
ばんのしゃーによかばんた さん
2005年 12月 26日 16時 36分 59秒
エクスプローラのKB単位サイズカラム問題のスクリプト的解決の第一弾です。
エクスプローラの詳細表示を代替します。
サイズカラムをバイト単位に変えて表示します。
「お気に入り」などから起動します。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim fso
Dim wShell
Dim Shell
Dim ie
Set fso=CreateObject("Scripting.FileSystemObject")
Set wShell=CreateObject("WScript.Shell")
Set Shell=CreateObject("Shell.Application")
Set ie=Shell.Windows().Item()
If ie Is Nothing Then
WScript.Echo "No Explorer Found."
WScript.Quit
End If
If Not Test(ie) Then
For Each ie In Shell.Windows()
If Test(ie) Then Exit For
Next
End If
If IsEmpty(ie) Then
WScript.Echo "No Explorer Found."
WScript.Quit
End If
Function Test(ie)
If ie.Busy Then
ElseIf ie.ReadyState<>4 Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderViewDual") Then
Test=True
End If
End Function
Dim Folder
Dim FolderItem
Dim k
Dim COL:COL=50
Dim tPath
Dim StdOut
Dim Title
Dim Name
Dim SizeColumn
Dim Size
Set Folder=ie.Document.Folder
On Error Resume Next
Title=Folder.Items().Item().Path
On Error GoTo 0
If Title="" Then
Title=Folder.Title
ElseIf Left(Title,2)="::" Then
Title=Folder.Title & " " & Title
End If
tPath=fso.BuildPath(fso.GetSpecialFolder(2).Path,fso.GetBaseName(fso.GetTempName())&".htm")
Set StdOut=fso.CreateTextFile(tPath,,True)
StdOut.WriteLine "<html><head>"
StdOut.WriteLine "<title>" & Title & "</title>"
StdOut.WriteLine "</head><body>"
StdOut.WriteLine "<table BORDER>"
StdOut.WriteLine "<caption>" & Title & "</caption>"
For COL=COL To 0 Step -1
If Folder.GetDetailsOf(,COL)<>"" Then Exit For
Next
StdOut.WriteLine "<tr>"
For k=0 To COL
Name=Folder.GetDetailsOf(,k)
StdOut.WriteLine "<td>"&Name&"</td>"
Select Case Name
Case "サイズ","元のサイズ" SizeColumn=k
End Select
Next
StdOut.WriteLine "</tr>"
For Each FolderItem In Folder.Items()
StdOut.WriteLine "<tr>"
For k=0 To COL
If k=SizeColumn Then
Size=FolderItem.ExtendedProperty("Size")
Rem VarType(Size) 21(Integer?) or 0(Empty)
If IsEmpty(Size) Then
Else
Size=CStr(Size)
'ごみ箱 cluster size
If FolderItem.Size Then Size=FolderItem.Size
'CAB 0
End If
Else
Size=""
End If
If Size<>"" Then
StdOut.WriteLine "<td>"&Size&"</td>"
Else
StdOut.WriteLine "<td>"&Folder.GetDetailsOf(FolderItem,k)&"</td>"
End If
Next
StdOut.WriteLine "</tr>"
Next
StdOut.WriteLine "</table></body></html>"
StdOut.Close
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate tPath
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.charset="shift_jis"
fso.OpenTextFile(tPath,2).Write ie.Document.documentElement.outerHTML
ie.Navigate tPath
ie.Visible=True
Do While TypeName(ie)="IWebBrowser2"
WScript.Sleep 100
Loop
fso.DeleteFile tPath
WScript.Quit
――――――――――――――――――――――――――――――――――――――
新開発の小技を使ってみました。これは何をしているんだろう？という箇所です。
これだと、
\が\に表示され、
「名前を付けて保存」でshift_jisで保存され、
shift_jisで文字化けもしない、
という3条件が簡単に実現できます。
ところで、FolderItem.ExtendedProperty("Size")で取れる型は何でしょう？
TypeName()するとVBScriptで扱えない型でエラーになります。
VarType()は21です。64bit整数とかでしょうか？
※メモ
Folder.GetDetailsOf(FolderItem,k)
KB単位。
FolderItem.ExtendedProperty("Size")
Byte単位。Cacheは0。ごみ箱はcluster sizeに切り上げ。
FolderItem.Size
Byte単位。CABとCacheは0。
ばんのしゃーによかばんた さん
2005年 12月 26日 16時 36分 35秒
私の場合、複数ファイルのタイムスタンプの時分にバージョンを設定して、
ZIPにまとめることが多いのですが、一旦まとめた後もファイルを修正しては入れ替えます。
そういうときに、あれ？ZIPの中身は入れ替えたかなと、ちょこっと確認したいのですが、
タイムスタンプは同じなので、サイズで確認しようとすると、これが問題なのです。
エクスプローラの詳細表示のサイズカラムはKB単位です。
これをバイト単位に変える方法はないものでしょうか。
それくらいはカストマイズ可能にしておいて欲しいものです。
普通のフォルダでは、ファイルのプロパティを表示すれば、バイト単位が分かりますが、
ZIPフォルダでは、プロパティでも、KB単位しか分からない。
CABファイルのフォルダビューには、プロパティ表示すらない。
VBなどでシェル拡張のカラムハンドラを作ればよいようですが。。。
仕方なく、コマンドプロンプトでDIRとPKZIP -vしたり、
それらをSendToに入れてみたりしていますが、もうひとつです。
※当記事は投稿条件からは外れているのですが、後述のスクリプトの作成動機と
なったものなので、スクリプトの制作意図を伝えるものとして書き込んでいます。
ばんのしゃーによかばんた さん
2005年 12月 25日 16時 55分 26秒
バイナリの序でに、SummaryInformationを読み出すサンプルです。
Folder.GetDetailsOf(FolderItem,k)やFolderItem.ExtendedPropertyでは、
キーワード欄が取り出せなかったのですが、これなら、取り出せます。
一方、カテゴリ欄はもうひとつ別のストリーム(:\005DocumentSummaryInformation)に
入っているので、これでは取り出せません。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const adTypeBinary=1
Const adTypeText=2
Dim Path
Dim Src
Dim wByteOrder
Dim wFormat
Dim cOSVersion
Dim cOSLevel
Dim wOSPlatform
Dim clsid
Dim dwReserved
Dim fmtid
Dim dwOffset
Dim dwSectionSize
Dim dwProperties
Dim Rows:Rows=Array()
Path=WScript.Arguments.Item(0)
Set Src=CreateObject("ADODB.Stream")
Src.Open
Src.Type=adTypeBinary
Src.LoadFromFile Path&":"&Chr(5)&"SummaryInformation"
Push Rows,Join(Array("StreamSize",Hex(Src.Size)),vbTab)
wByteOrder=ReadWord(Src,0)
Push Rows,Join(Array("wByteOrder",Hex(wByteOrder)),vbTab)
'&HFFFE FE,FF BigEndian
wFormat=ReadWord(Src,2)
Push Rows,Join(Array("wFormat",wFormat),vbTab)
'0
cOSVersion=ReadByte(Src,4)
Push Rows,Join(Array("cOSVersion",cOSVersion),vbTab)
'5 2000
cOSLevel=ReadByte(Src,5)
Push Rows,Join(Array("cOSLevel",cOSLevel),vbTab)
'1 XP
wOSPlatform=ReadWord(Src,6)
Push Rows,Join(Array("wOSPlatform",wOSPlatform),vbTab)
'2 Win32/NT
clsid=Read(Src,8,16)
Push Rows,Join(Array("clsid",Hexa(clsid)),vbTab)
'00000000-00000000-00000000-00000000
dwReserved=ReadLong(Src,&H18)
Push Rows,Join(Array("dwReserved",dwReserved),vbTab)
'1
fmtid=Read(Src,&H1C,16)
Push Rows,Join(Array("fmtid",Hexa(fmtid)),vbTab)
'E0859FF2-F94F6810-AB910800-2B27B3D9
dwOffset=ReadLong(Src,&H2C)
Push Rows,Join(Array("dwOffset",Hex(dwOffset)),vbTab)
dwSectionSize=ReadLong(Src,dwOffset)
Push Rows,Join(Array("dwSectionSize",Hex(dwSectionSize)),vbTab)
dwProperties=ReadLong(Src,dwOffset+4)
Push Rows,Join(Array("dwProperties",dwProperties),vbTab)
Const PID_CodePage=1
Const PID_Locale=-2147483648
Const PID_Title=2
Const PID_Subject=3
Const PID_Author=4
Const PID_Keywords=5
Const PID_Comments=6
Dim k
Dim dwPropID
Dim dwPropOffset
Dim dwType
Dim dwSize
Dim wCodePage
Dim dwLocale
Dim szTitle
Dim szSubject
Dim szAuthor
Dim szKeywords
Dim szComments
For k=1 To dwProperties
dwPropID=ReadLong(Src,dwOffset+8*k)
Push Rows,Join(Array("dwPropID["&k&"]",Hex(dwPropID)),vbTab)
dwPropOffset=ReadLong(Src,dwOffset+8*k+4)
Push Rows,Join(Array("dwPropOffset["&k&"]",Hex(dwPropOffset)),vbTab)
Select Case dwPropID
Case PID_CodePage
dwType=ReadLong(Src,dwOffset+dwPropOffset)
Push Rows,Join(Array("dwType",Hex(dwType)),vbTab)
'VT_I2 2
wCodePage=ReadWord(Src,dwOffset+dwPropOffset+4)
Push Rows,Join(Array("wCodePage",wCodePage),vbTab)
Case PID_Locale
dwType=ReadLong(Src,dwOffset+dwPropOffset)
Push Rows,Join(Array("dwType",Hex(dwType)),vbTab)
'VT_U4 19 &H13
dwLocale=ReadLong(Src,dwOffset+dwPropOffset+4)
Push Rows,Join(Array("dwLocale",dwLocale),vbTab)
Case PID_Title,PID_Subject,PID_Author,PID_Keywords,PID_Comments
dwType=ReadLong(Src,dwOffset+dwPropOffset)
Push Rows,Join(Array("dwType",Hex(dwType)),vbTab)
'VT_LPSTR 30 &H1E
dwSize=ReadLong(Src,dwOffset+dwPropOffset+4)
Push Rows,Join(Array("dwSize",Hex(dwSize)),vbTab)
Select Case dwPropID
Case PID_Title
szTitle=ReadText(Src,dwOffset+dwPropOffset+8,-dwSize)
Push Rows,Join(Array("szTitle",szTitle),vbTab)
Case PID_Subject
szSubject=ReadText(Src,dwOffset+dwPropOffset+8,-dwSize)
Push Rows,Join(Array("szSubject",szSubject),vbTab)
Case PID_Author
szAuthor=ReadText(Src,dwOffset+dwPropOffset+8,-dwSize)
Push Rows,Join(Array("szAuthor",szAuthor),vbTab)
Case PID_Keywords
szKeywords=ReadText(Src,dwOffset+dwPropOffset+8,-dwSize)
Push Rows,Join(Array("szKeywords",szKeywords),vbTab)
Case PID_Comments
szComments=ReadText(Src,dwOffset+dwPropOffset+8,-dwSize)
Push Rows,Join(Array("szComments",szComments),vbTab)
End Select
Case Else
dwType=ReadLong(Src,dwOffset+dwPropOffset)
Push Rows,Join(Array("dwType ???",Hex(dwType)),vbTab)
End Select
Next
Src.Close
Set Src=Nothing
WScript.Echo Join(Rows,vbLf)
WScript.Quit
Function Hexa(Bytes)
Dim k
For k=1 To LenB(Bytes)
Hexa=Hexa&Mid(Hex(AscB(MidB(Bytes,k,1))+256),2)
Next
End Function
Sub Push(Items,Item)
ReDim Preserve Items(UBound(Items)+1)
Items(UBound(Items))=Item
End Sub
Function Read(Stream,Position,Length)
Stream.Position=Position
Read=Stream.Read(Length)
End Function
Function ReadByte(Stream,Position)
Stream.Position=Position
ReadByte=AscB(Stream.Read(1))
End Function
Function ReadWord(Stream,Position)
Dim Bytes
Stream.Position=Position
Bytes=Stream.Read(2)
ReadWord=AscB(MidB(Bytes,1,1))+AscB(MidB(Bytes,2,1))*256
End Function
Function ReadLong(Stream,Position)
Dim Bytes
Stream.Position=Position
Bytes=Stream.Read(4)
'ReadLong=AscB(MidB(Bytes,1,1))+AscB(MidB(Bytes,2,1))*256+AscB(MidB(Bytes,3,1))*256*256+AscB(MidB(Bytes,4,1))*256*256*256
If AscB(MidB(Bytes,4,1)) And &H80 Then
ReadLong=AscB(MidB(Bytes,1,1))+AscB(MidB(Bytes,2,1))*256+AscB(MidB(Bytes,3,1))*256*256+(AscB(MidB(Bytes,4,1)) And &H7F)*256*256*256
ReadLong=ReadLong-2147483648
Else
ReadLong=AscB(MidB(Bytes,1,1))+AscB(MidB(Bytes,2,1))*256+AscB(MidB(Bytes,3,1))*256*256+AscB(MidB(Bytes,4,1))*256*256*256
End If
End Function
Function ReadText(Stream,Position,Length)
Dim Code
Dim Chars
Stream.Position=0
Stream.Type=adTypeText
Stream.Charset="shift_jis"
Stream.Position=Position
If Length>0 Then
ReadText=Stream.ReadText(Length)
ElseIf Length<0 Then
ReadText=Stream.ReadText(-Length)
ReadText=Left(ReadText,InStr(ReadText,vbNullChar)-1)
Else
Chars=Array()
Do
Code=Stream.ReadText(1)
If Code=vbNullChar Then Exit Do
Push Chars,Code
Loop
ReadText=Join(Chars,"")
End If
Stream.Position=0
Stream.Type=adTypeBinary
End Function
――――――――――――――――――――――――――――――――――――――
逆をやれば書き込みになります。こちらの需要はあります？
バイト配列を迂回するためにコツが必要で、もっと長くなるので、
需要がなければ割愛します。
あと、OLE Storage内で、このストリームへの辿り方が分かればよいのですが。。。
ばんのしゃーによかばんた さん
2005年 12月 24日 15時 30分 49秒
>ばんのしゃーによかばんた さん 2005年 12月 22日 16時 07分 44秒
補足記事です。
>Function ReadText(Stream,Position,Length)
当初、Null Terminated Stringを読むのに、Stream.LineSeparatorに0を入れて、
Stream.ReadText(adReadLine)しようとしたのですが、
Stream.LineSeparatorが0を受け付けてくれません。融通のきかない奴！
そこで、同等機能を
Chars=Array()
Do
Code=Stream.ReadText(1)
If Code=vbNullChar Then Exit Do
Push Chars,Code
Loop
ReadText=Join(Chars,"")
のようにインプリメントしたのですが、遅い！６倍くらい遅い。
そこで、一度に多めに読んで、NULで切り落とすように変えました。
ElseIf Length<0 Then
ReadText=Stream.ReadText(-Length)
ReadText=Left(ReadText,InStr(ReadText,vbNullChar)-1)
AKA さん
2005年 12月 24日 06時 27分 12秒
クリップボード機能のオートメーションオブジェクトを作りました。
http://winscript.s41.xrea.com/wiki/index.php?plugin=attach&pcmd=open&file=IECBD001.LZH&refer=%5B%5B%A5%A2%A5%C3%A5%D7%A5%ED%A1%BC%A5%C0%A1%BC%5D%5D
そんなもの何がいいの？、と言われそうですが、IEのclipboardDataと互換になっています。
すなわちスクリプト中でクリップボードを使うだけのためにIEを起動している場合に、簡単にパフォーマンスを上げることができます。
Set ie = CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
ie.document.parnetWindow.clipboardData.setData "Text", sFileName
こんな風に書かれている場合、これをコメントアウトし、すぐ下にでも、
Set cb = CreateObject("clipboardData")
cb.setData "Text", sFileName
のように書いておけば、クリップボード処理が格段に速くなります。
(IEをすでに起動しているような場合には基本的には必要ないが、IEのclipboardDataの設計には致命的バグがあるので、IEを起動していても別のクリップボードが必要になることがあるのだ・・・)
IEを使っている部分を消さずに残しておけば、必要になった時にすぐにIEを使うように戻せます。
現在の所、フォーマットは"Text"にしか対応していませんが、"Url"にも対応して欲しい方がいたらリクエスト下さい。
>>ばんのしゃーによかばんた さん 2005年 12月 16日 18時 38分 57秒
>どうも、後から起動したIEが、先に起動したIEへの参照を持っているみたいです。
？
というか、単にiexplore.exeが起動される原因となったオブジェクトだけがウィンドウクローズによる破棄を免れるみたいです。(クローズがiexplore.exeの終了を意味する場合を除く)
>>管理人むたぐち さん 2005年 12月 21日 23時 57分 55秒
動作確認ありがとうございました。m(_ _)m
>今後気をつけます。
いえ、管理人さんに言ったつもりではないんです。どうも、すみません。
ばんのしゃーによかばんた さん
2005年 12月 23日 12時 36分 39秒
エクスプローラでファイルやフォルダを｢切り取り」または｢コピー」した情報を
スクリプトから取り出せます。(既出)
今回は、｢切り取り」と｢コピー」の区別も出来ます。
エクスプローラでファイルやフォルダを｢切り取り」または｢コピー」してから
以下のスクリプトを起動してください。
――――――――――――――――――――――――――――――――――――――
Option Explicit
If WScript.Arguments.Count=0 Then
Call mother()
Else
Call daughter()
End If
WScript.Quit
Sub mother()
Dim Shell
Dim Folder
Dim FolderItem
Dim Verb
Dim k
Dim Text
Dim CutOrCopy
Set Shell=CreateObject("Shell.Application")
Set Folder=Shell.NameSpace(Left(WScript.FullName,InStrRev(WScript.FullName,"\")))
Set FolderItem=Folder.Items.Item(Mid(WScript.FullName,InStrRev(WScript.FullName,"\")+1))
For Each Verb In FolderItem.Verbs
If Verb.Name="貼り付け(&P)" Then Exit For
Next
If IsEmpty(Verb) Then CutOrCopy="切り取り" Else CutOrCopy="コピー"
Set Folder=Shell.NameSpace(Left(WScript.ScriptFullName,InStrRev(WScript.ScriptFullName,"\")))
Set FolderItem=Folder.Items.Item(WScript.ScriptName)
For Each Verb In FolderItem.Verbs
If Verb.Name="貼り付け(&P)" Then Exit For
Next
If IsEmpty(Verb) Then
WScript.Echo "データがありません。"
WScript.Quit
End If
Verb.DoIt
For k=1 To 100
WScript.Sleep 100
Text=GetCLipByMsIE()
If Text<>"" Then Exit For
Next
If Text="" Then
WScript.Echo "Failed. Timed Out."
WScript.Quit
End If
WScript.Echo CutOrCopy&vbLf&Replace(Text,vbCrLf,vbLf)
End Sub
Function GetCLipByMsIE()
Const OLECMDID_PASTE = 13
Const OLECMDEXECOPT_DODEFAULT = 0
Dim ie
Set ie=CreateObject("InternetExplorer.Application")
'ie.Visible=true
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.write "<html><body><textarea id=txt></textarea></body></html>"
ie.Document.all.txt.focus
Call ie.ExecWB(OLECMDID_PASTE,OLECMDEXECOPT_DODEFAULT)
GetCLipByMsIE=ie.document.all.txt.Value
ie.Quit
End Function
Sub daughter()
Dim k:k=0
Dim args():ReDim args(WScript.Arguments.Count-1)
For k=0 To WScript.Arguments.Count-1
args(k)=WScript.Arguments(k)
Next
Call PutClipByMsIE(Join(args,vbCrLf))
End Sub
Function PutClipByMsIE(args)
Const OLECMDID_COPY = 12
Const OLECMDID_SELECTALL = 17 '(&H11)
Const OLECMDEXECOPT_DODEFAULT = 0
Dim ie
Set ie=CreateObject("InternetExplorer.Application")
'ie.Visible=true
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.Body.InnerText=args
ie.ExecWB OLECMDID_SELECTALL,OLECMDEXECOPT_DODEFAULT
ie.ExecWB OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT
ie.Quit
End Function
ばんのしゃーによかばんた さん
2005年 12月 22日 16時 07分 44秒
CacheフォルダのURL/実パス一覧とURL→実パス変換です。
全部を調べ上げるには、VB.NETでWin32APIを使ってやるしかないのかなぁ、
と思っていましたが、見ると、INDEX.DATが単純な構造みたいなので、
スクリプトでやってみました。性能も結構よさそうです。
※構造解析は適当なので、もっと正確な辿り方があれば教えてください。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Const ssfINTERNETCACHE=32
'shell:Cache
Const adTypeBinary=1
Const adTypeText=2
Dim Shell
Dim Folder
Dim fso
Dim tPath
Dim Start:Start=Timer
Set Shell=CreateObject("Shell.Application")
Set Folder=Shell.NameSpace(ssfINTERNETCACHE)
Set fso=CreateObject("Scripting.FileSystemObject")
Folder=Folder.Items().Item().Path&"\CONTENT.IE5\"
tPath=fso.BuildPath(fso.GetSpecialFolder(2).Path,fso.GetTempName())
fso.CopyFile Folder&"INDEX.DAT",tPath
Dim Stream
Dim TextFile
Dim nFolders
Dim Folders
Dim k
Dim p
Dim ID
Dim nLen
Dim nPos
Dim URL
Dim FileName
Dim nFolder
Dim dic
Dim Count:Count=0
Set Stream=CreateObject("ADODB.Stream")
Stream.Open
Stream.Type=adTypeBinary
Stream.LoadFromFile tPath
Set TextFile=fso.CreateTextFile(tPath)
TextFile.WriteLine Folder
nFolders=ReadByte(Stream,&H48)
'MsgBox nFolders
Folders=Array()
For k=0 To nFolders-1
Push Folders,ReadText(Stream,&H50+12*k,8)
Next
'MsgBox Join(Folders)
Const URL_=&H204C5255
Const REDR=&H52444552
Const LEAK=&H4B41454C
Const HASH=&H48534148
Set dic=CreateObject("Scripting.Dictionary")
For p=&H4000 To Stream.Size-1 Step &H80
ID=ReadLong(Stream,p)
nLen=ReadByte(Stream,p+4)
Select Case ID
Case URL_
Count=Count+1
nFolder=ReadByte(Stream,p+&H38)
nPos=ReadLong(Stream,p+&H34)
URL=ReadText(Stream,p+nPos,nPos-&H80*nLen)
nPos=ReadLong(Stream,p+&H3C)
FileName=ReadText(Stream,p+nPos,nPos-&H80*nLen)
dic.Add URL,Folders(nFolder)&"\"&FileName
' TextFile.WriteLine nPos
TextFile.WriteLine URL
' TextFile.WriteLine Folder&Folders(nFolder)&"\"&FileName
TextFile.WriteLine Folders(nFolder)&"\"&FileName
p=p+&H80*(nLen-1)
Case REDR,LEAK,HASH,3735928559
p=p+&H80*(nLen-1)
Case &H0BADF00D
Case Else
TextFile.WriteLine "####"&vbTab&p&vbTab&ID
Exit For
End Select
Next
Start=Timer-Start
TextFile.WriteLine Count&vbTab&Start
TextFile.Close
'MsgBox Count&vbTab&Start&vbTab&p&vbTab&ID
Dim wShell
Set wShell=CreateObject("WScript.Shell")
wShell.Run "NotePad.EXE "&tPath,,True
fso.DeleteFile tPath
FileName=""
Dim Prompt
Prompt="Enter URL - "
Do
URL=InputBox(Prompt,WScript.ScriptName,FileName)
If IsEmpty(URL) Then Exit Do
If dic.Exists(URL) Then
Prompt="Found. - "&URL
FileName=Folder&dic.Item(URL)
ElseIf fso.FileExists(URL) Then
Prompt="Explored. - "&URL
wShell.Run "Explorer.EXE /select,"&URL
FileName=URL
Else
Prompt="Not Found. - "&URL
FileName=URL
End If
Loop
WScript.Quit
Sub Push(Items,Item)
ReDim Preserve Items(UBound(Items)+1)
Items(UBound(Items))=Item
End Sub
Function Read(Stream,Position,Length)
Stream.Position=Position
Read=Stream.Read(Length)
End Function
Function ReadByte(Stream,Position)
Stream.Position=Position
ReadByte=AscB(Stream.Read(1))
End Function
Function ReadLong(Stream,Position)
Dim Bytes
Stream.Position=Position
Bytes=Stream.Read(4)
ReadLong=AscB(MidB(Bytes,1,1))+AscB(MidB(Bytes,2,1))*256+AscB(MidB(Bytes,3,1))*256*256+AscB(MidB(Bytes,4,1))*256*256*256
End Function
Function ReadText(Stream,Position,Length)
Dim Code
Dim Chars
Stream.Position=0
Stream.Type=adTypeText
Stream.Charset="shift_jis"
Stream.Position=Position
If Length>0 Then
ReadText=Stream.ReadText(Length)
ElseIf Length<0 Then
ReadText=Stream.ReadText(-Length)
ReadText=Left(ReadText,InStr(ReadText,vbNullChar)-1)
Else
Chars=Array()
Do
Code=Stream.ReadText(1)
If Code=vbNullChar Then Exit Do
Push Chars,Code
Loop
ReadText=Join(Chars,"")
End If
Stream.Position=0
Stream.Type=adTypeBinary
End Function
――――――――――――――――――――――――――――――――――――――
ばんのしゃーによかばんた さん
2005年 12月 22日 16時 07分 18秒
「ごみ箱」内のファイルやフォルダは右クリックしても、何も出来ませんよね。
「ごみ箱」から削除するにしても、右クリックで中身を確認してからと思っても、
一旦「元に戻す」さないと、何も出来ないというのはなんとも不便です。
「ごみ箱」に入れたまま、右クリックで元と同じ操作が出来たら便利だと思いません？
以下のスクリプトを使えば、それが出来ます！
「ごみ箱」を開き、ファイルやフォルダを選択して、
「お気に入り」や｢リンク」から起動すると、対応する実ファイルや実フォルダを
別のエクスプローラで開きます。そこでは右クリックが自由自在です。
――――――――――――――――――――――――――――――――――――――
Option Explicit
Dim Shell
Dim Path
Dim fso
Dim wShell
Dim ans
Dim Folder
Dim File
Dim SubFolder
Dim ie
Dim FolderItem
Dim NewFolder
Set Shell=CreateObject("Shell.Application")
Path=Shell.Windows().Item().Document.FocusedItem.Path
Set fso=CreateObject("Scripting.FileSystemObject")
Set wShell=CreateObject("WScript.Shell")
If fso.FileExists(Path) Then
ans=MsgBox(Path,vbYesNoCancel,"View Path with [Yes]Explorer [No]NotePad [Cancel]Clipboard ?")
If ans=vbYes Then
Set File=fso.GetFile(Path)
Set Folder=File.ParentFolder
If Folder.SubFolders.Count=0 Then
NewFolder=fso.GetTempName()
Folder.SubFolders.Add NewFolder
End If
For Each SubFolder In Folder.SubFolders
Exit For
Next
wShell.Run """"&SubFolder.Path&""""
Do
Set ie=Shell.Windows().Item()
If ie Is Nothing Then
ElseIf ie.Busy Then
ElseIf ie.ReadyState<>4 Then
ElseIf InStr(TypeName(ie.Document),"IShellFolderView")=0 Then
ElseIf ie.Document.Folder.Items().Item().Path=SubFolder.Path Then
Exit Do
End If
WScript.Sleep 100
Loop
wShell.SendKeys "{BS}"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
If Not IsEmpty(NewFolder) Then Folder.SubFolders.Item(CStr(NewFolder)).Delete
Set FolderItem=ie.Document.Folder.Items.Item(File.Name)
ie.Document.SelectItem FolderItem,1+4+8+16
ElseIf ans=vbNo Then
wShell.Run "NotePad.EXE " & Path
ElseIf ans=vbCancel Then
PutClipByMsIE Path
End If
ElseIf fso.FolderExists(Path) Then
ans=MsgBox(Path,vbYesNoCancel,"View Path with [Yes]Explorer [No]Command Prompt [Cancel]Clipboard ?")
If ans=vbYes Then
wShell.Run """"&Path&""""
ElseIf ans=vbNo Then
If InStr(WScript.FullName,"32") Then
wShell.Run "CMD.EXE /K CD /D " & Path
ElseIf CDbl(WScript.Version)>5.5 Then
wShell.CurrentDirectory=Path
wShell.Run "COMMAND.COM"
ElseIf UCase(Left(Path,1))=UCase(Left(fso.GetAbsolutePathName(""),1)) Then
wShell.Run "COMMAND.COM /K CD " & Path
Else
wShell.Run "COMMAND.COM /K " & Left(Path,2) & " | CD " & Path
End If
ElseIf ans=vbCancel Then
PutClipByMsIE Path
End If
End If
Function PutClipByMsIE(Text)
Const OLECMDID_COPY=12
Const OLECMDID_SELECTALL=17 '(&H11)
Const OLECMDEXECOPT_DODEFAULT=0
Dim ie
Set ie=CreateObject("InternetExplorer.Application")
ie.Navigate "about:blank"
Do While ie.Busy Or ie.ReadyState<>4
WScript.Sleep 100
Loop
ie.Document.body.innerText=Text
ie.ExecWB OLECMDID_SELECTALL,OLECMDEXECOPT_DODEFAULT
ie.ExecWB OLECMDID_COPY,OLECMDEXECOPT_DODEFAULT
ie.Quit
Set ie=Nothing
End Function
――――――――――――――――――――――――――――――――――――――
Folders.Item(CStr(FolderName))で、嵌りました。
これも、「VT_BYREF+VT_VARIANT」問題かな。
wShell.SendKeys "{BS}"
なんてやっているのでタイミングエラーが心配。他に方法はないものか。。。
管理人むたぐち さん
2005年 12月 21日 23時 57分 55秒
To: AKA さん
SCRCですが、WinXP SP2およびWindows Server 2003で動作確認しました。
> 初心者とみなすと完全無視。冷たい上級者・・・そしてみんな無反応に・・・今の日本の現状だ・・・
FAQですので○○をキーワードに調べてください、くらいは
書くべきでしたね。今後気をつけます。
Return