邮件称重拍照记录工具

标签：

iamlaosong文

做了一个邮件重量稽核工具，即在集散中心随机抽取一定量的邮件，进行重量复核并记录在案。工具本身没什么新技术，但用到的技术比较多，如Excel文件操作、INI文件的读取、串口通信、拍照、图像格式转换、网页抓取等。工具操作很简单，将邮件放到电子秤上，用扫描枪扫描条码后，计算机完成抓取实际重量、抓取收寄重量（根据邮件号码上网站抓取）、拍照（摄像头对准邮件和电子秤）、保存为JPG格式、数据保存到Excel文件、显示本邮件的重量误差等一系列工作，然后换上新邮件重复上面的工作。工具界面如下：

上面说的是主要功能，还有些辅助功能，如取重测试、拍照测试、重量比较（就是批量到网站抓取邮件收寄重量）等。正常工作时界面如下：

下面是工具的完整代码：

'读取INI文件的API
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long

'拍照必需的API
Private Declare Function capCreateCaptureWindow Lib "avicap32.dll" Alias _
"capCreateCaptureWindowA" (ByVal lpszWindowName As String, ByVal dwStyle As Long, _
ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, _
ByVal hWndParent As Long, ByVal nID As Long) As Long

Private Const WS_CHILD = &H40000000
Private Const WS_VISIBLE = &H10000000
Private Const WM_USER = &H400
Private Const WM_CAP_START = &H400
Private Const WM_CAP_EDIT_COPY = (WM_CAP_START + 30)
Private Const WM_CAP_DRIVER_CONNECT = (WM_CAP_START + 10)
Private Const WM_CAP_SET_PREVIEWRATE = (WM_CAP_START + 52)
Private Const WM_CAP_SET_OVERLAY = (WM_CAP_START + 51)
Private Const WM_CAP_SET_PREVIEW = (WM_CAP_START + 50)
Private Const WM_CAP_DRIVER_DISCONNECT = (WM_CAP_START + 11)
Private Preview_Handle As Long

Private Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, lParam As Any) As Long
'===========================end

'用GDI+保存图片为JPG、TIFF、PNG、GIF、BMP等格式的API
Private Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type
Private Type GdiplusStartupInput
    GdiplusVersion As Long
    DebugEventCallback As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs As Long
End Type
Private Type EncoderParameter
    GUID As GUID
    NumberOfValues As Long
    type As Long
    Value As Long
End Type
Private Type EncoderParameters
    count As Long
    Parameter As EncoderParameter
End Type

Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, BITMAP As Long) As Long
Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal FileName As Long, clsidEncoder As GUID, encoderParams As Any) As Long
Private Declare Function CLSIDFromString Lib "ole32" (ByVal Str As Long, id As GUID) As Long
Private Declare Function CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Dest As Any, Src As Any, ByVal cb As Long) As Long
'===========================end

'公共变量
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet

Dim modFile, datPath, datFile, datFullName, SerialPort, picPath, OperateMode, TimeOut, TrackUrl As String
Dim Maxrow, Total As Integer
Dim CurDate As Date
'作为函数的参数变量要单独定义
Dim EmsCode As String


'拍摄图片测试
Private Sub CmdPicTest_Click()
    '拍摄图片
    Image1.Picture = CapturePicture(Preview_Handle)
    '保存图片
    If Image1.Picture <> 0 Then
        SavePicture Image1.Picture, App.Path & "\PicTest.bmp"
    Else
        MsgBox "摄像头无效，请检查！", vbOKOnly, "iamlaosong"
    End If
    SavePic Image1.Picture, App.Path & "\PicTest.jpg", ".jpg"

End Sub


'初始化
Private Sub Form_Load()
    '界面初始化，显示版本信息
    Form1.Caption = Form1.Caption & "--邮政速递安徽省分公司 Ver: iamlaosong-20160628"
    CurDate = Date
    LabNumber.Caption = CurDate
    '读取参数
    modFile = GetIniStr("Modfile", "重量记录模板.xls")
    datPath = GetIniStr("Datpath", App.Path)           '数据保存路径
    TimeOut = GetIniStr("TimeOut", "0")                  '串口通信超时，0表示不设置超时
    If Dir(datPath, vbDirectory) = vbNullString Then
        MkDir datPath   '创建文件夹
    End If
    If Right(datPath, 1) <> "\" Then datPath = datPath & "\"
    
    TrackUrl = GetIniStr("Http", "http://10.3.10.83/ems/")
    WebBrowser1.Visible = True
    WebBrowser1.Navigate TrackUrl
    
    SerialPort = GetIniStr("Device", "COM1")
    OperateMode = GetIniStr("Mode", "1")
    '设置串口
    SetComm
    '摄像头初始化
    SetViedo
