编码查询工具（进阶）

块定义

Option Explicit

Type VMCode
    prd_no As String '编码
    spc As String '具体规格
    ut As String '单位
End Type

Type VCode
    prd_no As String '编码
    PRD_MARK As String '供应商
    qty As Single '现有库存
    qty_on_way As Single '在途
    qty_on_prc As Single '在制
    qty_on_rsv As Single '未发量
    qty_end As Single '可用库存
    name As String '库位
End Type

主程序

Option Explicit
Private Declare Function LCMapstring Lib "kernel32" Alias "LCMapStringA" (ByVal locale As Long, ByVal dwpflags As Long, ByVal lpsrcstr As String, ByVal cchsrc As Long, ByVal lpdeststr As String, ByVal cchdest As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpstring As String) As Long
Dim stf As String
Dim stj As String
Dim stlen As String
Dim cnn As ADODB.Connection
Dim DataTemp() As VMCode
Dim DTemp() As VCode

Private Sub Combo1_Click()
Dim rs As ADODB.Recordset
Dim rst1 As ADODB.Recordset
Dim sql1 As String
Dim stf1 As String
Dim stj1 As String
Dim stlen1 As String
Dim sql2 As String
Dim i, x, y As Integer
Dim str2 As String
    Set rs = New ADODB.Recordset
    Text1.Text = DataTemp(Combo1.ListIndex).prd_no
    Label4.Caption = "单位:" & DataTemp(Combo1.ListIndex).ut
    sql1 = "select PRD_NO,PRD_MARK,QTY,QTY_ON_WAY,QTY_ON_PRC,QTY_ON_RSV,WH from dbo.prdt1 where '" & Trim(Text1.Text) & "' = prd_no"
    rs.Open Trim$(sql1), cnn, adOpenKeyset, adLockOptimistic
    If rs.RecordCount <> 0 Then
        ReDim DTemp(rs.RecordCount - 1)
        ReDim str1(0 To rs.RecordCount - 1)
        x = rs.RecordCount
        List1.Clear
        rs.MoveFirst
        For i = 0 To rs.RecordCount - 1
            DTemp(i).PRD_MARK = rs.Fields(1) & Space(7 - Len(rs.Fields(1)))
            DTemp(i).prd_no = rs.Fields(0)
            DTemp(i).qty = rs.Fields(2)
            str1(i) = DTemp(i).qty & Space(10 - Len(Str(DTemp(i).qty)))
            DTemp(i).qty_on_way = rs.Fields(3)
            DTemp(i).qty_on_prc = rs.Fields(4)
            DTemp(i).qty_on_rsv = rs.Fields(5)
            DTemp(i).name = rs.Fields(6)
            DTemp(i).qty_end = DTemp(i).qty + DTemp(i).qty_on_way + DTemp(i).qty_on_prc - DTemp(i).qty_on_rsv
            'rst1.Open Trim$(sql2), cnn, adOpenKeyset, adLockOptimistic
            'List1.AddItem "供应商:" & DTemp(i).PRD_MARK & "现有库存:" & str1(i) & "可用库存:" & DTemp(i).qty_end & vbCrLf
            rs.MoveNext
        Next i
        rs.Close
        Set rs = Nothing
        For y = 0 To x - 1
        Set rst1 = New ADODB.Recordset
        sql2 = "select wh,name from dbo.MY_WH where '" & Trim(DTemp(y).name) & "' = wh"
        rst1.Open Trim$(sql2), cnn, 3, 2
        If rst1.RecordCount <> 0 Then
        stf1 = rst1.Fields(1)
        stlen1 = lstrlen(stf1)
        stj1 = Space(stlen1)
        LCMapstring &H804, &H2000000, stf1, stlen1, stj1, stlen1
        str2 = stj1
        List1.AddItem "库位:" & str2 & " 供应商:" & DTemp(y).PRD_MARK & "现有库存:" & str1(y) & "可用库存:" & DTemp(y).qty_end & vbCrLf
        End If
        rst1.Close
        Set rst1 = Nothing
        Next y
    Else:
        List1.Clear
        List1.AddItem "无库存"
    End If
