?? 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 + -