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
表格中讀取圖片，插入圖片，跨工作簿讀寫
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