📄 frmhtm2db.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "Comdlg32.ocx"
Begin VB.Form FrmHtm2DB
Caption = "医保网页数据转换"
ClientHeight = 7245
ClientLeft = 60
ClientTop = 345
ClientWidth = 10800
Icon = "FrmHtm2DB.frx":0000
LinkTopic = "Form2"
ScaleHeight = 7245
ScaleWidth = 10800
StartUpPosition = 3 '窗口缺省
Begin VB.Frame Frame5
Height = 3255
Left = 240
TabIndex = 11
Top = 120
Width = 10095
Begin VB.TextBox TxtFile
Height = 2775
Left = 120
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 12
Top = 240
Width = 9735
End
End
Begin VB.Frame Frame4
Height = 855
Left = 8520
TabIndex = 9
Top = 5880
Width = 1815
Begin VB.CommandButton Command2
Caption = "退 出"
Height = 495
Left = 240
TabIndex = 10
Top = 240
Width = 1335
End
End
Begin VB.Frame Frame3
Height = 3375
Left = 240
TabIndex = 5
Top = 3360
Width = 7935
Begin VB.DriveListBox Drive1
Height = 300
Left = 240
TabIndex = 8
Top = 240
Width = 3495
End
Begin VB.DirListBox Dir1
Height = 2610
Left = 240
TabIndex = 7
Top = 600
Width = 3495
End
Begin VB.FileListBox File1
Height = 2970
Left = 3960
Pattern = "*.htm"
TabIndex = 6
Top = 240
Width = 3735
End
End
Begin VB.Frame Frame2
Height = 975
Left = 8520
TabIndex = 3
Top = 3360
Width = 1815
Begin VB.CommandButton Command1
Caption = "连续批量转换"
Height = 495
Left = 240
TabIndex = 4
Top = 240
Width = 1335
End
End
Begin VB.Frame Frame1
Height = 1575
Left = 8520
TabIndex = 0
Top = 4320
Width = 1815
Begin VB.CommandButton CmdReadCell
Caption = "单网页转换"
Height = 495
Left = 240
TabIndex = 2
Top = 840
Width = 1335
End
Begin VB.CommandButton CmdOpen
Caption = "单网页读取"
Height = 495
Left = 240
TabIndex = 1
Top = 240
Width = 1335
End
End
Begin MSComDlg.CommonDialog ComDlg
Left = 240
Top = 6360
_ExtentX = 847
_ExtentY = 847
_Version = 393216
Filter = "*.htm|*.htm"
End
End
Attribute VB_Name = "FrmHtm2DB"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim StrFile As String '网页内容
Dim iCols As Integer '总列数
Dim iFileFlag As Integer '文件标志
Dim CnYb As New ADODB.Connection
Dim RsYb As New ADODB.Recordset
Dim strSql As String
Dim FileHead As String
Dim Fname As String
Dim NextLine As String
Private Sub CmdOpen_Click()
' Dim NextLine As String
ComDlg.ShowOpen
Fname = ComDlg.FileName
FileHead = Left(GetFileName(Fname), 6)
If FileHead = "ybjsbb" Then
iFileFlag = 1
CmdReadCell.Enabled = True
ElseIf FileHead = "rkqkfk" Then
iFileFlag = 2
CmdReadCell.Enabled = True
Else
CmdReadCell.Enabled = False
'MsgBox "请检查文件是否是医保数据文件！"
Exit Sub
End If
If Fname <> "" Then
TxtFile.Text = ""
Open Fname For Input As #1
StrFile = ""
Do Until EOF(1)
Line Input #1, NextLine
StrFile = StrFile & NextLine & vbCrLf
Loop
Close #1
TxtFile.Text = StrFile
End If
End Sub
Private Sub CmdReadCell_Click()
Dim AreaPos As Long
Dim strArea As HtmTra
Dim strLine As HtmTra
Dim strcell As HtmTra
Dim lngArea As Long
Dim lngLine As Long
Dim Area As String
Dim PayDate As String
Dim Pdate As String
Dim iNo As Long
If iFileFlag = 1 Then
'////////////////////////////////////////////////////////////////////////
'********************住院费用结算支付明细表************************** //
'**检查项目： //
'** 结算日期 库中已经存在时将不新的文件数据转换 //
'**解析顺序： //
'** 文件－区域－行－单元格 //
'////////////////////////////////////////////////////////////////////////
PayDate = Mid(StrFile, InStr(1, StrFile, "结算日期：") + 5, 10)
Pdate = PayDate
Debug.Print Fname
lngArea = 1
lngLine = 1
' lngCell = 1
iCols = 15
PayDate = ",'" & PayDate & "'"
' strSql = "select [结算日期] from [支付明细表] where [结算日期]=#" & Pdate & "# and [区域]='" & Area & "'"
strSql = "select filename from [支付明细表] where filename='" & Fname & "'"
Set RsYb = CnYb.Execute(strSql)
If Not RsYb.EOF And Not RsYb.BOF Then
' MsgBox "住院费用结算支付明细表中［" & Pdate & "］日,［" & Area & "］ 数据已经存在！"
Set RsYb = Nothing
Else
Do While InStr(lngArea, StrFile, ">参保人报销地区：") <> 0
strArea = ReadArea(StrFile, lngArea) '读取区域块
Area = Mid(strArea.strChar, 10, 3)
iNo = 1
lngLine = 1
Do While InStr(lngLine, strArea.strChar, "<td>" & iNo & "</td>") <> 0
strLine = ReadLine(strArea.strChar, iNo, lngLine)
strcell = ReadCell(strLine.strChar, iCols, 1)
strSql = "INSERT INTO 支付明细表 ( 区域,序号,交易类别,医疗类别, 流水号, 姓名, [卡号/手册号], 参保人员类别, 交易日期, 申报费用总金额, 统筹支付, 住院大额支付, 公务员补助支付, 支付金额小计, 个人账户支付金额, 拒付金额小计,结算日期,filename )" _
& " VALUES ('" & Area & "'" & strcell.strChar & PayDate & ",'" & Fname & "')"
'Debug.Print strSql
CnYb.Execute strSql
iNo = iNo + 1
lngLine = strLine.lngPos
Loop
lngArea = strArea.lngPos
Loop
End If
'*******************************************************************************************
ElseIf iFileFlag = 2 Then
'////////////////////////////////////////////////////////////////////////
'********************上传数据入库情况反馈表************************** //
'**检查项目： //
'** 打包日期 库中已经存在时将不新的文件数据转换 //
'**解析顺序： //
'** 文件－区域－行－单元格 //
'////////////////////////////////////////////////////////////////////////
PayDate = Mid(StrFile, InStr(1, StrFile, "打包日期：") + 5, 10)
Pdate = PayDate
Debug.Print Fname
lngArea = 1
lngLine = 1
' lngCell = 1
iCols = 8
PayDate = ",'" & PayDate & "'"
'\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
'strSql = "select [打包日期] from [反馈表] where [打包日期]=#" & Pdate & "# and [区域]='" & Area & "'"
strSql = "select filename from [反馈表] where filename='" & Fname & "'"
' Debug.Print strSql
Set RsYb = CnYb.Execute(strSql)
If Not RsYb.EOF And Not RsYb.BOF Then
' MsgBox "上传数据入库情况反馈表中［" & Pdate & "］日,［" & Area & "］ 数据已经存在！"
Set RsYb = Nothing
Else
Do While InStr(lngArea, StrFile, ">参保人报销地区：") <> 0
strArea = ReadArea(StrFile, lngArea) '读取区域块
Area = Mid(strArea.strChar, 10, 3)
iNo = 1
lngLine = 1
Do While InStr(lngLine, strArea.strChar, "<td>" & iNo & "</td>") <> 0
strLine = ReadLine(strArea.strChar, iNo, lngLine)
strcell = ReadCell(strLine.strChar, iCols, 1)
strSql = "INSERT INTO 反馈表 ( 区域, 序号, 类别, 交易流水号, 姓名, [卡号/手册号], 费用总金额, 入库情况, 拒付原因, 打包日期,filename )" _
& " VALUES ('" & Area & "'" & strcell.strChar & PayDate & ",'" & Fname & "')"
'Debug.Print strSql
CnYb.Execute strSql
iNo = iNo + 1
lngLine = strLine.lngPos
Loop
lngArea = strArea.lngPos
Loop
'*******************************************************************************************
End If
End If
' MsgBox "数据转换完毕!"
TxtFile = ""
End Sub
Private Sub Command1_Click()
Dim iFileN As Integer
For iFileN = 0 To File1.ListCount - 1
File1.Selected(iFileN) = True
'MsgBox File1.FileName
'CmdOpen_Click
Fname = File1.FileName
'FileHead = Left(GetFileName(Fname), 6)
FileHead = Left(Fname, 6)
If FileHead = "ybjsbb" Then
iFileFlag = 1
CmdReadCell.Enabled = True
ElseIf FileHead = "rkqkfk" Then
iFileFlag = 2
CmdReadCell.Enabled = True
Else
CmdReadCell.Enabled = False
' MsgBox "请检查文件是否是医保数据文件！"
iFileFlag = 0
End If
If iFileFlag <> 0 Then
If Fname <> "" Then
TxtFile.Text = ""
' MsgBox Dir1.Path
Open Dir1.Path & "\" & Fname For Input As #1
StrFile = ""
Do Until EOF(1)
Line Input #1, NextLine
StrFile = StrFile & NextLine & vbCrLf
Loop
Close #1
TxtFile.Text = StrFile
End If
CmdReadCell_Click
End If
Next
MsgBox "本目录下数据转换完成！"
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Form_Load()
CnYb.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" _
& App.Path & "\医保数据.mdb;Persist Security Info=False;Jet OLEDB:Database Password=gold"
CnYb.CursorLocation = adUseServer
'CnYb.CursorLocation = adUseClient
CnYb.ConnectionTimeout = 30
CnYb.Open strSql
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -