modgeneral.bas

非常有用得编辑器软件源码

Attribute VB_Name = "modGeneral"
Option Explicit

Dim i  As Integer
Public K() As cControlFlater

Public Sub AlwaysOnTop(myfrm As Form, SetOnTop As Boolean)

    Dim lFlag As Integer
    
    If SetOnTop Then
        lFlag = HWND_TOPMOST
    Else
        lFlag = HWND_NOTOPMOST
    End If
    SetWindowPos myfrm.hwnd, lFlag, _
    myfrm.Left / Screen.TwipsPerPixelX, _
    myfrm.Top / Screen.TwipsPerPixelY, _
    myfrm.Width / Screen.TwipsPerPixelX, _
    myfrm.Height / Screen.TwipsPerPixelY, _
    SWP_NOACTIVATE Or SWP_SHOWWINDOW
End Sub

Public Sub FlatBorder(ByVal hwnd As Long)

  Dim TFlat As Long

    TFlat = GetWindowLong(hwnd, GWL_EXSTYLE)
    TFlat = TFlat And Not WS_EX_CLIENTEDGE Or WS_EX_STATICEDGE
    SetWindowLong hwnd, GWL_EXSTYLE, TFlat
    SetWindowPos hwnd, 0, 0, 0, 0, 0, SWP_NOACTIVATE Or SWP_NOZORDER Or SWP_FRAMECHANGED Or SWP_NOSIZE Or SWP_NOMOVE

End Sub

Public Sub FlattenAll(ByVal Frm As Form)

  Dim CTL As Control

    For Each CTL In Frm.Controls
        Select Case TypeName(CTL)
          Case "CommandButton", "ComboBox", "TextBox", "ListBox", "FileTree", "TreeView", "ProgressBar", "PictureBox"
            FlatBorder CTL.hwnd
        End Select
    Next CTL

End Sub

Public Sub Flatten(ByVal Frm As Form)

  Dim CTL As Control

    For Each CTL In Frm.Controls
        Select Case TypeName(CTL)
          Case "CommandButton", "TextBox", "ProgressBar"
            FlatBorder CTL.hwnd
        End Select
    Next CTL

End Sub

Public Sub FlattenSpc(ByVal Frm As Form, TypeN As String)

  Dim CTL As Control

    For Each CTL In Frm.Controls
        Select Case LCase(TypeName(CTL))
          Case LCase(TypeN)
            FlatBorder CTL.hwnd
        End Select
    Next CTL

End Sub

Sub FlatAllControls(Frm As Form)

  Dim CTL As Control

    ReDim Preserve K(0 To Frm.Controls.Count)
    
    For Each CTL In Frm.Controls
        On Error Resume Next
          Select Case TypeName(CTL)
            Case "CommandButton", "TextBox", "ComboBox", "ImageCombo", "HScrollBar", "ListBox"
              Set K(i) = New cControlFlater
              K(i).Attach CTL
              i = i + 1
          End Select
      Next CTL

End Sub
 
Sub FlatControls(Frm As Form)

  Dim CTL As Control

    ReDim Preserve K(0 To Frm.Controls.Count)
    
    For Each CTL In Frm.Controls
        On Error Resume Next
          Select Case TypeName(CTL)
            Case "ComboBox", "ImageCombo"
              Set K(i) = New cControlFlater
              K(i).Attach CTL
              i = i + 1
          End Select
      Next CTL

End Sub

Sub SetIconMenu(Frm As Form, iml As ImageList, IM As PopMenu)
IM.ImageList = iml
IM.SubClassMenu Frm
Dim c As Control
For Each c In Frm.Controls
    If TypeName(c) = "Menu" Then
        On Error Resume Next
        IM.ItemIcon(c.Name) = iml.ListImages(LCase(c.Name)).Index - 1
    End If
Next
End Sub

Sub MsgErr()

    MsgBox Err.Description, vbCritical, "Error Number: " & Err.Number

End Sub

Function StripTerminator(ByVal strString As String) As String

  Dim intZeroPos As Integer

    intZeroPos = InStr(strString, Chr$(0))

    If intZeroPos > 0 Then
        StripTerminator = Left$(strString, intZeroPos - 1)
      Else
        StripTerminator = strString
    End If

End Function

