Attribute VB_Name = "Module1"
'参数说明

' 按键: [F1] [F2] [OK] [ESC] [SCAN] [NET] [TAB] [LEFT] [RIGHT]


'Split(s1, vbCrLf, -1, vbTextCompare)(0)   ==> 按键名称
'Split(s1, vbCrLf, -1, vbTextCompare)(1)   ==> 设备序号
'Split(s1, vbCrLf, -1, vbTextCompare)(2)   ==> 用户代号
'Split(s1, vbCrLf, -1, vbTextCompare)(3)   ==> 窗体编号
'Split(s1, vbCrLf, -1, vbTextCompare)(4)   ==> 目前位置
'Split(s1, vbCrLf, -1, vbTextCompare)(5)   ==> 数值变量1 此变量具特殊用途, 字段移动时会自动清零.
'Split(s1, vbCrLf, -1, vbTextCompare)(6)   ==> 数值变量2
'Split(s1, vbCrLf, -1, vbTextCompare)(7)   ==> 数值变量3
'Split(s1, vbCrLf, -1, vbTextCompare)(8)   ==> 文字变量
'Split(s1, vbCrLf, -1, vbTextCompare)(9)   ==> 第一栏输入内容
'Split(s1, vbCrLf, -1, vbTextCompare)(10)   ==> 第二栏输入内容
'Split(s1, vbCrLf, -1, vbTextCompare)(11)   ==> 第三栏输入内容
'.........
'.........
'.........
'Split(s1, vbCrLf, -1, vbTextCompare)(N)   ==> 第N栏输入内容


'程序执行时没有参数, 将读取call.txt  完成后写入 ret.txt
'程序执行时有参数, 将读取参数名称的文字文件, 完成后写入同一文字文件


Public s1 As String, s2 As String, getname As String, putname As String

Sub Main()
On Error Resume Next
If Command$ = "" Then
    getname = "call.txt"
    putname = "ret.txt"
Else
    getname = Command$
    putname = Command$
End If

s1 = FileGet(getname)

Select Case Split(s1, vbCrLf, -1, vbTextCompare)(0)
    Case "F1"
        f1_rtn
    Case "F2"
        f2_rtn
    Case "OK"
        ok_rtn
    Case "ESC"
        esc_rtn
    Case "SCAN"
        scan_rtn
    Case "NET"
        net_rtn
    Case "TAB"
        tab_rtn
    Case "LEFT"
        left_rtn
    Case "RIGHT"
        right_rtn
    Case Else
        ot_rtn
End Select
Kill putname
FilePut putname, s2
'MsgBox "?????"
End
End Sub

Function ot_rtn()

End Function

Function f1_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
s2 = s2 & "TXT01=" & Split(s1, vbCrLf, -1, vbTextCompare)(0) & "陈陈陈" & vbCrLf
s2 = s2 & "TXT02=." & vbCrLf
s2 = s2 & "TXT04=" & "奥硕普电脑科技" & vbCrLf

End Function

Function f2_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
s2 = s2 & "MSG=" & "你按了[" & Split(s1, vbCrLf, -1, vbTextCompare)(0) & "]按键!" & vbCrLf

s2 = s2 & "FN=" & "2" & vbCrLf

s2 = s2 & "BEEP=" & "-...-" & vbCrLf


End Function

Function ok_rtn()
Dim TM_NO As String, QTY As String, CK_NO As String
On Error Resume Next
s2 = "[Form]" & vbCrLf

CK_NO = Split(s1, vbCrLf, -1, vbTextCompare)(9)

Call DY_RTN(CK_NO)

End Function

Function esc_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
s2 = s2 & "MSG=" & "你按了[" & Split(s1, vbCrLf, -1, vbTextCompare)(0) & "]按键!" & vbCrLf

s2 = s2 & "BEEP=" & ".-" & vbCrLf

End Function


Function scan_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
s2 = s2 & "MSG=" & "你按了[" & Split(s1, vbCrLf, -1, vbTextCompare)(0) & "]按键!" & vbCrLf

s2 = s2 & "BEEP=" & ".-" & vbCrLf

End Function

Function net_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
s2 = s2 & "MSG=" & "你按了[" & Split(s1, vbCrLf, -1, vbTextCompare)(0) & "]按键!" & vbCrLf

s2 = s2 & "BEEP=" & ".-" & vbCrLf

End Function


Function tab_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf
's2 = s2 & "FRM=" & Split(s1, vbCrLf, -1, vbTextCompare)(9) & vbCrLf

s2 = s2 & "SCR01=6,2,陈正成,WHITE,RED" & vbCrLf

