excel生成查cnki链接

时间: 2017-01-12 / 分类: 生活 / 浏览次数: 1,341 views / 0个评论 发表评论

Sub Macro3()

‘ Macro3 Macro


Dim i, j As Integer
For i = 1 To ActiveSheet.Range(“A65535”).End(xlUp).Row
Range(“A” & i).Select
Selection.Copy
Range(“D” & i).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
“http://kns.cnki.net/kns/brief/Default_Result.aspx?code=SCDB&korder=0&sel=1&db_codes=CJFQ,CJFN,CDFD,CMFD,CPFD,IPFD,CCND&kw=” & UTF8EncodeURI(Range(“A” & i)) _
, TextToDisplay:=”cnki”
Next
End Sub
Function UTF8EncodeURI(szInput)
Dim wch, uch, szRet
Dim x
Dim nAsc, nAsc2, nAsc3
If szInput = “” Then
UTF8EncodeURI = szInput
Exit Function
End If
For x = 1 To Len(szInput)
wch = Mid(szInput, x, 1)
nAsc = AscW(wch)
If nAsc < 0 Then nAsc = nAsc + 65536
If (nAsc And &HFF80) = 0 Then
szRet = szRet & wch
Else
If (nAsc And &HF000) = 0 Then
uch = “%” & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
Else
uch = “%” & Hex((nAsc \ 2 ^ 12) Or &HE0) & “%” & _
Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & “%” & _
Hex(nAsc And &H3F Or &H80)
szRet = szRet & uch
End If
End If
Next
UTF8EncodeURI = szRet
End Function

发表评论

你必须 登录后 才能留言!