mainmod.bas

用VB调用SSH控件

    Dim tmpDrvLet As String
    Dim SectorsPerCluster&, BytesPerSector&, NumberOfFreeClustors&, TotalNumberOfClustors&
    Dim BytesFreeas, BytesTotal, FreeBytes, TotalBytes As Variant
    Dim dl&, lpVolumeSerialNumber&, lpMaximumComponentLength&, lpFileSystemFlags&
    Dim lpVolumeNameBuffer As String, rcDim As String, B As String
    Dim G As String, s$, sz&
    rv = GetLogicalDrives&()
    If rv = 0 Then
        Stop
        Exit Function
    End If
    B = String$(255, 0)
    c = 200
    G = String$(255, 0)
    H = 100
    For Counter = 1 To 26
        CompareTo = (2 ^ (Counter - 1))
        If (rv And CompareTo) <> 0 Then
            vararyDriveInfo(Counter, 1) = True
            tmpDrvLet = Chr(Counter + 64)
            vararyDriveInfo(Counter, 2) = tmpDrvLet
            tmpDrvLet = tmpDrvLet & ":\"
            DriveType = GetDriveType&(tmpDrvLet)
            vararyDriveInfo(Counter, 3) = DriveType
            If DriveType = 3 Or DriveType = 4 Then
                rc = GetVolumeInformation(A, B, c, d, E, F, G, H)
                vararyDriveInfo(Counter, 11) = B
                dl& = GetDiskFreeSpace(tmpDrvLet, SectorsPerCluster, BytesPerSector, NumberOfFreeClustors, TotalNumberOfClustors)
                vararyDriveInfo(Counter, 4) = Format(SectorsPerCluster, "#,0")
                vararyDriveInfo(Counter, 5) = Format(BytesPerSector, "#,0")
                vararyDriveInfo(Counter, 6) = Format(NumberOfFreeClustors, "#,0")
                vararyDriveInfo(Counter, 7) = Format(TotalNumberOfClustors, "#,0")
                TotalBytes = (TotalNumberOfClustors / 100) * (SectorsPerCluster / 100) * (BytesPerSector / 100)
                vararyDriveInfo(Counter, 8) = Format(TotalBytes, "#,0")
                FreeBytes = (NumberOfFreeClustors / 100) * (SectorsPerCluster / 100) * (BytesPerSector / 100)
                vararyDriveInfo(Counter, 9) = Format(FreeBytes, "#,0")
                vararyDriveInfo(Counter, 10) = Format(FreeBytes / TotalBytes, "Percent")
            End If
        Else      ' *** no drive? then set to false
            vararyDriveInfo(Counter, 1) = False
        End If
    Next Counter
End Function

Public Function PrintText(Texty As String)
    Dim lPrinter As Long
    Dim lRet As Long
    Dim lDoc As Long
    Dim udtDocInfo As DOCINFO
    Dim lWritten As Long
    
    lRet = OpenPrinter(Printer.DeviceName, lPrinter, 0)
    If lRet = 0 Then
        Exit Function
    End If
    
    udtDocInfo.pDocName = "-"
    udtDocInfo.pOutputFile = vbNullString
    udtDocInfo.pDatatype = vbNullString
    lDoc = StartDocPrinter(lPrinter, 1, udtDocInfo)
    Call StartPagePrinter(lPrinter)
    lRet = WritePrinter(lPrinter, ByVal Texty, Len(Texty), lWritten)
    lRet = EndPagePrinter(lPrinter)
    lRet = EndDocPrinter(lPrinter)
    lRet = ClosePrinter(lPrinter)
End Function

Public Function SetCursorP(X, Y)
    SetCursorPos X, Y
End Function

Public Function GetCursorX()
    Dim dl&
    dl& = GetCursorPos(pt)
    GetCursorX = pt.X
End Function

Public Function GetCursorY()
    Dim dl&
    dl& = GetCursorPos(pt)
    GetCursorY = pt.Y
End Function

Public Function OpenCDROM()
    SendMCIString "set cd door open", True
End Function

Public Function CloseCDROM()
    SendMCIString "set cd door closed", True
End Function

' Return True if the Ctrl key is pressed.
Function CtrlKey() As Boolean
    CtrlKey = (GetAsyncKeyState(vbKeyControl) And &H8000)
End Function
' Return True if the Shift key is pressed.

Function ShiftKey() As Boolean
    ShiftKey = (GetAsyncKeyState(vbKeyShift) And &H8000)
End Function
' Return True if the Alt key is pressed.

Function AltKey() As Boolean
    AltKey = (GetAsyncKeyState(vbKeyMenu) And &H8000)
End Function
' Return True if a given key is pressed.

Public Function KeysPressed(ByVal KeyCode1 As KeyCodeConstants, Optional ByVal KeyCode2 As KeyCodeConstants, Optional ByVal KeyCode3 As KeyCodeConstants) As Boolean
    If GetAsyncKeyState(KeyCode1) >= 0 Then Exit Function
    If KeyCode2 = 0 Then KeysPressed = True: Exit Function
    If GetAsyncKeyState(KeyCode2) >= 0 Then Exit Function
    If KeyCode3 = 0 Then KeysPressed = True: Exit Function
    If GetAsyncKeyState(KeyCode3) >= 0 Then Exit Function
    KeysPressed = True
End Function
' Read the state of CapsLock.

Public Function GetCapsLock() As Boolean
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' for toggle keys, bit 0 reflects the cu
    '     rrent state
    GetCapsLock = (keystat(vbKeyCapital) And 1)
End Function
' Modify the state of CapsLock.

