accesscnn.bas

本系统特为行业报价、订单、产品管理与客户关系管理所订制

Attribute VB_Name = "accesscnn"
'****************************************************************************
'人人为我，我为人人
'枕善居收藏整理
'发布日期：2008/05/10
'描    述：商品综合管理系统 Sql2000版
'网    站：http://www.Mndsoft.com/  (VB6源码博客)
'网    站：http://www.VbDnet.com/   (VB.NET源码博客,主要基于.NET2005)
'e-mail  ：[e-mail]
'e-mail  ：[e-mail]
'OICQ    ：88382850
'          如果您有新的好的代码别忘记给枕善居哦!
'****************************************************************************
Public cnn As New ADODB.Connection
Public cnn1 As New ADODB.Connection
Public Qy1 As New ADODB.Recordset '数据专用
Public Qy2 As New ADODB.Recordset '数据专用
Public Qy3 As New ADODB.Recordset '数据专用
Public StrNumberID As String
Public hang As Integer
Public hang1 As Integer
Public admin As Boolean
Public sknPname As String '皮肤路径
Public LoginName As String '当前登陆名
Public GridSize As Integer '字体大小
Public TKTable As String
Public SendDH As String '传输单号
Public LoginAdmin As String '用户名
Public UKeyStr As String
Public KeyStr As String '序列号
Public PrintS As String '当前打印设定标号
Public yxsql As String
Public PRows As Integer '各表框定义行数限制
Public CRows As Integer
Public XSRows As Integer
Public VersionN As String '当前版本号
Public NEW_VersionN As String '新版本号
Public UPIP As String '升级服务器IP
Public UPURL As String '升级文件路径
Public UPlist As String '升级文件说明路径
Public EXIT_UP As Boolean '是否跳过了升级
Public Msgboxstr1 As String '提示不允许操作
Public FileName As String '升级文件名与路径
Public filesize As Double '文件大小
Public UPboolean As Boolean '是否已经结束文件的发送
Public bAppend As Boolean '是否新文件，用于提交到判断


Sub Main()
On Error GoTo finish:

tkOpenAccessDB App.Path & "\base.mdb"
'----获取默认皮肤
Dim filesize As Double
Dim intfile As Integer
Dim strinput As String
Dim strst() As String
Dim strtargetfile As String
strtargetfile = App.Path & "\skn.mk"
intfile = FreeFile
filesize = FileLen(strtargetfile)
Open strtargetfile For Binary As #1
strinput = Space(filesize)
Get #intfile, , strinput
Close #1
strst = Split(strinput, vbCrLf)
sknPname = strst(0)
GridSize = 8
strtargetfile = App.Path & "\sjj.mk"
intfile = FreeFile
If Dir(strtargetfile, vbNormal) <> "" Then
 filesize = FileLen(strtargetfile)
Open strtargetfile For Binary As #1
strinput = Space(filesize)
Get #intfile, , strinput
Close #1
strst = Split(strinput, ";")
XSRows = strst(0)
PRows = strst(1)
CRows = strst(2)
Else
XSRows = 15
PRows = 15
CRows = 15
End If
'-----
'Printset.Show
login.Show
Exit Sub
finish:
login.Show
End Sub
Public Sub tkOpenAccessDB( _
        tkFileName As String, _
        Optional tkUserID As String, _
        Optional tkPassword As String _
    )
    
    On Error GoTo tkFinish
    
    cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & tkFileName & ";" & _
        "Mode=Share Deny None;" & _
        "Extended Properties=;" & _
        "Jet OLEDB:System database=;" & _
        "Jet OLEDB:Registry Path=;" & _
        "Jet OLEDB:Database Password=;" & _
        "Jet OLEDB:Engine Type=5;" & _
        "Jet OLEDB:Database Locking Mode=1;" & _
        "Jet OLEDB:Global Partial Bulk Ops=2;" & _
        "Jet OLEDB:Global Bulk Transactions=1;" & _
        "Jet OLEDB:New Database Password=;" & _
        "Jet OLEDB:Create System Database=False;" & _
        "Jet OLEDB:Encrypt Database=False;" & _
        "Jet OLEDB:Don't Copy Locale on Compact=False;" & _
        "Jet OLEDB:Compact Without Replica Repair=False;" & _
        "Jet OLEDB:SFP=False;" & _
        tkUserID, _
        tkPassword
    
    Exit Sub
tkFinish:
    MsgBox Err.Description
    End
    
End Sub
Public Sub tkOpenAccessDB1( _
        tkFileName As String, _
        Optional tkUserID As String, _
        Optional tkPassword As String _
    )
    
    On Error GoTo tkFinish
    
    cnn1.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
        "Data Source=" & tkFileName & ";" & _
        "Mode=Share Deny None;" & _
        "Extended Properties=;" & _
        "Jet OLEDB:System database=;" & _
        "Jet OLEDB:Registry Path=;" & _
        "Jet OLEDB:Database Password=;" & _
        "Jet OLEDB:Engine Type=5;" & _
        "Jet OLEDB:Database Locking Mode=1;" & _
        "Jet OLEDB:Global Partial Bulk Ops=2;" & _
        "Jet OLEDB:Global Bulk Transactions=1;" & _
        "Jet OLEDB:New Database Password=;" & _
        "Jet OLEDB:Create System Database=False;" & _
        "Jet OLEDB:Encrypt Database=False;" & _
        "Jet OLEDB:Don't Copy Locale on Compact=False;" & _
        "Jet OLEDB:Compact Without Replica Repair=False;" & _
        "Jet OLEDB:SFP=False;" & _
        tkUserID, _
        tkPassword
    
    Exit Sub
