VBA获取泰克示波器图片，并保存在电脑和插入Excel

Public Sub ocs_read_pic()

'功能：读取示波器波形
'需要输入的参数：
'strPath_wjj---波形存放路径
'read_ch---读值的通道
'read_type---读值的类型
'
'    Call defined_BL

    Dim byteData() As Byte
    Dim wfm() As Byte
    Dim screen As String
    Dim tem As String
    Dim status As Integer
    Dim ocsno As String


  Dim stracq, dorecordl, DoCommand, strrl, time, dateofcos, row, column As String
  Set AppSheet = ActiveSheet
  Set rm = New VisaComLib.ResourceManager
  idos = "TCPIP0::" & Sheets("示波器地址").Cells(1, 2) & "::inst0::INSTR" 'OSC address
  Set fmio.IO = rm.Open(idos)
  fmio.IO.Timeout = 2000 '延时
  fmio.IO.Clear

    fmio.IO.Timeout = 10000 '因为图像数据量较大, 所以我们增加IO口的超时时间

    fmio.WriteString "DISplay:CLOCk OFF"
    fmio.WriteString "SAVe:IMAGe:FILEFormat PNG" '设置获取波形的格式，PNG格式波形最小
    fmio.WriteString "SAVe:IMAGe:INKSaver OFF" '将波形变成黑底
    fmio.WriteString "HARDCopy STARt"  '送入获取图像数据的指令

    Sleep 100 '添加Delay时间，让示波器多点时间传输，防止卡死

    Do
        byteData = fmio.IO.Read(20480)  '一次从VISA.Read()中读取1024 * 20个字节,Python中也是这样读取的(此处模仿Python编写)
        status = fmio.IO.ReadSTB  '判断VISA返回的状态
        tem = byteData '将Byte Array数据直接转换成String，方便将读取的数据连接；###注意，只有动态的Byte()才能这样赋值
        screen = screen & tem  '将转换后的String拼接
    Loop While status <> 0

    wfm = screen '将拼接完成的String转换成Byte()，方便存入到波形

    fmio.WriteString ":USBTMC:SERIAL?"
    zifu = fmio.ReadString()
'    ocsno = Left(fmio.ReadString(), 7)
    For i = 1 To Len(zifu)
     If IsNumeric(Mid(zifu, i, 1)) Then
        ocsno = Mid(zifu, i - 1, 7)

        Exit For
     End If
    Next


    Dim strPath As String

    strPath = Sheets("示波器地址").Range("b2").Value '波形保存路径

    If Dir(strPath, vbDirectory) = "" Then             '查找是否有此盘符，没有则退出宏
        MsgBox "未找到目录【" & strPath & "】，请检查!", vbCritical, ""
        Exit Sub
    Else
        strFile = Format(Now, "YYYYMMDD HHMMSS") & ".png"
        
        '将波形存到电脑
        Close #1 ' If #1 is open, close it.
        Open strPath & strFile For Binary Lock Read Write As #1
        Put #1, , wfm ' Write data. 写入之前获取的二进制图像数据
        Close #1 ' Close file. 关闭

        '将波形插入选中单元格
        Set rgInsert = Cells(pic_row, pic_col).MergeArea
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, rgInsert.Left + 2, rgInsert.Top + 2, rgInsert.Width - 4, rgInsert.Height - 4).Select
        Selection.ShapeRange.Fill.UserPicture strPath & strFile

    End If
    


End Sub

持续更新中... ...                    点个关注和收藏哦

Labview、Python、VBA、C、Excel公式、PCB Layout、PIC单片机、Visual Studio(ASP.NET)、SQL Server ，欢迎沟通讨论
部分文档为做项目过程中的源代码，可能没有注释，有疑问欢迎私信沟通

#电子爱好者       #电子专业       #熟悉开关电源原理和测试       #从事硬件自动测试开发