module1.bas

本软件系本人自学VB过程中试写,后来经不断改进完成,经试用比较完整,又修补了一些漏洞,可以放心投入使用,并供学习编程爱好者参考. 本软件简单易用,操作方便,基本可以不用鼠标,直接通过键盘操作.

Attribute VB_Name = "Module1"
Public caozuoyuan As String
Public ifmana As Boolean
Public mingzi As String
Option Explicit
Public cn As ADODB.Connection
Public Const HUOPIN_TABLE_STR = "hNo,hLeibie,hName,hGuige,hDanwei,hPinpai,hNum,hRukujia,hBak"
Public Const HUOPIN_TABLE_STR1 = "hNo,hLeibie,hName,hGuige,hDanwei,hPinpai,hNum,hRukujia,hBak,jiecun"
Public Const XIAOLU_TABLE_STR = "shijian,hNo,hName,hNum,hDanwei,hRukujia,hXiaojia,lirun,zonglirun"
Public ChahuoStr(8, 1) As String '供查询用的货品字段和对应的字段
Public Const JINLU_TABLE_STR = "jshijian,jNo,jren,jRukujia,jNum,jBak"
Public Const sqlZiduan = "ID as HID,hLeibie as 货品类别,hNo as 货品编号,hName as 货品名称 ,hGuige as 货品规格,hDanwei as 货品单位,hPinpai as 货品品牌,hNum as 货品数量,hRukujia as 入库价格,hBak as 备注"
Public Const sqlZiduan1 = "XID as ID,xshijian as 时间,xNo as 货品编号,xName as 货品名称 ,xleibie as 货品类别,xNum as 销售数量,xDanwei as 货品单位,xRukujia as 货品进价,xXiaojia as 实际销价,xlirun as 所得利润"
Public Const sqlziduan2 = "ID as KID,hNo as 货品编号,hNum as 货品数量,hRukujia as 进货价,jiecun as 结存金额"
Public Const sqlziduan3 = "ID as KID,kNo as 货品编号,kNum as 货品数量,kJiecun as 结存金额"
Public Const sqlziduan4 = "JID as JID,jshijian as 进货时间,jNo as 进货编号,jren as 进货人,jRukujia as 进货价,jNum as 进货数量,jBak as 进货备注"
'Public ChaSijiStr(10, 1) As String
Public Sub Main()
On Error GoTo 10
   Set cn = New ADODB.Connection
   cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
            "Data Source=" & App.Path & "\config.dll;" & _
            "Persist Security Info=False;" & _
            "Mode=ReadWrite|Share Deny None;" & _
            "Jet OLEDB:Database Password=aa"

            
   
   cn.CommandTimeout = 30
   cn.CursorLocation = adUseClient
   cn.open
   Call Chushihua
   frmlogin.Show 1
   Exit Sub
10:
      MsgBox Err.Description
End Sub

Public Sub fuzhi(grid As MSFlexGrid, re As ADODB.Recordset)
   Dim i As Integer
   Dim j As Integer
   Dim sss As String
   Dim x As Integer
   x = 0
   grid.Clear
   grid.Redraw = True
   grid.Refresh
   grid.cols = re.Fields.Count
   If re.RecordCount = 0 Then '数据库中无纪录,读字段名称
      grid.rows = 2
      grid.FixedRows = 1
      For i = 0 To re.Fields.Count - 1
          x = InStr(re.Fields(i).Name, ".")
          If x > 0 Then
             x = x - 1
             grid.TextMatrix(0, i) = Right(re.Fields(i).Name, x)
          Else
             grid.TextMatrix(0, i) = re.Fields(i).Name
          End If
      Next i
      Exit Sub
   End If
   '数据库中有纪录,读字段名称和数据
   re.MoveLast
   re.MoveFirst
   grid.rows = 1
   grid.cols = re.Fields.Count
   grid.rows = re.RecordCount + 1
   For i = 0 To re.Fields.Count - 1 '读字段名称
        x = InStr(re.Fields(i).Name, ".")
        If x > 0 Then
           x = x - 1
           grid.TextMatrix(0, i) = Right(re.Fields(i).Name, x)
        Else
           grid.TextMatrix(0, i) = re.Fields(i).Name
        End If
        grid.TextMatrix(0, i) = Left(re.Fields(i).Name, InStr(re.Fields(i).Name, "."))
        grid.TextMatrix(0, i) = re.Fields(i).Name
   Next i
   For i = 1 To re.RecordCount '读纪录
      For j = 0 To re.Fields.Count - 1
      If Not IsNull(re.Fields(j).Value) Then
        grid.TextMatrix(i, j) = re.Fields(j).Value