End Sub

'日期调整
Private Sub CmdDate_Click(Index As Integer)
    If Index = 0 Then
        CurDate = CurDate + 1
    Else
        CurDate = CurDate - 1
    End If
    LabNumber.Caption = CurDate
End Sub

'开始扫描称重，如当天的记录文件存在，则继续添加
Private Sub CmdBegin_Click()

    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    '检查记录文件
    datFile = Format(CurDate, "yyyymmdd") & modFile
    datFullName = datPath & datFile
    If Dir(datFullName, vbNormal) = vbNullString Then
        FileCopy App.Path & "\" & modFile, datFullName    ' 将源文件的内容复制到目的文件中。
    End If
    '检查图像目录
    picPath = datPath & "Pic" & Format(CurDate, "yyyymmdd")
    If Dir(picPath, vbDirectory) = vbNullString Then
        MkDir picPath   '创建文件夹
    End If
   
    
    '打开记录文件
    Set xlBook = xlApp.Workbooks.Open(datFullName)         '打开文件
    'xlApp.Visible = True '设置EXCEL对象可见（或不可见）
    'Set xlSheet = xlBook.Worksheets("表名") '设置活动工作表
    Total = 0
    Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
    Maxrow = xlSheet.Cells(65536, 2).End(xlUp).Row
    If xlBook.ReadOnly = True Then
        xlBook.Close
        xlApp.Quit '结束EXCEL对象
        Set xlApp = Nothing '释放xlApp对象
        MsgBox "文件<" & datFile & ">已打开，请先关闭！", vbOKOnly, "iamlaosong"
    Else
    
        '打开串口
        MSComm1.InBufferCount = 0              '清除接收缓冲区
        If Not MSComm1.PortOpen Then
          MSComm1.PortOpen = True              '打开通信端口
        End If
        '打开输入框
        TxtCode.Enabled = True
        TxtWeight.Enabled = True
        CmdDate(0).Visible = False
        CmdDate(1).Visible = False
        
        TxtCode.Text = ""
        TxtWeight.Text = ""
        CmdEnd.Enabled = True
        LabState.Caption = "邮件记录："
        LabNumber.FontSize = LabState.FontSize + 2
        LabNumber.Caption = Total
        
        TxtCode.SetFocus
    End If
    
End Sub


'退出（按回车）重量文本框记录一条邮件信息
Private Sub TxtCode_KeyPress(KeyAscii As Integer)
    Dim Err As Boolean
    
    If KeyAscii = 13 Then
        EmsCode = TxtCode.Text
        If ChkCode.Value = Checked Then
            '判断号码是否规范
            If Len(EmsCode) = 13 Then
                Err = Not ChkMailCode(EmsCode)    '检查邮件号码是否正常（正常时返回True）
            Else
                Err = True
            End If
            If Err Then
                MsgBox "经校验，邮件号码有误！", vbOKOnly, "iamlaosong"
            Else
                Err = ChkMailDuplicate(EmsCode)
                If Err Then
                    MsgBox "经检查，邮件号码重复！", vbOKOnly, "iamlaosong"
                    TxtCode.SelStart = 0
                    TxtCode.SelLength = Len(TxtCode.Text)
                    TxtCode.SetFocus
                    Exit Sub
                End If
            End If
            If Err Then
                TxtCode.SelStart = 0
                TxtCode.SelLength = Len(TxtCode.Text)
                TxtCode.SetFocus
                Exit Sub
            End If
        End If
        If OperateMode = "1" Then
            CmdGetweight_Click
        Else
            TxtWeight.Text = ""
            CmdGetweight.SetFocus
        End If
    End If
End Sub

