fc2ブログ
WSH
こちらの記事を受けて実行するだけでFireFoxの「places.sqlite」ファイルをリネームするvbsを作成してみた。

詳細は同梱のReadMe.txtファイル参照のこと。

FireFoxCacheRev100.zip


続きにソースコード記述



Option Explicit
Const c_ExeFileName = "firefox.exe" '起動中かの確認
Const c_RenameFile = "places.sqlite" 'リネームするファイル名

Call main

Function main
Dim strUser
Dim strPath
Dim strFile
Dim FSO
' On Error Resume Next

'起動中のアプリチェック
If pf_CheckBoot(c_ExeFileName) Then
MsgBox "FireFoxを終了してください。"
Exit Function
End If

'実行確認
If MsgBox("FireFoxの高速化を行います。",vbYesNo) <> vbYes Then
Exit Function
End If

'ユーザー名取得
strUser = pf_GetUserName

'OSバージョンごとにルートパス設定
Select Case pf_GetOSver
Case 0
MsgBox "OSのバージョン取得に失敗しました。"
Exit Function
Case 1,2 '95,98
strPath = "C:\Windows\Application Data\Mozilla\Firefox\Profiles"
Case 3 'NT
strPath = "C:\Winnt\Profiles\" & strUser & "\Application Data\Mozilla\Firefox\Profiles"
Case 4,5,6 '2k,XP,2003
strPath = "C:\Documents and Settings\" & strUser & "\Application Data\Mozilla\Firefox\Profiles"
Case 7,8 'VISTA,7
strPath = "C:\Users\" & strUser & "\AppData\Roaming\Mozilla\Firefox\Profiles"
End Select

'ファイルの格納パス取得(FireFoxなし・ファイルなし・複数 はエラー)
strFile = pf_FileSearch(strPath,c_RenameFile)
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strFile) = False Then
MsgBox "ファイル名の取得に失敗しました。--"
Exit Function
End If

'ファイルのリネーム
If pf_FileReName(strFile , pf_Format(Now()) & "_" & Mid(strFile,InStrRev(strFile,"\") + 1)) = False Then
MsgBox "ファイルのリネームに失敗しました。"
Exit Function
End If

MsgBox "完了"
End Function


'==========================================================================
'機能:アプリケーションが起動中か確認する
'引数:Exeファイルの名前
'返値:True:起動中 False:起動していない
'==========================================================================
Function pf_CheckBoot(strExeName)
On Error Resume Next
Dim ProcessList
Dim Process
pf_CheckBoot = False
Set ProcessList = GetObject("winmgmts:").ExecQuery("select * from Win32_Process where Name='" & strExeName & "'")
For Each Process In ProcessList
pf_CheckBoot = True
Exit For
Next
End Function

'==========================================================================
'機能:OSバージョン取得
'返値:1:Win95 2:Win98 3:NT4 4:2k 5:XP 6:2003 7:VISTA 8:7 0:取得不能
'==========================================================================
Function pf_GetOSver
On Error Resume Next
Dim objWMIService
Dim objOperatingSystems
Dim objOperatingSystem
Dim intOSType
Dim strOSVer
pf_GetOSver = 0

'OS をチェックする
Set objWMIService = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objOperatingSystems = objWMIService.ExecQuery("Select * from Win32_OperatingSystem")
For Each objOperatingSystem In objOperatingSystems
intOSType = objOperatingSystem.OSType
strOSVer = Left(objOperatingSystem.Version, 3)
Next

Select Case intOSType
Case 16 'Windows 95
pf_GetOSver = 1
Case 17 'Windows 98
pf_GetOSver = 2
Case 18
Select Case strOSVer
Case "4.0"
pf_GetOSver = 3 'Windows NT 4.0
Case "5.0"
pf_GetOSver = 4 'Windows 2000
Case "5.1"
pf_GetOSver = 5 'Windows XP
Case "5.2"
pf_GetOSver = 6 'Windows Server 2003
Case "6.0"
pf_GetOSver = 7 'Windows VISTA
Case "6.1"
pf_GetOSver = 8 'Windows 7
Case Else
pf_GetOSver = 0 '取得不能
End Select
Case Else
pf_GetOSver = 0 '取得不能
End Select
End Function

'==========================================================================
'機能:ユーザー名取得
'返値:正常:ユーザー名 失敗:ブランク
'==========================================================================
Function pf_GetUserName
On Error Resume Next
Dim objWSN
Dim strUser
Set objWSN = WScript.CreateObject("WScript.Network")
strUser = objWSN.UserName
pf_GetUserName = strUser
End Function

'==========================================================================
'機能:ファイル検索
'引数:ルートフォルダ(最終\なし),検索するファイル名
'返値:正常:ファイル名を返す(フルパス) 失敗:ブランク 複数:後ろに結合
'==========================================================================
Function pf_FileSearch(strPath,strSearchFileName)
On Error Resume Next
Dim FSO
Dim objDirs
Dim objDir
Dim strGetFileName
Dim clsData
Set clsData = New clsStorage
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
If FSO.FolderExists(strPath) = False Then Exit Function
If FSO.FileExists(strPath & "\" & strSearchFileName) Then strGetFileName = strPath & "\" & strSearchFileName
Set objDirs = FSO.GetFolder(strPath)
For Each objDir In objDirs.SubFolders
If strGetFileName = "" Then
strGetFileName = pf_FileSearch(objDir.Path ,strSearchFileName)
Else
strGetFileName = strGetFileName & pf_FileSearch(objDir.Path ,strSearchFileName)
End If
Next
pf_FileSearch = strGetFileName
End Function

'==========================================================================
'機能:ファイルのリネーム
'引数:変更前のファイル名(フルパス),変更後のファイル名(ファイル名のみ)
'返値:正常:True 失敗:False
'==========================================================================
Function pf_FileReName(strBeforeName,strAfterName)
On Error Resume Next
Dim FSO
Dim objFile
pf_FileReName = False
Set FSO = WScript.CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(strBeforeName) = False Then Exit Function
Set objFile = FSO.GetFile(strBeforeName)
objFile.Name = strAfterName
If Err.Number <> 0 Then Exit Function
pf_FileReName = True
End Function

'==========================================================================
'機能:日付をYYYYMMDDhhmmssで取得
'引数:変換したい日付情報(datetime型)
'返値:正常:YYYYMMDDhhmmss 失敗:""
'==========================================================================
Function pf_Format(datDateTime)
On Error Resume Next
Dim strRet
pf_Format = ""
strRet= Year(datDateTime)
strRet= strRet & Right("0" & Month(datDateTime) , 2)
strRet= strRet & Right("0" & Day(datDateTime) , 2)
strRet= strRet & Right("0" & Hour(datDateTime) , 2)
strRet= strRet & Right("0" & Minute(datDateTime) , 2)
strRet= strRet & Right("0" & Second(datDateTime) , 2)
If Len(strRet) = 14 Then
pf_Format = strRet
End If
End Function

スポンサーサイト



Secret

TrackBackURL
→http://tmnotwork.blog27.fc2.com/tb.php/436-40b1827d