modannex.bas

一个VB编写的

Attribute VB_Name = "modAnnexModl"
Option Explicit

'-----
Public Const AkaIro As Long = &HA0A0FF      '愒怓
Public Const AoIro As Long = &HFFC0C0       '惵怓
Public Const KiIro As Long = &HC0FFFF       '墿怓
Public Const HaiIro As Long = &H8000000F    '奃怓
Public Const Makkakka As Long = &HFF&       '恀愒
Public Const DaidaiIro As Long = &H80C0FF   '烌怓
Public Const KuroIro As Long = &H0&         '崟怓
Public Const SiroIro As Long = &HFFFFFF     '敀怓
Public Const MidoriIro As Long = &HC0FFC0   '椢怓
Public Const MizuIro As Long = &HFFFFC0     '悈怓
Public Const SiroHai As Long = &HE0E0E0     '敀奃怓
'-----
Public iniFile$ 'ini僼傽僀儖(僼儖僷僗)

Public SysDir$
Public TmpDir$
Public ParDir$
Public DatDir$
Public TDatDir$
Public SDatDir$
Public IniDirFName$ '儗僕僗僩儕曐懚応強
Public IniTstName$  '帋尡柤徧(Hai Sen Hip... etc.)

Public RekeyFlag As Integer '(0:忦審擖椡 1:帋尡屻)


'------API
Public n_Windir As String * 255
Public n_Crtdir As String * 255
Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Declare Function GetCurrentDirectory Lib "kernel32.dll" Alias "GetCurrentDirectoryA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Long) As Long

Declare Function GetPrivateProfileInt Lib "kernel32" Alias "GetPrivateProfileIntA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal nDefault As Long, ByVal lpFileName As String) As Long
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
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

' 僋儔僗柤偲僞僀僩儖偱僂傿儞僪僂傪専嶕偟僂傿儞僪僂僴儞僪儖傪庢摼偡傞
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'僇儗儞僩僗儗僢僪偺幚峴傪巜掕偺帪娫偩偗拞抐偡傞
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

'***************************************
'*        ini僼傽僀彂偒崬傒
'***************************************
Private Function ReadIniString(path As String, title As String, keyword As String) As String
    Dim StrBuf As String * 100          'GetPrivateProfileString偺暥帤楍庢摼僄儕傾
    Dim length As Long, WK As String
    StrBuf = ""
    
    length = GetPrivateProfileString(title, keyword, "", StrBuf, 100, path)
        WK = StrConv(StrBuf, vbFromUnicode)
        WK = LeftB(WK, length)
        WK = StrConv(WK, vbUnicode)
    ReadIniString = WK 'Left(StrBuf, length)

End Function

'***************************************
'*      ini僼傽僀儖撉崬傒(Long)
'***************************************
Private Function ReadIniLong(path As String, title As String, keyword As String) As Long
    
    ReadIniLong = GetPrivateProfileInt(title, keyword, 0, path)

End Function

'***************************************
'*     ini僼傽僀儖撉崬傒(String)
'***************************************
Private Function WriteIniString(path As String, title As String, keyword As String, writedata As String) As Long
    
    WriteIniString = WritePrivateProfileString(title, keyword, writedata, path)

End Function

'***************************************
'*         奺僼僅儖僟嶌惉
'***************************************
Public Sub DataFolderGenerate(sBasyo As String)
    Dim gRET As Integer
    
    If sBasyo = "" Then
        SysDir$ = App.path
    Else
        SysDir$ = sBasyo
    End If
    
    gRET = DataFolder(SysDir$ + "\TEMP")    'TEMP
    gRET = DataFolder(SysDir$ + "\PARA")    'PARA
    gRET = DataFolder(SysDir$ + "\DATA")    'DATA
End Sub

'***************************************
'*         ini僼傽僀儖柤嶌惉
'***************************************
Public Function iniFileGenerate(sTesTName As String, sBasyo As String) As String
    
    If Right(sBasyo, 1) = "\" Then
        iniFileGenerate = sBasyo + sTesTName + ".ini"
    Else
        iniFileGenerate = sBasyo + "\" + sTesTName + ".ini"
    End If

End Function

'***************************************
'*   慜夞偺僼僅乕儉偺埵抲傪撉傒崬傓
'***************************************
Public Sub TestForm_Input(oForm As Object)
    Dim gRET As Long
    Dim Pt_Top As Single, Pt_Left As Single
    Dim sForm As String
    
    sForm = oForm.Name
    
    Pt_Top = ReadIniLong(iniFile$, oForm.Caption, "Top")
    Pt_Left = ReadIniLong(iniFile$, oForm.Caption, "Left")
    
    If (Pt_Top < 0) Or (Pt_Top > 16000) Then Pt_Top = 0
    If (Pt_Left < 0) Or (Pt_Left > 16000) Then Pt_Left = 0
    
    oForm.Top = Pt_Top
    oForm.Left = Pt_Left
End Sub