Public Function SetCapsLock(ByVal newValue As Boolean)
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' modify bit 0 of the relevant item, and
    '     store back
    keystat(vbKeyCapital) = (keystat(vbKeyCapital) And &HFE) Or (newValue And 1)
    SetKeyboardState keystat(0)
End Function
' Read the state of ScrollLock.

Public Function GetScrollLock() As Boolean
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' for toggle keys, bit 0 reflects the cu
    '     rrent state
    GetScrollLock = (keystat(vbKeyScrollLock) And 1)
End Function
' Modify the state of ScrollLock.

Public Function SetScrollLock(ByVal newValue As Boolean)
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' modify bit 0 of the relevant item, and
    '     store back
    keystat(vbKeyScrollLock) = (keystat(vbKeyScrollLock) And &HFE) Or (newValue And 1)
    SetKeyboardState keystat(0)
End Function
' Read the state of NumLock.

Public Function GetNumLock() As Boolean
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' for toggle keys, bit 0 reflects the cu
    '     rrent state
    GetNumLock = (keystat(vbKeyNumlock) And 1)
End Function
' Modify the state of NumLock.

Public Function SetNumLock(ByVal newValue As Boolean)
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' modify bit 0 of the relevant item, and
    '     store back
    keystat(vbKeyNumlock) = (keystat(vbKeyNumlock) And &HFE) Or (newValue And 1)
    SetKeyboardState keystat(0)
End Function
' Read the state of Insert Key.

Public Function GetInsertKey() As Boolean
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' for toggle keys, bit 0 reflects the cu
    '     rrent state
    GetInsertKey = (keystat(vbKeyInsert) And 1)
End Function
' Modify the state of Insert key.

Public Function SetInsertKey(ByVal newValue As Boolean)
    ' get current state of all 256 virtual k
    '     eys
    Dim keystat(0 To 255) As Byte
    GetKeyboardState keystat(0)
    ' modify bit 0 of the relevant item, and
    '     store back
    keystat(vbKeyInsert) = (keystat(vbKeyInsert) And &HFE) Or (newValue And 1)
    SetKeyboardState keystat(0)
End Function

Public Function GetPrivateString(PathName As String, IDLocation As String, VariableName As String)
    sString = String(100, "*")
    lLength = Len(sString)
    GetPrivateProfileString IDLocation, VariableName, vbNullString, sString, lLength, PathName
    GetPrivateString = sString
End Function

Public Sub SetPrivateString(PathName As String, IDLocation As String, VariableName As String, VariableSet As String)
    WritePrivateProfileString IDLocation, VariableName, VariableSet, PathName
End Sub

Public Function CallCache(SaveToFlag As Integer, SpkfileName As String, FiletoCache As String)
    WavCache(SaveToFlag) = PrecacheSound(SpkfileName, FiletoCache)
End Function

Public Function PakValid(PakFileName As String) As Boolean
    Header = String$(Len(MainHeader), Chr$(0))
    FileNumber = FreeFile
    Open PakFileName For Binary As FileNumber
        Get FileNumber, 1, Header
        If Header = MainHeader Then PakValid = True Else PakValid = False
    Close FileNumber
End Function

Function PrecacheSound(PakFile As String, FileToPrecache As String) As String
    If PakValid(PakFile) = True Then
        FileNumber = FreeFile
        Open PakFile For Binary As FileNumber
            Get FileNumber, Len(MainHeader) + 1, FileListStart
            If FileListStart = 0 Then
                Close FileNumber
                Exit Function
            Else
                Do
                    Get FileNumber, FileListStart, Offset
                    FileListStart = FileListStart + 4: OffSetTypes(DoCount) = Offset
                    
                    Get FileNumber, FileListStart, Size
                    FileListStart = FileListStart + 4: SizeTypes(DoCount) = Size
                    
                    Name = String$(255, Chr$(0))
                    Get FileNumber, FileListStart, Name
                    Name = Mid(Name, 1, InStr(1, Name, Chr$(0)) - 1)
                    FileListStart = FileListStart + (Len(Name) + 1): DoCount = DoCount + 1
                    
                    If UCase(Name) = UCase(FileToPrecache) Then
                        Buffload = Space(SizeTypes(DoCount - 1))
                        Get FileNumber, OffSetTypes(DoCount - 1), Buffload
                        PrecacheSound = Buffload
                    End If
                    
                Loop Until FileListStart > LOF(FileNumber)
            End If
        Close FileNumber
    End If
End Function

Public Function SOUNDPRECACHEFileCount(PakFile As String) As Long
    DoCount = 0
    If PakValid(PakFile) = True Then
        FileNumber = FreeFile
        Open PakFile For Binary As FileNumber
            Get FileNumber, Len(MainHeader) + 1, FileListStart
            If FileListStart = 0 Then
                Close FileNumber
                Exit Function
            Else
                FileCountTemp = 1
                Do
                    Get FileNumber, FileListStart, Offset
                    FileListStart = FileListStart + 4
                    
                    If DoCount = 0 Then
                        OffSetTypes(DoCount) = Offset
                    ElseIf DoCount > 0 Then
                        If OffSetTypes(0) = Offset Then SOUNDPRECACHEFileCount = FileCountTemp - 1: Close FileNumber: Exit Function
                        OffSetTypes(DoCount) = Offset: FileCountTemp = FileCountTemp + 1
                    End If
                    
                    Get FileNumber, FileListStart, Size
                    FileListStart = FileListStart + 4: SizeTypes(DoCount) = Size
                    
                    Name = String$(255, Chr$(0))
                    Get FileNumber, FileListStart, Name
                    
                    Name = Mid(Name, 1, InStr(1, Name, Chr$(0)) - 1)
                    FileListStart = FileListStart + Len(Name) + 1: DoCount = DoCount + 1