邮件称重拍照记录工具
Posted 宋哥
tags:
篇首语:本文由小常识网(cha138.com)小编为大家整理,主要介绍了邮件称重拍照记录工具相关的知识,希望对你有一定的参考价值。
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
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, _
ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileInt Lib "kernel32" Alias _
"GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, _
ByVal nDefault 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-20160706"
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 Wei0, Wei1, Wei2 As Integer
LabNumber.Caption = ""
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)
Wei0 = Wei2 - Wei1
xlSheet.Cells(Maxrow, 3) = TxtWeight.Text
xlSheet.Cells(Maxrow, 6) = Wei0
Else
'保存一条记录
If ChkWeight.Value = Checked Then
Wei1 = MailWeight(EmsCode)
Else
Wei1 = 0 '网站不通时可以去掉这个勾选,便不访问网站了,此功能不外露
End If
Wei2 = CInt(TxtWeight.Text)
Wei0 = Wei2 - Wei1
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) = Wei0
'拍摄图片,参见装载语句: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"
PicDir = "Pic" & Format(CurDate, "yyyymmdd") & "\\" '增加图片链接
xlSheet.Hyperlinks.Add Anchor:=Cells(Maxrow, 2), Address:=PicDir & EmsCode & ".jpg"
Else
MsgBox "摄像头无效,请检查!", vbOKOnly, "iamlaosong"
End If
'输入框初始化
TxtCode.Text = ""
Total = Total + 1
End If
If Wei0 > 5 Then
LabNumber.ForeColor = &HFF
ElseIf Wei0 < -5 Then
LabNumber.ForeColor = &HFF0000
Else
LabNumber.ForeColor = 0
End If
LabNumber.Caption = Total & " " & EmsCode & Chr(13) & TxtWeight.Text & Chr(13) & "误差:" & Wei0
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.ForeColor = 0
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
On Error GoTo CmdCheckErr
'是否正在采集重量
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
CmdCheckErr:
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
'写参数:WritePrivateProfileString "Setting", KeyName, GetStr, App.Path & "\\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
On Error GoTo MailWeightErr
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 Until WebBrowser1.ReadyState = 4
DoEvents
Loop
Do
Str = WebBrowser1.Document.ParentWindow.Frames("maincontext").Document.All(0).innertext
i1 = InStr(Str, "重量:")
DoEvents
If Timer > tim1 + 20 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
Exit Function
MailWeightErr:
Err.Clear
Resume Next
End Function
以上是关于邮件称重拍照记录工具的主要内容,如果未能解决你的问题,请参考以下文章