联盟域名：www.cn-dos.net 论坛域名：www.cn-dos.net/forum
DOS，代表着自由开放与发展，我们努力起来，学习FreeDOS和Linux的自由开放与GNU精神，共同创造和发展美好的自由与GNU GPL世界吧！
Dim WshSHell,FSO
On Error Resume Next
Set WshSHell = WScript.CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WinVer = WshSHell.Environment("Process")
Set Args = WScript.Arguments
CloseTime = 5
FileName = WScript.ScriptName
FileFullName = WScript.ScriptFullName
FilePath = FSO.GetParentFolderName(FileFullName)
InsPath = FSO.GetSpecialFolder(1)
InsFullName = FSO.BuildPath(InsPath ,FileName)
LnkPathNT = WshSHell.SpecialFolders(2)
LnkPath9X = WshSHell.SpecialFolders(14)
LnkPathAll = WshSHell.SpecialFolders("StartMenu")
OtherFileName="winclip.exe"
OtherFilePath=FSO.GetSpecialFolder(1)
TemFileName="无标题"
TemFilePath=FSO.GetSpecialFolder(2)
Copyright="玲珑科技"
QQ="QQ:25926183"
Email="Email:fty1995@163.com"
InsTitle="迅速打开快捷方式所在目录"
InsAnswer="打开目标文件夹"
RegPath0="HKEY_CLASSES_ROOT\lnkfile\shell\"
RegValue0="open"
RegForm0="REG_SZ"
RegPath1="HKEY_CLASSES_ROOT\lnkfile\shell\Open Folder\"
RegValue1="打开目标文件夹"
RegForm1="REG_SZ"
RegPath2="HKEY_CLASSES_ROOT\lnkfile\shell\Open Folder\command\"
RegValue2="wscript.exe " & chr(34) & InsFullName & chr(34) & " " & chr(34) & "%L" & chr(34)
RegForm2="REG_SZ"
If WinVer("OS") = "Windows_NT" Then
LnkPath=LnkPathNT
Else
LnkPath=LnkPath9X
End If
IF FileFullName <> InsFullName then
intAnswer = MsgBox("【是】将“"+ InsAnswer +"”加入到快捷方式右键菜单，"&Chr(10)&Chr(10)&"【否】将“"+ InsAnswer +"”从快捷方式右键菜单删除。 ", vbQuestion + vbYesNoCancel, "安装 - "+ InsTitle +" - "+ Copyright)
If intAnswer = vbYes Then
WshSHell.RegWrite RegPath0,RegValue0,RegForm0
WshSHell.RegWrite RegPath1,RegValue1,RegForm1
WshSHell.RegWrite RegPath2,RegValue2,RegForm2
FSO.GetFile(FileFullName).Copy(InsFullName)
WshSHell.popup _
"添加脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _
"添加注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _
chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _
chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _
, CloseTime, "安装成功 - "+ InsTitle +" - "+ Copyright, 0 + 64
end if
If intAnswer = vbNo Then
WshSHell.RegDelete RegPath2
WshSHell.RegDelete RegPath1
FSO.DeleteFile InsFullName
WshSHell.popup _
"删除脚本文件："+chr(10)+InsFullName+chr(10)+chr(10)+ _
"删除注册表项："+chr(10)+chr(34)+ RegPath1 +chr(34)+chr(10)+ _
chr(10) & CloseTime & " 秒钟后本窗口将自动关闭!" +chr(10)+chr(10)+ _
chr(10) & "Copyright(C) " + Copyright +" " & QQ &" " + Email _
, CloseTime, "卸载成功 - "+ InsTitle +" - "+ Copyright, 0 + 64
end if
If intAnswer = vbCancel Then
end if
ELSE
if Args.count="0" then:WScript.Quit(0):end if
LinkName = Args(0)
Set Scut = WshSHell.CreateShortcut(linkname)
Folder = """" & FSO.GetParentFolderName(Scut.TargetPath) & """"
WshSHell.Run(Folder)
END IF
Set WshSHell = Nothing
Set FSO = Nothing
Set Args = Nothing
WScript.Quit(0)
'==========================================================================
'
' NAME: ShowLnkTarget.vbs
'
' AUTHOR: SleepBoy
' DATE : 2006-1-12
'
' COMMENT: 快速显示“快捷方式”中“目标”所在的位置，并把焦点停留在目标上。
'
' 安装说明：1. 放在任意目录中，直接双击脚本，即可完成安装。
' 2. 安装好之后，右键单击快捷方式，会出现一项“显示目标位置”。
' 3. 如果移动了脚本的位置，请再安装一次。
' 4. 脚本名字可以改变。改好之后，请再安装一次。
'
'==========================================================================
Option Explicit
Dim objArgs, WshShell
Set objArgs = WScript.Arguments
Set WshShell = WScript.CreateObject("WScript.Shell")
If objArgs.Count = 1 Then
ShowLnkTarget
ElseIf objArgs.Count = 0 Then
Setup
End If
'==========================================================================
Sub Setup
Dim QM
QM = """"
WshShell.RegWrite "HKCR\lnkfile\shell\ShowLnkTarget\", "显示目标位置"
WshShell.RegWrite "HKCR\lnkfile\shell\ShowLnkTarget\command\", _
QM & WScript.FullName & QM & " " & _
QM & WScript.ScriptFullName & QM & " " & _
QM & "%1" & QM
MsgBox "安装完毕！",64,WScript.ScriptName
End Sub
'---------------------------------------------------------------------------
Sub ShowLnkTarget
Dim lnkname, strComputer, objWMIService, colFiles, objFile
lnkname = Replace(objArgs(0),"\","\\")
strComputer = "."
Set objWMIService = GetObject _
("winmgmts:\\" & strComputer & "\root\cimv2")
Set colFiles = objWMIService.ExecQuery _
("Select * From Win32_ShortcutFile WHERE Name = " & "'" & lnkname & "'")
For Each objFile in colFiles
WshShell.Run ("explorer /n, /select," & objFile.Target)
Next
End Sub
'==========================================================================
'卸载：下列代码保存为REG
'REGEDIT4
'
Originally posted by everest79 at 2007-4-11 06:30:
用这一行不是更简单？ explorer /select,%1
Originally posted by zh159 at 2007-4-11 16:24:
借问 baomaboy 能不能用 VBS 获取图象分辨率、大小（jpg、gif、bmp）（脚本）
Originally posted by kich at 2007-4-12 22:23:
想问一下这里:
Folder = """" & FSO.GetParentFolderName(Scut.TargetPath) & """"
WshSHell.Run(Folder)
那引号,是不是随便几个都O ...
搜索到一个利用WMI的...
Dim arrFile
Dim oFile,oDir,oShell,oLink
arrFile = MyGetFile()
Set oShell = CreateObject("Shell.Application")
Set oDir = oShell.NameSpace(arrFile(1) + "\")
Set oFile = oDir.ParseName(arrFile(0))
Set oLink = oFile.GetLink
WScript.Echo oLink.WorkingDirectory & "\"
Set oFile = Nothing
Set oDir = Nothing
Set oShell = Nothing
'***********************************************************************************
'获得要操作的文件,返回一个包含文件名和路径的数组
'***********************************************************************************
Function MyGetFile()
On Error Resume Next
Dim strFile,objFso,objFile
If WScript.Arguments.Count < 1 Then
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "Lnk 文件|*.lnk"
objDialog.ShowOpen
strFile = objDialog.FileName
Set objDialog = Nothing
Else
strFile = WScript.Arguments(0)
end if
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.GetFile(strFile)
If Err Then
If Err.Number = 5 Then WScript.Quit
WScript.Echo Err.Description
Err.Clear
WScript.Quit
Else
MyGetFile = Array(objFile.Name,objFile.ParentFolder)
End If
Set objFile = Nothing
Set objFso = Nothing
End Function
The_Windows_Shortcut_File_Format.pdf (43.98 KiB, 下载附件所需积分 1 点, 下载次数: 8)Originally posted by zh159 at 2007-4-11 16:24:
借问 baomaboy 能不能用 VBS 获取图象分辨率、大小（jpg、gif、bmp）（脚本）
Dim sFile,str
sFile = "a.bmp"
Set oPicture = LoadPicture(sFile)
str = "文件:" & vbTab & sFile & vbCrLf
str = str & "宽度:" & vbTab & Fix(oPicture.Width / 26.458) & vbCrLf
str = str & "高度:" & vbTab & Fix(oPicture.Height / 26.458)
Set oPicture = Nothing
WScript.Echo str
Dim arrFile
Dim oFile,oDir,oShell
arrFile = MyGetFile()
Set oShell = CreateObject("Shell.Application")
Set oDir = oShell.NameSpace(arrFile(1) + "\")
Set oFile = oDir.ParseName(arrFile(0))
WScript.Echo oDir.GetDetailsOf(oFile,-1)
Set oFile = Nothing
Set oDir = Nothing
Set oShell = Nothing
'***********************************************************************************
'获得要操作的文件,返回一个包含文件名和路径的数组
'***********************************************************************************
Function MyGetFile()
On Error Resume Next
Dim strFile,objFso,objFile
If WScript.Arguments.Count < 1 Then
Set objDialog = CreateObject("UserAccounts.CommonDialog")
objDialog.Filter = "bmp 文件|*.bmp|jpg 文件|*.jpg|ico 文件|*.ico|所有 文件|*.*"
objDialog.ShowOpen
strFile = objDialog.FileName
Set objDialog = Nothing
Else
strFile = WScript.Arguments(0)
end if
Set objFso = CreateObject("Scripting.FileSystemObject")
Set objFile = objFso.GetFile(strFile)
If Err Then
If Err.Number = 5 Then WScript.Quit
WScript.Echo Err.Description
Err.Clear
WScript.Quit
Else
MyGetFile = Array(objFile.Name,objFile.ParentFolder)
End If
Set objFile = Nothing
Set objFso = Nothing
End Function
Dim sFile,str
Dim oStream
Dim bWidth,bHeight
sFile = "a.bmp"
Set oStream = CreateObject("Adodb.Stream")
With oStream
.Type = 1
.Open
.LoadFromFile sFile
End With
'如果是BMP格式，则Position=18，读4字节；
'如果是gif格式，则为Position=6，读2字节；
'如果是png格式，则Position=16，读4字节
oStream.Position = 18
bWidth = oStream.Read(4)
bHeight = oStream.Read(4)
oStream.Close
str = "文件:" & vbTab & sFile & vbCrLf
str = str & "宽度:" & vbTab & Bin2Num(bWidth) & vbCrLf
str = str & "高度:" & vbTab & Bin2Num(bHeight)
Set oStream = Nothing
WScript.Echo str
'二进制流转换为数值
Private Function Bin2Num(binStr)
Dim i,numLen
numLen = Lenb(binStr)
For i = numLen To 1 Step -1
Bin2Num = Bin2Num * 256 + Ascb(Midb(binStr,i,1))
Next
End FunctionOriginally posted by 3742668 at 2007-4-13 08:44:
方法１，利用LoadPicture函数:
Dim sFile,str
sFile = "a.bmp"
Set oPicture = LoadPicture(sFile)
str = "文件:" & vbTab & sFile & vbCr ...