フォルダの大きさ

質問

WindowsXPHome SP1です。
新しいフォルダを作り開くとフォルダサイズが画面いっぱいに伸びた状態で開きたいのですが画面いっぱいになって開きません。
画面いっぱいに伸ばしてから閉じてもう一度開けば問題ないのですがすべてのフォルダの初期フォルダの大きさを変更することはできないでしょうか？

回答No.8

ittochan

改良しました(；´・`)>

const HKCU = &H80000001
const REG_SZ = 1
const REG_EXPAND_SZ = 2
const REG_BINARY = 3
const REG_DWORD = 4
const REG_MULTI_SZ = 7
dim StatusChk()
dim arrSubKeys
dim flag,key2
Dim Input

Set WshShell = WScript.CreateObject("WScript.Shell")
i = WshShell.PopUp("「すべてのフォルダに適用」をします(ウィンドウサイズも含む)" ,0,"Windows Script Host",65)
if i<>1 then
WScript.Echo "中止しました"
WScript.Quit
end if

WScript.Echo "基準にしたいフォルダを１つだけ開いてください"

Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")

strBags="Software\Microsoft\Windows\ShellNoRoam\Bags\"
key2="\Shell\Status"
flag=0
set Shell = CreateObject("Shell.Application")
set WindowsShell = Shell.Windows

FldrPath =""

ItmNo = chckfldr()
WindowsShell.item(ItmNo).Quit
Set obj = WshShell.Exec("explorer " & FldrPath )
ItmNo = chckfldr()
do while ItmNo = -1
WScript.Sleep 100
ItmNo = chckfldr()
loop

Set objTarget = WindowsShell.item(ItmNo)

do while objTarget.Busy
WScript.Sleep 100
loop
'WScript.Sleep 1000

GetSubKey()

ReDim StatusChk(UBound(arrSubKeys))
for i=0 to UBound(arrSubKeys)
oReg.GetDWORDValue HKCU,strBags & arrSubKeys(i) & "\Shell" ,"Status" , inta
StatusChk(i) = inta
next

StatusChange()

MovePath "shell:DriveFolder" , True
WScript.Sleep 1000
for i=0 to UBound(arrSubKeys)
oReg.GetDWORDValue HKCU,strBags & arrSubKeys(i) & "\Shell" ,"Status" ,inta
if StatusChk(i) <> inta then
flag=1
Exit For
end if
next

StatusChange()

MovePath FldrPath , True

if flag=1 then
BagNo = i

strKeyPath = strBags & arrSubKeys(BagNo) & "\Shell"
AllFolderKeyPath = strBags & "AllFolders\Shell"

oReg.EnumValues HKCU, strKeyPath, arrValueNames, arrValueTypes
oReg.CreateKey HKCU,AllFolderKeyPath
For i=0 To UBound(arrValueNames)
for j=0 to UBound(arrSubKeys)
strv = arrValueNames(i)
if j<>BagNo then
strKeyPath2 = strBags & arrSubKeys(j) & "\Shell"
Select Case arrValueTypes(i)
Case REG_SZ
stra = WshShell.RegRead( "HKCU\" & strKeyPath & "\" & strv )
if strv<>"FolderType" then
WshShell.RegWrite "HKCU\" & strKeyPath2 & "\" & strv,stra,"REG_SZ"
WshShell.RegWrite "HKCU\" & AllFolderKeyPath & "\" & strv,stra,"REG_SZ"
end if
Case REG_EXPAND_SZ
stra = WshShell.RegRead( "HKCU\" & strKeyPath & "\" & strv )
WshShell.RegWrite "HKCU\" & strKeyPath2 & "\" & strv,stra,"REG_EXPAND_SZ"
WshShell.RegWrite "HKCU\" & AllFolderKeyPath & "\" & strv,stra,"REG_EXPAND_SZ"
Case REG_BINARY
oReg.GetBinaryValue HKCU,strKeyPath ,strv,strValue
oReg.SetBinaryValue HKCU,strKeyPath2 ,strv,strValue
oReg.SetBinaryValue HKCU,AllFolderKeyPath ,strv,strValue
Case REG_DWORD
inta = WshShell.RegRead( "HKCU\" & strKeyPath & "\" & strv )
WshShell.RegWrite "HKCU\" & strKeyPath2 & "\" & strv,inta,"REG_DWORD"
WshShell.RegWrite "HKCU\" & AllFolderKeyPath & "\" & strv,inta,"REG_DWORD"
Case REG_MULTI_SZ
End Select
end if
next
Next
WshShell.Popup "成功しました",0,"Windows Script Host",64
else
WshShell.Popup "失敗しました",0,"Windows Script Host",16
end if

function chckfldr()
j=0
chckfldr = -1
for i=0 to WindowsShell.Count-1
if TypeName(WindowsShell.item(i))<>"Nothing" then
FldrPath = WindowsShell.item(i).LocationURL
if InStr(FldrPath,"file") = 1 then
if j=1 then
WScript.Echo "フォルダが複数開いているので中止します"
WScript.Quit
end if
chckfldr = i
j=1
end if
end if
next
end function

function GetSubKey()
oReg.EnumKey HKCU, strBags, arrSubKeys
end function

sub MovePath(str,flag)
objTarget.Navigate str
if flag then
do
WScript.Sleep 100
loop while objTarget.Busy
end if
end sub
Sub StatusChange()
WshShell.AppActivate obj.ProcessID
WScript.Sleep 100
WshShell.sendkeys "%vb"
End sub

お礼

ありがとうございます。
やってみたところフォルダを開いてくださいの後にエラーが発生しました。
スクリプト: C:\Documents and Settingd\ユーザー名デスクトップ\フォルダ.vbs
行：32
文字：1
エラー:オブジェクトがありません。:'WindowsShell.item(....)'
コード:800A01A8
ソース:Microsoft VBSScript 実行時エラー

補足

お礼の欄にユーザー名デスクトップとなっていますがユーザー名\デスクトップの間違いです。