Sub AddDirSep(strPathName As String)

    If Right$(Trim$(strPathName), Len("/")) <> "/" And _
       Right$(Trim$(strPathName), Len("\")) <> "\" Then
        strPathName = RTrim$(strPathName) & "\"
    End If

End Sub

Function GetWindowsSysDir() As String

  Dim strBuf As String

    strBuf = Space$(255)

    '
    'Get the system directory and then trim the buffer to the exact length
    'returned and add a dir sep (backslash) if the API didn't return one
    '
    If GetSystemDirectory(strBuf, 255) > 0 Then
        strBuf = StripTerminator(strBuf)
        AddDirSep strBuf
        
        GetWindowsSysDir = strBuf
      Else
        GetWindowsSysDir = vbNullString
    End If

End Function

Sub Install(ByVal DllName As String)

    On Error GoTo 2
    FileCopy App.Path & "\" & DllName, GetWindowsSysDir & DllName
2

    Shell "regsvr32 " & DllName & " /s"

End Sub

Public Sub SaveOption(ByVal Section As String, ByVal Value As Variant)

    SaveSet App.ProductName, "option", Section, Value

End Sub

Public Function GetOption(ByVal Section As String, Optional ByVal Default As String)

    GetOption = GetSet(App.ProductName, "option", Section, Default)

End Function

Public Function StripPath(t) As String

  Dim X As Integer
  Dim ct As Integer

    StripPath = t
    X = InStr(t, "\")
    Do While X
        ct = X
        X = InStr(ct + 1, t, "\")
    Loop
    If ct > 0 Then StripPath = Mid$(t, ct + 1)

End Function

Function ReadText(ByVal Filename As String) As String

  Dim iFile, sData

    On Error Resume Next
      iFile = FreeFile
      sData = ""
      Open Filename For Binary As #iFile
      sData = Input$(LOF(iFile), #iFile)
      DoEvents
      Close #iFile
      ReadText = sData

End Function

Sub SaveText(ByVal Filename As String, ByVal OutText As String)

  Dim t As Integer

    t = FreeFile
    Open Filename For Output As #t
    Print #t, OutText
    Close #t

End Sub

Function Convert2VBText(ByVal NormalString As String) As String

    Convert2VBText = AP & Replace$(Replace$(NormalString, AP, AP & AP), vbCrLf, AP & " & vbCrLf & " & AP) & AP

End Function

Function ComparePath(BaseStr As String, TargetStr As String) As String
    
    
    Dim i As Long, j As Long, a As String, b As String
    
    Dim Base As String, Target As String
    Base = Replace$(BaseStr, "\", "/")
    Target = Replace$(TargetStr, "\", "/")
    
    If LCase(Left(Base, 1)) <> LCase(Left(Target, 1)) Then
        ComparePath = "file:///" & Target
        Exit Function
    End If
    
    Dim FindBase1 As Long, FindTarget1 As Long
    Dim FindBase As Long, FindTarget As Long
    
    Dim Out As String
    Dim UnMatchDIR As Integer
    
    Dim Sample As String
    Dim UnMatch As String
    
    Dim BackDIR As Integer
    
    BackDIR = CountSingleString(Base, "/") - CountSingleString(Target, "/")
    If BackDIR > 0 Then UnMatchDIR = BackDIR
    
    For i = 1 To IIf(BackDIR > 0, CountSingleString(Target, "/"), CountSingleString(Base, "/"))
        FindBase = InStr(FindBase + 1, Base, "/")
        FindTarget = InStr(FindTarget + 1, Target, "/")
        
        On Error GoTo 1
            If Mid$(Base, FindBase1 + 1, FindBase - FindBase1 - 1) = Mid$(Target, FindTarget1 + 1, FindTarget - FindTarget1 - 1) And UnMatch <> "true" Then
                'The folder match
                Sample = Mid$(Target, FindTarget + 1)

                Else
                'The folder do not match

                UnMatch = "true"
1                UnMatchDIR = UnMatchDIR + 1
            End If
            
        FindBase1 = FindBase
        FindTarget1 = FindTarget
    Next
            
            Dim Udir As String
            For i = 1 To UnMatchDIR
                Udir = Udir & "../"
            Next
             
            ComparePath = Udir & Sample
    
End Function

Function CountSingleString(Text As String, CountText As String) As Long
    Dim i As Long
    Dim a As String
    Dim c As Long
    c = 0
    For i = 1 To Len(Text)
        a = Mid$(Text, i, 1)
        If a = CountText Then
            c = c + 1
        End If
    Next
    CountSingleString = c
End Function

Sub SelectBox(ByRef Box As TextBox)
Box.SelStart = 0
Box.SelLength = Len(Box.Text)
End Sub

Public Sub StopMIDI(MidiFileName As String)
Call mciSendString("stop " + MidiFileName, 0&, 0, 0)
Call mciSendString("close " + MidiFileName, 0&, 0, 0)
End Sub

Function PlayMIDI(MidiFileName As String)
On Error Resume Next
Call mciSendString("open " + MidiFileName + " type sequencer", 0&, 0, 0)
If mciSendString("play " + MidiFileName + Flags, 0&, 0, 0) = 0 Then
PlayMIDI = 0
Else
PlayMIDI = 1
End If
End Function