tkFinish:
    MsgBox Err.Description
    End
    
End Sub

'分析并保存Winsock得到服务器响应的数据
'入口变量
'ByteNum：  接收到数据的字节数
'ByteData： 接收数据的Byte类型的数组
'出口变量：
'Flen：     文件长度
'函数返回值：表示一定意思的字符串
Public Function SaveData(ByteNum As Long, ByteData() As Byte, Flen As Long) As String
Dim Tfile As String
Dim Fnum As Integer
Static m3Byte(3) As Byte
'Static bAppend As Boolean
Dim StartPos As Long
Dim i As Long
If bAppend = False Then
    ReceiveData = ReceiveData & StrConv(ByteData(), vbUnicode)
    Clipboard.SetText ReceiveData
    If (InStr(1, ReceiveData, "HTTP/1.0 200 OK") Or InStr(1, ReceiveData, "HTTP/1.1 200 OK")) Then
        '表示请求下载文件成功
        SaveData = "200"
    ElseIf (InStr(1, ReceiveData, "HTTP/1.0 206 ") Or InStr(1, ReceiveData, "HTTP/1.1 206")) Then
        '表示请求断点续传成功
        SaveData = "206"
    ElseIf (InStr(1, ReceiveData, "HTTP/1.0 404 ") Or InStr(1, ReceiveData, "HTTP/1.1 404")) Then
        '表示服务器未找到请求的资源
        SaveData = "404"
    Else
        '请求错误
        SaveData = "error"
        Exit Function
    End If
    '如果服务器响应的字符串有指定文件大小的标题字段，取得文件大小
    If InStr(1, ReceiveData, "Content-Length:") > 0 And mflen = 0 Then
    Dim pos1 As Long, pos2 As Long
    pos1 = InStr(1, ReceiveData, "Content-Length:")
    pos2 = InStr(pos1 + 16, ReceiveData, vbCrLf)
        If pos2 > pos1 Then
            mflen = Mid(ReceiveData, pos1 + 16, pos2 - pos1 - 16)
            Flen = mflen
            filesize = mflen
        End If
    End If
    '从服务器响应返回的数据中查找下载文件的起始位置
    For i = 0 To UBound(ByteData()) - 3
        If ByteData(i) = 13 And ByteData(i + 1) = 10 And ByteData(i + 2) = 13 And ByteData(i + 3) = 10 Then
            StartPos = i + 4
            bAppend = True
            Exit For
        End If
    Next i
End If
'如果取消，则退出该过程，并返回字符串“cancel”
If bAppend = False Then
    If bCancel = True Then
        SaveData = "cancel"
    End If
    Exit Function
End If
'在调用frmDown的Public函数DraoDownPic反映下载情况
'frmDown.DrawDownPic WhichSocket, ByteNum - StartPos, mFlen, ReceiveBytes
'ReceiveBytes = ReceiveBytes + ByteNum - StartPos
Tfile = FileName
Fnum = FreeFile()
'向二进制文件中加入下载文件的数据
Open Tfile For Binary As #Fnum
If LOF(Fnum) > 0 Then
    Seek #Fnum, LOF(Fnum) + 1
End If
If StartPos > 0 Then
    For i = StartPos To UBound(ByteData())
        Put #Fnum, , ByteData(i)
    Next i
Else
    Put #Fnum, , ByteData()
End If
Close #Fnum
If FileLen(Tfile) >= filesize Then
UPboolean = True
End If
'If bCancel = True Then
'    SaveData = "cancel"
'End If
End Function

Public Function StringToBinary(ByVal VarString As String) As Variant '字符串转成二进制
  Dim strBin As Variant
  Dim varchar As Variant
  Dim varasc As Long
  Dim varlow, varhigh
  Dim i As Long
  strBin = ""
  
  For i = 1 To Len(VarString)
      varchar = Mid(VarString, i, 1)
      varasc = Asc(varchar)
      If varasc < 0 Then
          varasc = varasc + 65535
      End If
      If varasc > 255 Then
          varlow = Left(Hex(Asc(varchar)), 2)
          varhigh = Right(Hex(Asc(varchar)), 2)
          strBin = strBin & ChrB("&H" & varlow) & ChrB("&H" & varhigh)
      Else
          strBin = strBin & ChrB(AscB(varchar))
      End If
  Next
  StringToBinary = strBin
End Function

Public Function BinaryToString(ByVal BinaryStr As Variant) As String '二进制转换为字符串
  Dim lnglen As Long
  Dim tmpBin As Variant
  Dim strC As String
  Dim skipflag As Long
  Dim i As Long
  skipflag = 0
  strC = ""
  
  If Not IsNull(BinaryStr) Then
      lnglen = LenB(BinaryStr)
      For i = 1 To lnglen
          If skipflag = 0 Then
            tmpBin = MidB(BinaryStr, i, 1)
            If AscB(tmpBin) > 127 Then
                strC = strC & Chr(AscW(MidB(BinaryStr, i + 1, 1) & tmpBin))
                skipflag = 1
            Else
                strC = strC & Chr(AscB(tmpBin))
            End If
          Else
            skipflag = 0
          End If
      Next
    End If
    BinaryToString = strC
End Function