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 ""
        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