'退出（按回车）重量文本框记录一条邮件信息----用于手工录入重量
Private Sub TxtWeight_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        '保存一条记录
        Maxrow = Maxrow + 1
        xlSheet.Cells(Maxrow, 1) = Total
        xlSheet.Cells(Maxrow, 2) = TxtCode.Text
        xlSheet.Cells(Maxrow, 3) = TxtWeight.Text
        xlSheet.Cells(Maxrow, 4) = Now
        
        '输入框初始化
        TxtCode.Text = ""
        TxtWeight.Text = ""
        Total = Total + 1
        LabNumber.Caption = Total
        TxtCode.SetFocus
    End If
End Sub

'读取重量文本框记录一条邮件信息或者修改邮件信息
Private Sub CmdGetweight_Click()
    Dim Wei1, Wei2 As Integer
    
    TxtWeight.Text = GetWeight
    If TxtWeight.Text = "ComErr" Then
        MsgBox "电子秤通信有误，请检查！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    '如果已经开始，保存数据
    If CmdEnd.Enabled = True Then
        If Len(TxtCode.Text) = 0 Then
            '修正重量
            Wei1 = xlSheet.Cells(Maxrow, 5)
            Wei2 = CInt(TxtWeight.Text)
            xlSheet.Cells(Maxrow, 3) = TxtWeight.Text
            xlSheet.Cells(Maxrow, 6) = Wei2 - Wei1
        Else
            '保存一条记录
            If ChkWeight.Value = Checked Then
                Wei1 = MailWeight(EmsCode)
            Else
                Wei1 = 0                '网站不通时可以去掉这个勾选，便不访问网站了，此功能不外露
            End If
            Wei2 = CInt(TxtWeight.Text)

            Maxrow = Maxrow + 1
            xlSheet.Cells(Maxrow, 1) = Total
            xlSheet.Cells(Maxrow, 2) = TxtCode.Text
            xlSheet.Cells(Maxrow, 3) = Wei2
            xlSheet.Cells(Maxrow, 4) = Now
            xlSheet.Cells(Maxrow, 5) = Wei1
            xlSheet.Cells(Maxrow, 6) = Wei2 - Wei1
            
            '拍摄图片，参见装载语句：Image1.Picture =  LoadPicture("c:\hello.bmp")
            Image1.Picture = CapturePicture(Preview_Handle)
            '保存图片
            If Image1.Picture <> 0 Then
                'SavePicture Image1.Picture, picPath & "\" & EmsCode & ".bmp"
                SavePic Image1.Picture, picPath & "\" & EmsCode & ".jpg", ".jpg"

            Else
                MsgBox "摄像头无效，请检查！", vbOKOnly, "iamlaosong"
            End If
            '输入框初始化
            TxtCode.Text = ""
            Total = Total + 1
        End If
        LabNumber.Caption = Total & " " & EmsCode & Chr(13) & TxtWeight.Text & Chr(13) & "误差：" & Wei2 - Wei1
        TxtCode.SetFocus
    End If
End Sub

'结束记录，保存文件
Private Sub CmdEnd_Click()
    '关闭输入框
    TxtCode.Enabled = False
    TxtWeight.Enabled = False
    CmdEnd.Enabled = False
    '保存文件
    xlBook.Save
    xlBook.Close
    
    xlApp.Quit '结束EXCEL对象
    Set xlApp = Nothing '释放xlApp对象
    LabState.Caption = "保存文件："
    LabNumber.FontSize = LabState.FontSize
    LabNumber.Caption = datFullName

    If MSComm1.PortOpen Then
        MSComm1.PortOpen = False              '关闭通信端口
    End If
    MsgBox Total & "条数据保存，总数量：" & Maxrow - 1, vbOKOnly, "iamlaosong"

End Sub