s2 = s2 & "SCR02=8,6,奥硕普电脑科技,GREEN,BLUE" & vbCrLf
s2 = s2 & "SCR03=10,6,FORTH,WHITE,BLACK" & vbCrLf
s2 = s2 & "SCR04=12,6,FORTH,RED" & vbCrLf

End Function

Function left_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf

End Function

Function right_rtn()
On Error Resume Next
s2 = "[Form]" & vbCrLf

End Function

'======================以上为公用程序,以下为自写程序
Function DY_RTN(CK_NO As String)       'CK_NO--出库单号
Dim cn As New ADODB.Connection
Dim Rs As New ADODB.Recordset
Dim SQL As String, TM As String
Dim EE As Object

On Error Resume Next

'打开数据库
lj = App.Path
lj = Left(lj, Len(lj) - 4)
cnstr = FileGet(lj & "\ini\database.ini") & vbCrLf & vbCrLf
'cnstr = FileGet(App.Path & "\ini\database.ini") & vbCrLf & vbCrLf   '测试时使用
'lj = App.Path

SS = Split(cnstr, vbCrLf, -1, vbTextCompare)(dbn(index)) & ",,"
TT = "Data Source=" & Split(SS, ",", -1, vbTextCompare)(0) & "; "
If Trim(Split(SS, ",", -1, vbTextCompare)(1)) <> "" Then TT = TT & "UID=" & Split(SS, ",", -1, vbTextCompare)(1) & "; "
If Trim(Split(SS, ",", -1, vbTextCompare)(2)) <> "" Then TT = TT & "PWD=" & Split(SS, ",", -1, vbTextCompare)(2) & ";"
cn.Open TT

'FilePut App.Path & "\new_data.txt", cnstr & SS & TT & vbCrLf
 
If CK_NO & "" = "" Then
    CK_NO = GET_BIG("pur_no", "t_pur_record", "FORMAT(pur_man,'YYMM')='" & Format(Date, "YYMM") & "'")
End If
Rs.Open "SELECT t_pur_record.* FROM t_pur_record WHERE pur_no=" & CK_NO, cn, adOpenDynamic, adLockPessimistic
If Rs.EOF Then
    s2 = s2 & "MSG= 无该单的资料!" & vbCrLf
    s2 = s2 & "BEEP=" & "-...-" & vbCrLf
    Exit Function
End If

STR_FILENA = lj & "\小票" & CK_NO & ".xls"
FileCopy lj & "\MOD_XLS.xls", STR_FILENA
If Err.Number <> 0 Then
    Select Case Err.Number
        Case 70
            'MsgBox STR_FILENA & " 档案已经开启, 请关闭excel 再重新执行.", vbCritical, "提示"
            s2 = s2 & "MSG= 档案已经开启, 请关闭!" & vbCrLf
            s2 = s2 & "BEEP=" & "-...-" & vbCrLf
            Exit Function
        Case Else
        'MsgBox Err.Description, vbCritical, "提示"
    End Select
    'Exit Function
End If
Set EE = CreateObject("Excel.Application")
EE.Visible = False
EE.Workbooks.Open STR_FILENA
'EE.Sheets("Sheet1").Select

i = 5
EE.Range("A" & i) = "出库单号：" & Rs("pur_no")
EE.Range("C" & i) = "打印时间：" & Now()
i = i + 1
EE.Range("A" & i) = "项次"
EE.Range("B" & i) = "料品编号"
EE.Range("C" & i) = "品名"
EE.Range("D" & i) = "重量"
EE.Range("E" & i) = "件数"
TOTAL_Q = 0
TOTAL_W = 0
i2 = 0
Do While Not Rs.EOF
    i = i + 1
    i2 = i2 + 1
    EE.Range("A" & i) = i2
    EE.Range("B" & i) = Rs("mcode")
    EE.Range("C" & i) = Rs("mname1")
    EE.Range("D" & i) = Rs("pur_weight")
    EE.Range("E" & i) = 1
    TOTAL_Q = TOTAL_Q + 1
    TOTAL_W = TOTAL_W + Rs("pur_weight")
    Rs.MoveNext
Loop
i = i + 1
EE.Range("A" & i) = "总计："
EE.Range("D" & i) = TOTAL_W
EE.Range("E" & i) = TOTAL_Q

EE.Sheets("Sheet1").Select
EE.ActiveWorkbook.Save
EE.ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True
EE.quit

s2 = s2 & "SCR01=8,1, '生成单据是：'" & vbCrLf
s2 = s2 & "SCR02=9,1, '" & "小票" & CK_NO & ".xls '" & vbCrLf
s2 = s2 & "SCR03=10,1, '存在目录是：'" & vbCrLf
s2 = s2 & "SCR04=11,1, '" & lj & "\" & vbCrLf

End Function