'***************************************
'*   廔椆帪偺僼僅乕儉偺埵抲傪彂偒崬傓
'***************************************
Public Sub TestForm_OutPut(oForm As Object)
    Dim gRET As Long
    Dim Pt_Top As Single, Pt_Left As Single
    Dim sForm As String
    
    sForm = oForm.Name
    Pt_Top = oForm.Top
    Pt_Left = oForm.Left
    
    If (Pt_Top < 0) Or (Pt_Top > 16000) Then Pt_Top = 0
    If (Pt_Left < 0) Or (Pt_Left > 16000) Then Pt_Left = 0
    
    gRET = WriteIniString(iniFile$, oForm.Caption, "Top", CStr(Pt_Top))
    gRET = WriteIniString(iniFile$, oForm.Caption, "Left", CStr(Pt_Left))
End Sub

'***************************************
'*  丂丂 僼僅乕儉傪拞墰埵抲偵偡傞
'***************************************
Public Sub TestForm_Center(oForm As Form)
    Dim ScHe As Integer
    Dim ScWi As Integer
    
    ScHe = Screen.Height
    ScWi = Screen.Width
    oForm.Move (ScWi \ 2) - (oForm.Width \ 2), (ScHe \ 2) - (oForm.Height \ 2)

End Sub

'***********************************
'* 丂僼傽僀儖柤梡嬛巭暥帤敳偒庢傝
'***********************************
Public Sub ufFileChkFName(ByRef Name As String)

End Sub

'***********************************
'*  丂丂 暥帤悢帤寘崌傢偣
'***********************************
Public Function plcFormat(nData As Variant, nPlace As String, nNum As Integer) As String
    Dim iWK As Integer, sWK As Single, WK As String
    iWK = Val(nPlace)
    If iWK = 0 Then
        sWK = Val(nData)
        plcFormat = Right(Space(nNum) + Format(sWK, nPlace), nNum)
    Else
        WK = StrConv(nData + Space(nNum), vbFromUnicode)
        WK = LeftB(WK, nNum)
        WK = StrConv(WK, vbUnicode)
        plcFormat = WK
    End If
End Function

'******************************
'*   僼僅儖僟偺妋擣偲愝掕
'******************************
Public Sub DataFolderPrepare(sParental As String, sChild As String, _
                             sComplete As String, ANew As Boolean)
    Dim J As Integer
    Dim RET1 As Integer

    '怴婯-----
    ANew = False '偡偱偵偁傞
    '僨傿儗僋僩儕乕愝掕-----
    sComplete = sParental + "\" + sChild
    RET1 = DataFolder(sComplete)      'sParental + "\" + sChild
    If RET1 = 1 Then    '僼僅儖僟偑懚嵼偟側偐偭偨(弶婜偲擣幆)
        ANew = True '怴婯-----
    End If

End Sub

'******************************
'*   巊梡僼僅儖僟偺妋擣偲愝掕
'******************************
Public Sub DataFolderConfirm()
    
    TmpDir$ = ReadIniString(iniFile$, "Directory", "TmpDir")
    ParDir$ = ReadIniString(iniFile$, "Directory", "ParDir")
    DatDir$ = ReadIniString(iniFile$, "Directory", "DatDir")
    TDatDir$ = ReadIniString(iniFile$, "Directory", "TDatDir")
    SDatDir$ = ReadIniString(iniFile$, "Directory", "SDatDir")
    
    If TmpDir$ = "" Then TmpDir$ = SysDir$ + "\TEMP"
    If ParDir$ = "" Then ParDir$ = SysDir$ + "\PARA"
    If DatDir$ = "" Then DatDir$ = SysDir$ + "\DATA"
    If TDatDir$ = "" Then TDatDir$ = SysDir$
    If SDatDir$ = "" Then SDatDir$ = SysDir$

End Sub

'******************************
'*   巊梡僼僅儖僟偺峏怴
'******************************
Public Sub DataFolderUpdate()
    
    Dim gRET As Long
    
    gRET = WriteIniString(iniFile$, "Directory", "TmpDir", TmpDir$)
    gRET = WriteIniString(iniFile$, "Directory", "ParDir", ParDir$)
    gRET = WriteIniString(iniFile$, "Directory", "DatDir", DatDir$)
    gRET = WriteIniString(iniFile$, "Directory", "TDatDir", TDatDir$)
    gRET = WriteIniString(iniFile$, "Directory", "SDatDir", SDatDir$)

End Sub

'******************************
'*  嶌嬈僼僅儖僟偺妋擣仌嶌惉
'******************************
Private Function DataFolder(N As String) As Integer
    Dim WK As String
    Dim FileNumB1 As Integer
    On Error GoTo NotFolder
    
    '-----
    WK = N
    FileNumB1 = FreeFile
    Open WK + "\TEST.$$$" For Output As #FileNumB1
    Close #FileNumB1
    Kill WK + "\TEST.$$$"
    On Error GoTo 0
    DataFolder = 0
Exit Function
    
    
NotFolder:
    On Error GoTo 0
    Close #FileNumB1
    MkDir WK
    DataFolder = 1
End Function

'***********************************
'*       擖椡抣偺斖埻妋擣
'***********************************
Public Function ufTextErrSearch(Name As String, param As Variant, _
                            Max As Single, xCmp As String, Min As Single, nCmp As String, UGNG As String, _
                            oForm As Object, oText As Object) As Boolean
    Dim oKomoku As Object, RET As Integer
    
    ufTextErrSearch = True
    
    Set oKomoku = oText
    
    Select Case xCmp
    Case ">=", "=>"     '嵟戝偑埲忋偱偁傞-----
        Select Case nCmp