pubmod.bas

将xml格式的文件导入到 数据库中,将xml格式的文件导入到 数据库中

Attribute VB_Name = "pubmod"
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Const BIF_RETURNONLYFSDIRS = &H1
Public Const BIF_DONTGOBELOWDOMAIN = &H2
Public Const BIF_STATUSTEXT = &H4
Public Const BIF_RETURNFSANCESTORS = &H8
Public Const BIF_BROWSEFORCOMPUTER = &H1000
Public Const BIF_BROWSEFORPRINTER = &H2000
Public Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Public Type BROWSEINFO
    hOwner As Long
    pidlRoot As Long
    pszDisplayName As String
    lpszTitle As String
    ulFlags As Long
    lpfn As Long
    lParam As Long
    iImage As Long
End Type


Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Public Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Public Function GFileName(ByVal Gmod As Long) As String
On Error GoTo NikeeError
Dim ofn As OPENFILENAME
Dim rtn As Long
ofn.lStructSize = Len(ofn)
ofn.hInstance = App.hInstance
ofn.lpstrFilter = "文本文件 (*.txt)" + Chr$(0) + "*.txt" + Chr$(0)
ofn.lpstrFile = Space(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = App.Path
ofn.flags = 6148
If Gmod = 1 Then
ofn.lpstrTitle = "打开文件..."
rtn = GetOpenFileName(ofn)
Else
ofn.lpstrTitle = "保存文件的路径及文件名..."
rtn = GetSaveFileName(ofn)
End If
If rtn >= 1 Then
GFileName = Trim(ofn.lpstrFile)
GFileName = Replace(GFileName, Chr(0), "")
End If
Exit Function
NikeeError:
MsgBox "未知原因导致操作失败!", 48, "妮可提示!!"
End Function

'将str字符串中的substr 子串过滤掉
Public Function leach_substr(str As String, substr As String) As String
Dim tempstr As String
Dim I As Long
    Do
        I = InStr(1, str, substr, vbTextCompare)
        If I > 0 Then
            tempstr = Left(str, I - 1) & Right(str, Len(str) - I)
            str = tempstr
        End If
    Loop Until I < 1
    leach_substr = str
End Function
 
'取出str_str_key1 和 str_key2 关键子之间的字符
Public Function get_midstr(ByVal str As String, str_key1 As String, str_key2 As String) As String
Dim tempstr As String
Dim tempstr1 As String
Dim I As Long
tempstr1 = str
    If str_key1 <> "" Then
        I = InStr(1, tempstr1, str_key1, vbTextCompare)
        If I > 0 Then
            I = I + Len(str_key1) - 1
            tempstr = Right(tempstr1, Len(str) - I)
            tempstr1 = tempstr
        End If
    End If
    
    If str_key2 <> "" Then
        I = InStr(1, tempstr1, str_key2, vbTextCompare)
        If I > 0 Then
            tempstr = Left(tempstr1, I - 1)
            tempstr1 = tempstr
        End If
    End If
    get_midstr = tempstr1
End Function
 

'取出 str_str_key 关键子左边的字符
Public Function get_leftstr(str As String, str_key As String) As String
Dim tempstr As String
Dim I As Long
    If str_key <> "" Then
        I = InStr(1, str, str_key, vbTextCompare)
        If I > 0 Then
            tempstr = Left(str, I - 1)
        End If
        get_leftstr = tempstr
    Else
        get_leftstr = ""
    End If
    
End Function
 
'取出 str_str_key 关键子右边的字符
Public Function get_Rightstr(str As String, str_key As String) As String
Dim tempstr As String
Dim I As Long
    If str_key <> "" Then
        I = InStr(1, str, str_key, vbTextCompare)
        If I > 0 Then
            I = I + Len(str_key) - 1
            tempstr = Right(str, Len(str) - I)
        End If
        get_Rightstr = tempstr
    Else
        get_Rightstr = ""
    End If
End Function

Public Function FullPathName(ByVal strPath As String) As String

FullPathName = IIf(VBA.Right(strPath, 1) = "\", strPath, strPath & "\")

End Function
'多个文件夹名组成路径

Public Function Combin(ParamArray arg()) As String

Dim X

Dim result As String

For Each X In arg()

result = result & FullPathName(X)

Next

Combin = result

End Function



Function FileExist(FileName As String) As Boolean
Dim SfName As String
Dim f As Long
        On Error GoTo 12
        f = FreeFile
        SfName = FileName & "\aa.txt"
        Open SfName For Output As #f
        Close #f
        FileExist = True
        Call Kill(SfName)
        Exit Function
12
        FileExist = False
        MsgBox "您输入的路径不合法，请重新输入！！", vbOKOnly, "提示"
  End Function
'  Public Function IsFileExists(sFileName As String) As Boolean
'
'          Dim Ltxt As Long
'
'          'On Error GoTo handleError
'           sFileName = sFileName & "aa.txt"
'          If sFileName <> "" Then
'                  Ltxt = FreeFile
'                  Open sFileName For Input As Ltxt
'                  Close Ltxt
'
'                  IsFileExists = True
'          Else
'                  IsFileExists = False
'          End If
'
'          Exit Function
'          End Function

Public Function Encrypt(PlainStr As String, key As String) As String
  Dim Char     As String, KeyChar       As String, NewStr       As String
  Dim Pos     As Integer
  Dim I     As Integer, Side1       As String, Side2       As String
  Pos = 1

  'This   loop   encrypts   the   data.
  For I = 1 To Len(PlainStr)
      Char = Mid(PlainStr, I, 1)
      KeyChar = Mid(key, Pos, 1)
      NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
      If Pos = Len(key) Then Pos = 0
      Pos = Pos + 1
  Next I

  'This   is   a   little   trick   to   make   it   slightly   harder   to   crack.
  'However,   the   chances   of   this   operation   firing   is   50/50
  'because   the   length   of   the   string   must   be   divisable   by   2.
  If Len(NewStr) Mod 2 = 0 Then
      Side1 = StrReverse(Left(NewStr, (Len(NewStr) / 2)))
      Side2 = StrReverse(Right(NewStr, (Len(NewStr) / 2)))
      NewStr = Side1 & Side2
  End If

  Encrypt = NewStr
  End Function
  


Public Function Decrypt(PlainStr As String, key As String) As String
  Dim Char     As String, KeyChar       As String, NewStr       As String
  Dim Pos     As Integer
  Dim I     As Integer, Side1       As String, Side2       As String
  Pos = 1
     
  'This   is   a   little   trick   to   make   it   slightly   harder   to   crack.
  'However,   the   chances   of   this   operation   firing   is   50/50
  'because   the   length   of   the   string   must   be   divisable   by   2.
  If Len(PlainStr) Mod 2 = 0 Then
      Side1 = StrReverse(Left(PlainStr, (Len(PlainStr) / 2)))
      Side2 = StrReverse(Right(PlainStr, (Len(PlainStr) / 2)))
      PlainStr = Side1 & Side2
  End If
     
  'This   loop   decrypts   the   data.
  For I = 1 To Len(PlainStr)
      Char = Mid(PlainStr, I, 1)
      KeyChar = Mid(key, Pos, 1)
      NewStr = NewStr & Chr(Asc(Char) Xor Asc(KeyChar))
      If Pos = Len(key) Then Pos = 0
      Pos = Pos + 1
  Next I
     
  Decrypt = NewStr
  End Function