從網上找到一些代碼，我改成一個類，功能是創建快捷方式用，不依賴其它組件，直接二進制寫檔案，但現在問題是，無法自定義圖示，無法加入運行引數，也加不了簡介，只能創建一個普能的快捷方式！~
函式代碼如下
Public Function BuitLink(ByVal StrLinkPath As String, ByVal StrFocusFilePath As String, Optional ByVal StrDescrip As String, Optional ByVal StrCommand As String, Optional ByVal StrIconFile As String, Optional ByVal lIconIndex As Long, Optional ByVal lWindowState As Long, Optional ByVal StrRelativePath As String)
Dim FileNum As Integer
Dim LFH As LNKHEAD
Dim LI As LnkInfo
Dim FLI As FILELOCATIONINFO
Dim LVT As LOCALVOLUMETAB
Dim NVT As NETWORKVOLUMETAB
Dim fSeek As Long
Dim Buf() As Byte
Dim iBuf As Integer
Dim ExtraStuffLen As Long
Dim LvtSeek As Long
Dim NvtSeek As Long
Dim RemainSeek As Long
Dim PathSeek As Long
Dim VolumeLableSeek As Long
Dim IDL As SHITEMID
Dim StrPath As String
Dim StrFile As String
Dim lngHandle As Long '存放檔案句柄
On Error Resume Next
Kill StrLinkPath
If Len(Dir(StrFocusFilePath)) = 0 Then
On Error GoTo LineErr
LFH.dwFileAttributes = GetAttr(StrFocusFilePath)
SetAttr StrFocusFilePath, vbNormal
End If
StrFile = Right$(StrFocusFilePath, InStr(1, StrReverse(StrFocusFilePath), "\") - 1)
StrPath = Left$(StrFocusFilePath, Len(StrFocusFilePath) - Len(StrFile))
FileNum = FreeFile()
Open StrLinkPath For Binary As #FileNum
'檔案頭
fSeek = &H1
With LFH
.dwSize = Len(LFH)
.dwGUID(1) = &H21401
.dwGUID(3) = &HC0&
.dwGUID(4) = &H46000000
.dwFlags = SetFlags(True, CBool(Len(StrFile)), CBool(Len(StrDescrip)), CBool(Len(StrRelativePath)), CBool(Len(StrPath)), CBool(Len(StrCommand)), CBool(Len(StrIconFile)))
lngHandle = CreateFile(StrFocusFilePath, GENERIC_READ, FILE_SHARE_READ, ByVal 0&, OPEN_EXISTING, 0, 0)
Debug.Assert GetFileTime(lngHandle, .dwCreationTime, .dwLastaccessTime, .dwModificationTime)
CloseHandle lngHandle
.dwFileLen = FileLen(StrFocusFilePath)
.dwIconIndex = lIconIndex
.dwWinStyle = lWindowState
' dwHotkey
End With
' MsgBox LFH.dwFlags
Put #FileNum, fSeek, LFH
'Exit Function
With LI
' MsgBox LFH.dwFlags
GetFlags LFH.dwFlags, .fgSIIL, .fgToFile, .fgDescript, .fgRelativePath, .fgWorkPath, .fgHaveCommand, .fgCustomIcon
GetLinkAttr LFH.dwFileAttributes, .faReadOnly, .faHide, .faSystem, .faVolumeLabel, .faFolder, .faChanged, .faEncrypted, .faNomal, .faTemporary, .faSparseFile, .faReparsePoint, .faCompression, .faWeaned
.ftCreateTime = FileTimeToDate(LFH.dwCreationTime)
.ftModificateTime = FileTimeToDate(LFH.dwModificationTime)
.ftLastaccessTime = FileTimeToDate(LFH.dwLastaccessTime)
fSeek = fSeek + &H4C
'shell item id list
If .fgSIIL Then
Buf = GetIDListFormPath(StrFocusFilePath)
iBuf = UBound(Buf) - LBound(Buf) + 1
Put #FileNum, fSeek, iBuf
fSeek = fSeek + &H2
Put #FileNum, fSeek, Buf
fSeek = fSeek + iBuf
End If
'指向檔案
If .fgToFile Then
' Public Type FILELOCATIONINFO
' dwSize As Long
' dwSizeOfTpye As Long
' dwFlags As Long
' dwOffsetOfVolume As Long
' dwOffsetOfBasePath As Long
' dwOffsetOfNetworkVolume As Long
' dwOffsetOfRemainingPath As Long
'End Type
With FLI
.dwFlags = &H1
LvtSeek = fSeek + .dwOffsetOfVolume
NvtSeek = fSeek + .dwOffsetOfNetworkVolume
RemainSeek = fSeek + .dwOffsetOfRemainingPath
.dwSize = Len(FLI)
'有本地卷
' MsgBox .dwFlags
If .dwFlags And &H1 Then
' MsgBox VolumeLableSeek
With LVT
'dwVolumeSerialNumber即盤符序列號
Debug.Assert .dwVolumeSerialNumber Or GetSerialNumber("c:\") ', .dwTypeOfVolume, .dwOffsetOfVolumeName
VolumeLableSeek = LvtSeek + .dwOffsetOfVolumeName
MsgBox VolumeLableSeek
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, VolumeLableSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrLocalVolumeLabel = StrConv(Buf(), vbUnicode): .StrLocalVolumeLabel = Left$(.StrLocalVolumeLabel, InStr(1, .StrLocalVolumeLabel, Chr$(0)) - 1)
End With
End With
PathSeek = VolumeLableSeek + iBuf + 1
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, PathSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrLocalPath = StrConv(Buf(), vbUnicode): .StrLocalPath = Left$(.StrLocalPath, InStr(1, .StrLocalPath, Chr$(0)) - 1)
End With
Put #FileNum, LvtSeek, LVT
End If
' Exit Function
'有網路卷
If .dwFlags And &H2 Then
With NVT
Debug.Assert .dwSize
VolumeLableSeek = NvtSeek + .dwOffsetOfNetShareName
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, VolumeLableSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrNetWorkVolumeLabel = StrConv(Buf(), vbUnicode): .StrNetWorkVolumeLabel = Left$(.StrNetWorkVolumeLabel, InStr(1, .StrNetWorkVolumeLabel, Chr$(0)) - 1)
End With
End With
PathSeek = VolumeLableSeek + iBuf + 1
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, PathSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrNetWorkPath = StrConv(Buf(), vbUnicode): .StrNetWorkPath = Left$(.StrNetWorkPath, InStr(1, .StrNetWorkPath, Chr$(0)) - 1)
End With
Put #FileNum, NvtSeek, NVT
End If
'Exit Function
If RemainSeek <> 0 Then
' MsgBox "XXX"
iBuf = -1
ReDim Buf(255)
Do
iBuf = iBuf + 1
Put #FileNum, RemainSeek + iBuf, Buf(iBuf)
Loop Until Buf(iBuf) = 0
With LI
.StrRemainPath = StrConv(Buf(), vbUnicode): .StrRemainPath = Left$(.StrRemainPath, InStr(1, .StrRemainPath, Chr$(0)) - 1)
End With
End If
fSeek = fSeek + .dwSize
Put #FileNum, RemainSeek + iBuf, Buf(iBuf)
End With
Put #FileNum, fSeek, FLI
End If
If .fgDescript Then
LI.StrDescript = GetUnicodeStr(fSeek, FileNum)
End If
If .fgRelativePath Then
LI.StrRelativePath = GetUnicodeStr(fSeek, FileNum)
End If
If .fgWorkPath Then
LI.StrWorkPath = GetUnicodeStr(fSeek, FileNum)
End If
If .fgHaveCommand Then
LI.StrCommandLine = GetUnicodeStr(fSeek, FileNum)
' Put #FileNum, fSeek, StrConv(Len(StrConv(StrCommand, vbUnicode)), vbUnicode)
'Put #FileNum, fSeek, StrConv(StrCommand, vbUnicode)
End If
If .fgCustomIcon Then
LI.StrIconFileName = GetUnicodeStr(fSeek, FileNum)
End If
'后面是附加資料節
If ExtraStuffLen <> 0 Then
Put #FileNum, fSeek, ExtraStuffLen
fSeek = fSeek + 4
End If
End With
' Put #FileNum, fSeek, &HAA
Close #FileNum
SetAttr StrFocusFilePath, Not LFH.dwFileAttributes
Exit Function
LineErr:
MsgBox Err.Description, vbOKOnly, "錯誤"
End Function
這是關于快捷方式的資料
http://blog.csdn.net/liuyukuan/article/details/5990753
請高手幫忙完善一下，謝謝！~
uj5u.com熱心網友回復：
已自行解決！~不麻煩大家了！~uj5u.com熱心網友回復：
http://wenku.baidu.com/link?url=dKTjmZ1naCOOqu6xL2amUn01iPZPw0WqkF2umuicULkfyDbSdktVlbDiKLueEtXhTCfqbAHG4KtmBEmK2AHn60pS1o5pXLsytWUtPoswe6euj5u.com熱心網友回復：
好吧，學習一下。
轉載請註明出處，本文鏈接：https://www.uj5u.com/gongcheng/86808.html
標籤：資源
上一篇：VB 發送滑鼠單擊訊息給picture 控制元件不回應單擊事件
下一篇：求VB做一雙色球選號軟體