bas1.bas

数据同步工具

Attribute VB_Name = "Bas1"
Option Explicit

Public Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long

Public gstrConfigFile As String

Dim mintC() As Integer
Dim mintN() As Integer
Dim mintD() As Integer

Public Function ReadConfig() As Boolean
    ReadConfig = False
    gstrConfigFile = gstrAppPath & "\config.ini"
    If gfso.FileExists(gstrConfigFile) = False Then
        XF_MsgE "对不起，找不到系统配置文件 " & gstrConfigFile & ",程序不能运行!"
        Exit Function
    End If
    
    Dim str1 As String
    Dim S As String
    Dim MyRetrun As Long
    Dim S1() As String
    Dim I As Integer
    
    str1 = Space(500)
    MyRetrun = GetPrivateProfileString("DataType", "char", "", str1, 500, gstrConfigFile)
    str1 = Trim(str1)
    If Len(str1) >= 1 Then str1 = Trim(Mid(str1, 1, Len(str1) - 1))
    XF_FJStringToArray str1, ",", S1
    ReDim mintC(UBound(S1))
    For I = 1 To UBound(S1)
        mintC(I) = Val(S1(I))
    Next
    
    str1 = Space(500)
    MyRetrun = GetPrivateProfileString("DataType", "numeric", "", str1, 500, gstrConfigFile)
    str1 = Trim(str1)
    If Len(str1) >= 1 Then str1 = Trim(Mid(str1, 1, Len(str1) - 1))
    XF_FJStringToArray str1, ",", S1
    ReDim mintN(UBound(S1))
    For I = 1 To UBound(S1)
        mintN(I) = Val(S1(I))
    Next
   
    str1 = Space(500)
    MyRetrun = GetPrivateProfileString("DataType", "date", "", str1, 500, gstrConfigFile)
    str1 = Trim(str1)
    If Len(str1) >= 1 Then str1 = Trim(Mid(str1, 1, Len(str1) - 1))
    XF_FJStringToArray str1, ",", S1
    ReDim mintD(UBound(S1))
    For I = 1 To UBound(S1)
        mintD(I) = Val(S1(I))
    Next
   
    ReadConfig = True
End Function

Public Function GetDataType(pvarType) As String
    '将一个 ADO DataType 对象 归纳为三类
    '"n" 数字
    '"d" 时间，日期
    '"c" 字符串
    Dim I As Integer
    Dim J As Integer
    
    J = 0
    For I = 1 To UBound(mintC)
        If mintC(I) = pvarType Then
            J = 1
            Exit For
        End If
    Next
    If J = 1 Then
        GetDataType = "c"
        Exit Function
    End If
    
    For I = 1 To UBound(mintN)
        If mintN(I) = pvarType Then
            J = 1
            Exit For
        End If
    Next
    If J = 1 Then
        GetDataType = "n"
        Exit Function
    End If
    
    For I = 1 To UBound(mintD)
        If mintD(I) = pvarType Then
            J = 1
            Exit For
        End If
    Next
    If J = 1 Then
        GetDataType = "d"
        Exit Function
    End If
        
    '不能识别的数据类别，返回 ""
    GetDataType = ""
'    Select Case pvarType
'        Case Is = adBigInt, adBoolean, adCurrency, adDecimal, adDouble, adInteger, adNumeric, adSingle, adSmallInt, adTinyInt, adUnsignedBigInt, adUnsignedInt, adUnsignedSmallInt, adUnsignedTinyInt
'            XF_GetDataType = "n"
'        Case Is = adDate, adDBDate, adDBTime, adDBTimeStamp
'            XF_GetDataType = "d"
'        Case Is = adBSTR, adChar, adLongVarChar, adLongVarWChar, adVarChar, adVarWChar, adWChar
'            XF_GetDataType = "c"
'    End Select
End Function