End Sub

Private Sub Combo1_KeyDown(KeyCode As Integer, Shift As Integer)
Dim VarString
Dim dbFilePath As String
'Dim cnn As ADODB.Connection
Dim rst As ADODB.Recordset
Dim SQL As String
Dim i As Integer

dbFilePath = "FileDSN=db_tz13.dsn;UID=sa;PWD=sqlsa"   'server 192.168.1.12

If KeyCode = 13 Then
    Text1.Text = ""
    If Combo1.Text <> "" Then
        VarString = Split(Combo1.Text, " ") 'split是一个切割函数
        Combo1.Clear
        SQL = "SELECT prd_no,spc,ut FROM DBO.PRDT WHERE "
        For i = 0 To UBound(VarString)
            stj = VarString(i)
            stlen = lstrlen(stj)
            stf = Space(stlen)
            LCMapstring &H804, &H4000000, stj, stlen, stf, stlen
            VarString(i) = stf
            If i <> 0 Then
                SQL = SQL & " and "
            End If
            SQL = SQL & "CHARINDEX(N'" & Trim(VarString(i)) & "',spc)<>0"
'N 在这里表示 Unicode，就是双字节字符。对于西文字符，用一个字节来存储过足够了，对于东方文字，就需要两个字节来存储。字符串用引号，公式用& &，字符型数据用单引号
        Next i
        SQL = SQL & " order by prd_no"
    Else
        Label3.Caption = ""
        Exit Sub
    End If
Else
    Exit Sub
End If

On Error GoTo ExecuteSQL_Error
Set cnn = New ADODB.Connection
cnn.Open dbFilePath
cnn.Execute "use db_tz13"
Set rst = New ADODB.Recordset
rst.Open Trim$(SQL), cnn, adOpenKeyset, adLockOptimistic
'Rs.open语法：rs.open Source(sql语句),ActiveConnection(数据库连接),CursorType(游标),LockType(数据锁定类型)
'Set rs = New ADODB.Recordset
'SQL1 = "select prd_no,qty from dbo.prdt1 where rst.fields(0)=prd_no "
'rs.Open SQL1, cnn, adOpenKeyset, adLockOptimistic
If rst.RecordCount <> 0 Then
    ReDim DataTemp(rst.RecordCount - 1)
    Label3.Caption = "找到符合条件的 " & rst.RecordCount & "条记录！"
    rst.MoveFirst
    For i = 0 To rst.RecordCount - 1
        stf = rst.Fields(1)
        stlen = lstrlen(stf)
        stj = Space(stlen)
        LCMapstring &H804, &H2000000, stf, stlen, stj, stlen
        'Set rs = New ADODB.Recordset
        DataTemp(i).prd_no = rst.Fields(0)
        DataTemp(i).spc = stj
        DataTemp(i).ut = rst.Fields(2)
        'rs.Open "select prd_no,qty from dbo.prdt1 where CHARINDEX(N'" & Trim(DataTemp(i).prd_no) & "',prd_no)<>0", cnn, adOpenKeyset, adLockBatchOptimistic
        'DataTemp(i).qty = rs.Fields(1)
        Combo1.AddItem DataTemp(i).prd_no & " | " & DataTemp(i).spc '& " | 数量:" & rs.Fields(1)
        rst.MoveNext
        'rs.MoveNext
        If i = 100 Then
            i = rst.RecordCount
            Label3.Caption = Label3.Caption & Chr(13) & "请注意仅仅列出前100个记录！"
        End If
    Next i
    'Combo1.Drop
    'SendKeys "{f4}"
Else
    Label3.Caption = "找到符合条件的 0条记录！"
End If
rst.Close
Set rst = Nothing
Exit Sub

ExecuteSQL_Error:
MsgBox "连接服务器失败！", vbOKOnly + vbCritical, "错误！"

End Sub

Private Sub Command1_Click()
Shell "C:\WINDOWS\system32\calc.exe", vbNormalFocus
End Sub