'重量稽核：连接数据库查询重量并比较。
Private Sub CmdCheck_Click()
    Dim cnn, rst, cmd As Object
    Dim sqls As String
    Dim emsid As String

    '是否正在采集重量
    If CmdEnd.Enabled = True Then
        MsgBox "请点击<结束>按钮保存数据！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    
    '检查数据文件是否存在
    datFile = Format(CurDate, "yyyymmdd") & modFile
    datFullName = datPath & datFile
    If Dir(datFullName, vbNormal) = vbNullString Then
        MsgBox datFile & "文件不存在！", vbOKOnly, "iamlaosong"
        Exit Sub
    End If
    
    '打开记录文件
    sqls = "Open datFile"
    Set xlApp = CreateObject("Excel.Application") '创建EXCEL对象
    Set xlBook = xlApp.Workbooks.Open(datFullName)         '打开文件
    Set xlSheet = xlBook.Worksheets(1) '设置活动工作表
    Maxrow = xlSheet.Cells(65536, 2).End(xlUp).Row
    If xlBook.ReadOnly = True Then
        xlBook.Close
        xlApp.Quit '结束EXCEL对象
        Set xlApp = Nothing '释放xlApp对象
        MsgBox "文件<" & datFile & ">已打开，请先关闭！", vbOKOnly, "iamlaosong"
        Exit Sub
    Else
        pos_sav = 5
        xlSheet.Cells(1, pos_sav + 0) = "收寄重量"
        xlSheet.Cells(1, pos_sav + 1) = "重量差额"
        
        ' 开始处理
        For row1 = 2 To Maxrow
            emsid = Trim(xlSheet.Cells(row1, 2))   '邮件号码
            emsw1 = Trim(xlSheet.Cells(row1, 3))   '邮件重量
            If Not IsNumeric(emsw1) Then emsw1 = 0
            
            '当日业务量、收入
           emsw2 = MailWeight(emsid)
           xlSheet.Cells(row1, pos_sav + 0) = emsw2
           xlSheet.Cells(row1, pos_sav + 1) = emsw1 - emsw2
         
           TxtCode.Text = "已完成：" & CStr(Round(row1 * 100 / Maxrow, 2)) & "%"
            'DoEvents

        Next row1
        
        '保存文件
        xlBook.Save
        xlBook.Close
        xlApp.Quit '结束EXCEL对象
        Set xlApp = Nothing '释放xlApp对象
   
    End If
    
    MsgBox "重量稽核完毕，邮件数量：" & Maxrow - 1, vbOKOnly, "iamlaosong"
    Exit Sub
Err:
    MsgBox "错误#" & Str(Err.Number) & Err.Description & "-位置： " & sqls, vbOKOnly + vbExclamation, "iamlaosong"
    Err.Clear
    Resume Next
End Sub

'关闭窗体
Private Sub CmdQuit_Click()
    If CmdEnd.Enabled = True Then
        MsgBox "请点击<结束>按钮保存数据！", vbOKOnly, "iamlaosong"
    Else
        If MSComm1.PortOpen Then
            MSComm1.PortOpen = False              '关闭通信端口
        End If
        '断开摄像头
        SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
        Unload Me
    End If
End Sub

'除了让controlbox=false外，这个也可以让点击"关闭"没反应...
'Private Sub Form_Unload(Cancel As Integer)
    '断开摄像头
'    SendMessage Preview_Handle, WM_CAP_DRIVER_DISCONNECT, 0, 0
'End Sub

'拍照的自定义函数
Public Function CapturePicture(nCaptureHandle As Long) As StdPicture
    Clipboard.Clear
    SendMessage nCaptureHandle, WM_CAP_EDIT_COPY, 0, 0
    Set CapturePicture = Clipboard.GetData
End Function

'链接摄像头
Public Sub SetViedo()

    Preview_Handle = capCreateCaptureWindow("Video", WS_CHILD + WS_VISIBLE, 350, 10, 640, 480, Me.hwnd, 1)
    SendMessage Preview_Handle, WM_CAP_DRIVER_CONNECT, 0, 0
    SendMessage Preview_Handle, WM_CAP_SET_PREVIEWRATE, 1, 0
    SendMessage Preview_Handle, WM_CAP_SET_PREVIEW, 1, 0
    
End Sub

'设置通信参数.Setting="BBBB,P,D,S"含义是：B：Baud Rate（波特率）；P：Parity（奇偶）；D：Data Bit；S：Stop Bit）
Public Sub SetComm()
    With MSComm1
      .CommPort = SerialPort          '设置通信端口
      .Settings = "2400,N,8,1"        '设置通信端口参数 2400赫兹、无校验、8个数据位、1个停止位.
      .InBufferSize = 40              '设置缓冲区接收数据为40字节
      .InputLen = 1                   '设置Input一次从接收缓冲读取字节数为1
      .RThreshold = 1                 '设置接收一个字节就产生OnComm事件
      
      .InputMode = comInputModeText   '设置数据接收模式为二进制形式comInputModeBinary、文本模式comInputModeText
      .InBufferCount = 0              '清除接收缓冲区
      If Not .PortOpen Then
        .PortOpen = True              '打开通信端口
      End If
    End With