'           Select Case re.Fields(j).Name '特殊字段值处理
'                  Case "性别"
'                       grid.TextMatrix(i, j) = IIf(re.Fields(j).Value, "男", "女")
'                  Case "是否身高/身长"
'                       grid.TextMatrix(i, j) = IIf(re.Fields(j).Value, "身高", "身长")
'                  Case Else
'                       grid.TextMatrix(i, j) = re.Fields(j).Value
'           End Select
      Else
           grid.TextMatrix(i, j) = ""
      End If
      Next j
      re.MoveNext
   Next i
   're.Close
End Sub

Public Function csv(adoRS As ADODB.Recordset, CD1 As CommonDialog) As Boolean '如果有换行，比较麻烦
Dim iTotalRD As Integer        '记录总数
Dim sExportFile As String      '要输出的文件名
Dim iFileNum As Integer     '要输出的文件名代号
Dim iFieldNumber As Integer    '字段总数
Dim msg As String              'MsgBox上的信息
Dim iindex As Integer

Screen.MousePointer = vbDefault

On Error Resume Next

With CD1
.CancelError = True
.FileName = "Export.csv"
.InitDir = App.Path
.DialogTitle = _
"输出csv文件至"
.Filter = "Export Files(*.csv)|*.csv"
.DefaultExt = "csv"                       '默认扩展名是.csv
.Flags = cdlOFNOverwritePrompt Or cdlOFNCreatePrompt
.ShowSave
End With

'User单击了Cancel按钮
If (Err = 32755) Then
   Screen.MousePointer = vbDefault
   Beep
   msg = "您取消了转换成csv文件的动作！"
   iindex = MsgBox(msg, 48, "提示信息")
   csv = False
   Exit Function
Else
   On Error GoTo expErrors
End If

'开始输出与格式转换

Screen.MousePointer = vbHourglass    '鼠标光标变成漏斗的形状

iTotalRD = 0
sExportFile = CD1.FileName
iFileNum = FreeFile()             '向Windows取得文件代号

Open sExportFile For Output As #iFileNum  '打开输出文件

'依序存取字段的数据
iFieldNumber = adoRS.Fields.Count - 1

For iindex = 0 To iFieldNumber
 If iindex = iFieldNumber Then
   Print #iFileNum, Trim$(CStr(adoRS.Fields(iindex).Name));
 Else
   Print #iFileNum, Trim$(CStr(adoRS.Fields(iindex).Name)); ",";
 End If
Next
Print #iFileNum,
adoRS.MoveFirst
Do Until adoRS.EOF
 iTotalRD = iTotalRD + 1
   For iindex = 0 To iFieldNumber
    If (IsNull(adoRS.Fields(iindex))) Then
     Print #iFileNum, ",";
    Else
     If iindex = iFieldNumber Then
      Print #iFileNum, Trim$(CStr(adoRS.Fields(iindex)));
    Else
      Print #iFileNum, Trim$(CStr(adoRS.Fields(iindex))); ",";
     End If
    End If
   Next
Print #iFileNum,
adoRS.MoveNext
Loop

'关闭输出文件
Close iFileNum
Screen.MousePointer = vbDefault
Beep
msg = "输出的csv文件成功！"
iindex = MsgBox(msg, 48, "提示信息")
csv = True
Exit Function
 
expErrors:
Screen.MousePointer = vbDefault
MsgBox (Err & ":" & Err.Description)
csv = False

