VBA代码备忘笔记
Http相关
Sub test()
Dim url As String, Http As WinHttpRequest, rsp As String
url = " "
Set Http = CreateObject("WinHttp.WinHttpRequest.5.1")
With Http
.Open "GET", url, False
.SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/81.0.4044.122 Safari/537.36"
.SetRequestHeader "Accept", "text/html,application/xhtml+xml,application/xml;q=0.9,image/webp,image/apng,*/*;q=0.8,application/signed-exchange;v=b3;q=0.9"
.SetRequestHeader "Upgrade-Insecure-Requests", "1"
.SetRequestHeader "Sec-Fetch-Site", "same-origin"
.SetRequestHeader "Sec-Fetch-Mode", "navigate"
.SetRequestHeader "Sec-Fetch-User", "?1"
.SetRequestHeader "Sec-Fetch-Dest", "document"
' .SetRequestHeader "Accept-Encoding", "gzip, deflate, br"
.SetRequestHeader "Referer", "https://mynx.sooxie.com/?s=%E9%93%AD%E9%98%B3%E9%9E%8B%E4%B8%9A-A-021"
.send
rsp = UTF8ToGB2312(.responseBody)
Debug.Print .responseText
End With
End Sub
'* ************************************** *
'* 模块名称:modCharset.bas
'* 模块功能:GB2312与UTF8相互转换函数
'* 作者:lyserver
'* ************************************** *
Option Explicit
'- ------------------------------------------- -
' 函数说明:GB2312转换为UTF8
'- ------------------------------------------- -
Public Function GB2312ToUTF8(strIn As String, Optional ByVal ReturnValueType As VbVarType = vbString) As Variant
Dim adoStream As Object
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 2 'adTypeText
adoStream.Open
adoStream.WriteText strIn
adoStream.Position = 0
adoStream.Type = 1 'adTypeBinary
GB2312ToUTF8 = adoStream.Read()
adoStream.Close
If ReturnValueType = vbString Then GB2312ToUTF8 = Mid(GB2312ToUTF8, 1)
End Function
'- ------------------------------------------- -
' 函数说明:UTF8转换为GB2312
'- ------------------------------------------- -
Public Function UTF8ToGB2312(ByVal varIn As Variant) As String
Dim bytesData() As Byte
Dim adoStream As Object
bytesData = varIn
Set adoStream = CreateObject("ADODB.Stream")
adoStream.Charset = "utf-8"
adoStream.Type = 1 'adTypeBinary
adoStream.Open
adoStream.Write bytesData
adoStream.Position = 0
adoStream.Type = 2 'adTypeText
UTF8ToGB2312 = adoStream.ReadText()
adoStream.Close
End Function
网址汉字加密
Function encodeURIByHtml(strText) 'URL加密
With CreateObject("htmlfile")
.Write "<html><script></script></html>"
encodeURIByHtml = CallByName(.parentwindow, "encodeURIComponent", VbMethod, strText)
End With
End Function
Function EnCodeByHTML(strText) 'HTML字符实体
With CreateObject("htmlfile")
.Write strText
EnCodeByHTML = .body.innerText
End With
End Function
//url转换gb2312
Function UrlEncode(ByVal urlText As String) As String
Dim i As Long
Dim ansi() As Byte
Dim ascii As Integer
Dim encText As String
ansi = StrConv(urlText, vbFromUnicode)
encText = ""
For i = 0 To UBound(ansi)
ascii = ansi(i)
Select Case ascii
Case 48 To 57, 65 To 90, 97 To 122
encText = encText & Chr(ascii)
Case 32
encText = encText & "+"
Case Else
If ascii < 16 Then
encText = encText & "%0" & Hex(ascii)
Else
encText = encText & "%" & Hex(ascii)
End If
End Select
Next i
UrlEncode = encText
End Function
Function GBKEnCode(strText)
Dim i, s
For i = 1 To Len(strText)
s = Hex(Asc(Mid(strText, i, 1)))
If Len(s) = 4 Then s = Left(s, 2) & "%" & Right(s, 2)
GBKEnCode = GBKEnCode & "%" & s
Next
End Function
表格中读取图片,插入图片,跨工作簿读写
Sub main()
Dim sht1 As Worksheet, sht2 As Worksheet, wb As Workbook, sFilePath As String, r As Integer
Application.DisplayAlerts = False
'提取指定行的图片,这里示例为2
r = 2
Set sht1 = ThisWorkbook.Worksheets(1)
sFilePath = ThisWorkbook.Path & "\表4.xlsx"
Set wb = GetObject(sFilePath)
Set sht2 = wb.Worksheets(1)
For Each shp In sht1.Shapes
If shp.TopLeftCell.Address = sht1.Cells(r, 3).Address Then
Call SaveAsPicture(shp)
Call Insertpic(sht2, ThisWorkbook.Path & "\Picture1.jpg", r, shp)
Exit For
End If
Next
Windows(wb.Name).Visible = True
wb.Save
wb.Close
Set sht1 = Nothing
Set sht2 = Nothing
Set wb = Nothing
Application.DisplayAlerts = True
End Sub
Sub SaveAsPicture(pic)
Dim ChtObj As ChartObject
With pic
.Select
Set ChtObj = ActiveSheet.ChartObjects.Add(0, 0, .Width, .Height)
.Copy
End With
With ChtObj
.Border.LineStyle = 0
.Select
ActiveChart.Paste
.Chart.Export ThisWorkbook.Path & "\Picture1.jpg", "jpg"
.Delete
End With
End Sub
Sub Insertpic(sht, picPath, r, shp)
Dim rg As Range
sht.Rows(r).RowHeight = shp.Height
Set rg = sht.Cells(r, 3)
sht.Shapes.AddPicture picPath, True, True, rg.Left, rg.Top, rg.Width, rg.Height
End Sub