End Sub

'按指定格式保存图片
Private Sub SavePic(ByVal pict As StdPicture, ByVal FileName As String, PicType As String, _
                    Optional ByVal Quality As Byte = 80, _
                    Optional ByVal TIFF_ColorDepth As Long = 24, _
                    Optional ByVal TIFF_Compression As Long = 6)
   Screen.MousePointer = vbHourglass
   Dim tSI As GdiplusStartupInput
   Dim lRes As Long
   Dim lGDIP As Long
   Dim lBitmap As Long
   Dim aEncParams() As Byte
   On Error GoTo ErrHandle:
   tSI.GdiplusVersion = 1   ' 初始化 GDI+
   lRes = GdiplusStartup(lGDIP, tSI)
   If lRes = 0 Then     ' 从句柄创建 GDI+ 图像
      lRes = GdipCreateBitmapFromHBITMAP(pict.Handle, 0, lBitmap)
      If lRes = 0 Then
         Dim tJpgEncoder As GUID
         Dim tParams As EncoderParameters    '初始化解码器的GUID标识
         Select Case PicType
         Case ".jpg"
            CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
            tParams.count = 1                               ' 设置解码器参数
            With tParams.Parameter ' Quality
               CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID    ' 得到Quality参数的GUID标识
               .NumberOfValues = 1
               .type = 4
               .Value = VarPtr(Quality)
            End With
            ReDim aEncParams(1 To Len(tParams))
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
        Case ".png"
             CLSIDFromString StrPtr("{557CF406-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".gif"
             CLSIDFromString StrPtr("{557CF402-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             ReDim aEncParams(1 To Len(tParams))
        Case ".tiff"
             CLSIDFromString StrPtr("{557CF405-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
             tParams.count = 2
             ReDim aEncParams(1 To Len(tParams) + Len(tParams.Parameter))
             With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{E09D739D-CCD4-44EE-8EBA-3FBF8BE4FC58}"), .GUID    ' 得到ColorDepth参数的GUID标识
                .Value = VarPtr(TIFF_Compression)
            End With
            Call CopyMemory(aEncParams(1), tParams, Len(tParams))
            With tParams.Parameter
                .NumberOfValues = 1
                .type = 4
                 CLSIDFromString StrPtr("{66087055-AD66-4C7C-9A18-38A2310B8337}"), .GUID    ' 得到Compression参数的GUID标识
                .Value = VarPtr(TIFF_ColorDepth)
            End With
            Call CopyMemory(aEncParams(Len(tParams) + 1), tParams.Parameter, Len(tParams.Parameter))
        Case ".bmp"                                               '可以提前写保存为BMP的代码，因为并没有用GDI+
            SavePicture pict, FileName
            Screen.MousePointer = vbDefault
            Exit Sub
        End Select
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(FileName), tJpgEncoder, aEncParams(1))           '保存图像
         GdipDisposeImage lBitmap       ' 销毁GDI+图像
      End If
      GdiplusShutdown lGDIP              '销毁 GDI+
   End If
   Screen.MousePointer = vbDefault
   Erase aEncParams
   Exit Sub
ErrHandle:
    Screen.MousePointer = vbDefault
    MsgBox "在保存图片的过程中发生错误:" & vbCrLf & vbCrLf & "错误号:  " & Err.Number & vbCrLf & "错误描述:  " & Err.Description, vbInformation Or vbOKOnly, "错误"
End Sub

'======================================================
' Function
'======================================================
'首先接好通讯连续线，开机使秤进入称量状态，然后正常使用。
'当计算机需要重量信号时，计算机首先发送一个“a”字符，作为主机请求信号，秤接到请求信号后，随即发送5个字符的重量信号。
'例如重量为125克，则传送数据为“0”“0”“1”“2”“5”，以ASCⅡ码送出。
Public Function GetWeight() As String
    Dim Tmpstr As String
    Dim IsComNormal As Boolean
    
    time1 = Timer                     'Timer()计时函数时间单位是秒，Time()当前时间函数，单位是天，时间用小数部分表示
    If TimeOut = "0" Then
      time2 = 30
    Else
      time2 = CInt(TimeOut)
    End If
    With MSComm1
      .Output = "a"                   '发送取数命令
      Tmpstr = ""
      IsComNormal = True
      Do
          DoEvents
          If Timer - time1 > time2 Then           'time2秒无反馈，COM口异常
            IsComNormal = False
            Exit Do
          End If
      Loop Until MSComm1.InBufferCount = 5
      If IsComNormal Then
        Do
            Tmpstr = Tmpstr & MSComm1.Input
        Loop Until Len(Tmpstr) = 5
      Else
        If TimeOut <> "0" Then
            Tmpstr = "ComErr"     '罗阳测试发现扫描一次后，不扫描也会包通信错误，暂时屏蔽待查明原因，此错实在是莫名其妙
        End If
      End If
    End With
    GetWeight = Tmpstr
End Function

'读取参数，参数文件config.ini
Public Function GetIniStr(ByVal KeyName As String, ByVal KeyDefault As String) As String
    
    Dim GetStr As String
    
    On Error GoTo GetIniStrErr
    GetStr = String(128, 0)
    GetPrivateProfileString "Setting", KeyName, KeyDefault, GetStr, 128, App.Path & "\config.ini"
      GetStr = VBA.Replace(GetStr, VBA.Chr(0), "")
    If GetStr = "" Then
       GoTo GetIniStrErr
    Else
       GetIniStr = GetStr
       GetStr = ""
    End If
    Exit Function
GetIniStrErr:
       Err.Clear
       GetIniStr = KeyDefault
       GetStr = ""
End Function

'检查邮件号码是否正常（正常时返回True）
Public Function ChkMailCode(MailCode As String) As Boolean
    Dim mm As String
    Dim chk_sum, chk_code As Integer
    
    mm = Mid(MailCode, 3, 8)
    'chk_code = 。。。   这儿计算校验码，算法就不展示了
    
    If chk_code = Mid(MailCode, 11, 1) Then
        ChkMailCode = True     '正常
    Else
        ChkMailCode = False    '异常
    End If
End Function

'检查邮件号码是否重复（重复时返回True）
Public Function ChkMailDuplicate(MailCode As String) As Boolean
    Dim mm As String
    Dim kk As Integer
    
    For kk = 2 To Maxrow
        If xlSheet.Cells(kk, 2) = MailCode Then
            ChkMailDuplicate = True     '重复
            Exit For
        End If
    Next kk
    If kk > Maxrow Then
        ChkMailDuplicate = False        '不重复
    End If
End Function

'从全程跟踪网址取重量
Public Function MailWeight(MailCode As String) As Integer
    Dim Str As String
    Dim i1, i2 As Integer
    
    WebBrowser1.Navigate TrackUrl

    Do Until WebBrowser1.ReadyState = 4
        DoEvents
    Loop
    WebBrowser1.Document.ParentWindow.Frames("maincontext").Document.GetElementById("mailNum").innertext = MailCode
    WebBrowser1.Document.ParentWindow.Frames("maincontext").Document.Forms("mailTrackSnglForm").submit
    
    'For Each i In WebBrowser1.Document.ParentWindow.Frames("maincontext").Document.All
        'Debug.Print i.innertext
    'Next
    tim1 = Timer
    Do
        Str = WebBrowser1.Document.ParentWindow.Frames("maincontext").Document.All(0).innertext
        i1 = InStr(Str, "重量:")
        DoEvents
        If Timer > tim1 + 30 Then Exit Do       '超时退出
    Loop While i1 = 0
    
    If i1 > 0 Then
        i2 = InStr(Str, "实收费用:")
        MailWeight = Mid(Str, i1 + 3, i2 - i1 - 4) * 1000
    Else
        MailWeight = 0                          '超时退出时重量为0
    End If

End Function

邮件称重拍照记录工具

标签：

原文地址：http://blog.csdn.net/iamlaosong/article/details/51828586