End Function
Public Sub Chushihua()
    ChahuoStr(0, 0) = "按货品编号"
    ChahuoStr(1, 0) = "按货品类别"
    ChahuoStr(2, 0) = "按货品品牌"
    ChahuoStr(3, 0) = "按货品名称"
    ChahuoStr(4, 0) = "按货品规格"
    ChahuoStr(5, 0) = "按入库价"
    
    ChahuoStr(0, 1) = "hNo"
    ChahuoStr(1, 1) = "hLeibie"
    ChahuoStr(2, 1) = "hPinpai"
    ChahuoStr(3, 1) = "hName"
    ChahuoStr(4, 1) = "hGuige"
    ChahuoStr(5, 1) = "hRukujia"
End Sub
Public Function GetSqlStr(i As Integer, txtcha As String, huoVSsiji As Integer) As String
    Dim strsql As String
    If huoVSsiji = 0 Then
        strsql = "select " & sqlZiduan & " from huo where " & ChahuoStr(i, 1) & " like '%" & txtcha & "%' order by " & ChahuoStr(i, 1)
'    Else
'        strSql = "select " & sqlZiduan1 & " from che where " & ChaCheStr(i, 1) & " like '%" & txtCha & "%' order by " & ChaCheStr(i, 1)
    End If
    GetSqlStr = strsql
End Function
Public Function html(adoRS As ADODB.Recordset, CD1 As CommonDialog) As Boolean
Dim exportfile As String          '输出的文件名
Dim iFileNum As Integer           '输出文件名的代号
Dim outlp As Integer
Dim inlp As Integer
Dim msg As String                 '消息框的说明文字
Dim iindex As Integer             '字段索引

On Error Resume Next
With CD1
.CancelError = True
.FileName = "Export.html"
.InitDir = App.Path
.DialogTitle = _
"输出HTML文件至"
.Filter = "Export Files(*.html)|*.html"
.DefaultExt = "htm"
.Flags = cdlOFNOverwritePrompt Or cdlOFNCreatePrompt
.ShowSave
End With

'User cancel the operation
If (Err = 32755) Then
   Screen.MousePointer = vbDefault
   Beep
   msg = "您取消了转成HTML文件的动作!"
   iindex = MsgBox(msg, 48, "提示信息")
   html = False
   Exit Function
Else
   On Error GoTo htmlErrors
End If

'进行转成HTML文件的动作

Screen.MousePointer = vbHourglass

exportfile = CD1.FileName
iFileNum = FreeFile()

Open exportfile For Output As #iFileNum
adoRS.MoveFirst

Print #iFileNum, "<HTML><HEAD><TITLE>将数据转成" & _
                    "HTML格式</TITLE></HEAD>"
Print #iFileNum, "<BODY BGCOLOR=""FFFFFF"">"
Print #iFileNum, "<TABLE BGCOLOR=""00AAFF"" WIDTH=""100%"">"
Print #iFileNum, "<TR><TD>"
Print #iFileNum, "<FONT FACE=ARIAL SIZE+=3><B>导出数据" & _
                    "</B></FONT></TD></TR>"
Print #iFileNum, "<TR>"

For iindex = 0 To adoRS.Fields.Count - 1
    Print #iFileNum, "<TD BGCOLOR=CCCCC>"
    Print #iFileNum, "<B> &nbsp"; adoRS.Fields(iindex).Name; "&nbsp</B>"
    Print #iFileNum, "</TD>"
Next
Print #iFileNum, "</TR>"
With adoRS
.MoveFirst

While Not .EOF
Print #iFileNum, "<TR>"
For inlp = 0 To .Fields.Count - 1
    Print #iFileNum, "<TD BGCOLOR=CCCCC>"
    Print #iFileNum, "&nbsp"; .Fields(inlp); "&nbsp"
    Print #iFileNum, "</TD>"
Next
Print #iFileNum, "</TR>"
.MoveNext
Wend
End With

Print #iFileNum, "</TABLE></BODY></HTML>"

Close #iFileNum

MsgBox "转成HTML文件成功!", 48, "提示信息"

Screen.MousePointer = vbDefault
html = True

Exit Function

htmlErrors:
Screen.MousePointer = vbDefault
MsgBox Err.Description
html = False

End Function