module3.bas

一款反编译VFP程序的代码的工具

Attribute VB_Name = "Module3"
Option Explicit

Const MAX_PATH As Long = 260

Private 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

Private Const OFN_READONLY = &H1
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_SHOWHELP = &H10
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOLONGNAMES = &H40000
Private Const OFN_EXPLORER = &H80000
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_LONGNAMES = &H200000

Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Const SWP_NOMOVE = &H2
Const SWP_NOSIZE = &H1
Private Const GWL_EXSTYLE = (-20)
Private Const WS_EX_CLIENTEDGE = &H200
Private Const WS_EX_STATICEDGE = &H20000
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOACTIVATE = &H10
Private Const SWP_NOZORDER = &H4
Public Function File_Dialog(frmForm As Form, bSaveDialog As Boolean, ByVal sTitle As String, ByVal sFilter As String, Optional ByVal sFileName As String, Optional ByVal sExtention As String, Optional ByVal sInitDir As String) As String
    Dim OFN As OPENFILENAME, lReturn As Long
    frmForm.Enabled = False
    sFileName = sFileName + String(MAX_PATH - Len(sFileName), 0)
    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = frmForm.hWnd
        .hInstance = App.hInstance
        .lpstrFilter = Replace(sFilter, "|", chr$(0))
        .lpstrFile = sFileName
        .nMaxFile = MAX_PATH
        .lpstrFileTitle = Space$(MAX_PATH - 1)
        .nMaxFileTitle = MAX_PATH
        .lpstrInitialDir = sInitDir
        .lpstrTitle = sTitle
        .Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_CREATEPROMPT
        .lpstrDefExt = sExtention
    End With
    If bSaveDialog Then lReturn = GetSaveFileName(OFN) Else lReturn = GetOpenFileName(OFN)
    If lReturn <> 0 Then File_Dialog = Left$(OFN.lpstrFile + vbNullChar, InStr(1, OFN.lpstrFile + vbNullChar, vbNullChar) - 1)
    frmForm.Enabled = True
End Function
Public Sub RID_FILE(ByVal sFileName As String)
    If File_Exists(sFileName) Then
        SetAttr sFileName, vbNormal
        Kill sFileName
    End If
End Sub
Public Function FILE_TITLE_ONLY(sFileName As String, Optional bReturnDirectory As Boolean) As String
    FILE_TITLE_ONLY = IIf(bReturnDirectory, Left$(sFileName, InStrRev(sFileName, "\")), Right$(sFileName, Len(sFileName) - InStrRev(sFileName, "\")))
End Function
Public Function File_Exists(sFileName As String) As Boolean
On Error GoTo Errs
    If sFileName <> "" Then File_Exists = (dir(sFileName, vbNormal Or vbReadOnly Or vbHidden Or vbSystem Or vbArchive) <> "")
    Exit Function
Errs:
    File_Exists = False
    
End Function
Public Function GetFileInName(ShowText As String, Filter As String, Optional sFileName As String = "") As String
    Dim FileName As String
    FileName = File_Dialog(form1, False, ShowText, Filter, sFileName)
    If FileName = "" Then Exit Function
    If FileLen(FileName) = 0 Then Exit Function
    GetFileInName = FileName
End Function
Public Function GetFileOutName(ShowText As String, Filter As String) As String
    Dim FileName As String
    FileName = File_Dialog(form1, False, ShowText, Filter)
    If FileName = "" Then Exit Function
    GetFileOutName = FileName
End Function
Public Function ShortPath(ByVal strFileName As String) As String
    Dim strBuffer As String * 255
    Dim lngReturnCode As Long
    lngReturnCode = GetShortPathName(strFileName, strBuffer, 255)
    ShortPath = Left$(strBuffer, lngReturnCode)
End Function
Public Function DirExists(ByVal strDirName As String) As Boolean
    On Error Resume Next

    DirExists = (GetAttr(strDirName) And vbDirectory) = vbDirectory

    Err.Clear
End Function
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 Flatten(ByVal frm As Form)
  Dim Ctl As Control
  For Each Ctl In frm.Controls
    Select Case TypeName(Ctl)
      Case "CommandButton", "TextBox", "ListBox", "FileTree", "TreeView", "ProgressBar", "ListView", "VScrollBar", "PictureBox"
        FlatBorder Ctl.hWnd
    End Select
  Next
End Sub
Function GetFileName(FileName As String) As String
'returns filename.ext from drive:\path\path\etc\filename.ext or path\path\path\filename.ext
  Dim I As Integer
  Dim Tmp As String
  GetFileName = FileName
  For I = 1 To Len(FileName)
    Tmp = Right$(FileName, I)
    If Left$(Tmp, 1) = "\" Then
      GetFileName = Mid$(Tmp, 2)
      Exit For
    End If
  Next
End Function

Function GetFileExtension(FileName As String, Optional LowerCase As Boolean = True) As String
' Returns .ext of filename.ext. If lowercase = true (default) then it will be _
  converted to small chars
  Dim I As Integer
  GetFileExtension = FileName     ' Just in case there is no "." in the file
  For I = 1 To Len(FileName)
      If Mid$(FileName, Len(FileName) - I, 1) = "." Then
        GetFileExtension = Mid$(FileName, Len(FileName) - I)
        Exit For
      End If
  Next
  If (LowerCase) Then GetFileExtension = LCase$(GetFileExtension)
End Function

Function GetFileNoExtension(FileName As String) As String
' Returns filename from drive:\path\path\filename.ext or filename.ext
  Dim I As Integer
  GetFileNoExtension = FileName     ' Just in case there is no "." in the file
  For I = 1 To Len(FileName)
    If Mid$(FileName, Len(FileName) - I, 1) = "." Then
      GetFileNoExtension = Mid$(FileName, 1, Len(FileName) - (I + 1))
      Exit For
    End If
  Next
End Function

Function GetFilePath(FileName As String, Optional IncludeDrive As Boolean = True) As String
' returns full path. drive can be excluded if needed
  GetFilePath = FileName
  If (Not IncludeDrive) Then FileName = Right$(FileName, Len(FileName) - 3)
  Dim I As Integer
  GetFilePath = FileName     ' Just in case there is no "\" in the file
  For I = 1 To Len(FileName)
    If Mid$(FileName, Len(FileName) - I, 1) = "\" Then
      GetFilePath = Mid$(FileName, 1, Len(FileName) - (I + 1))
      Exit For
    End If
  Next
End Function

Function GetDrive(FileName As String, Optional IncludeSlash As Boolean = False) As String
' returns lowercase drive .. with or without \
  Dim iLenght As Integer
  If (IncludeSlash) Then iLenght = 3 Else iLenght = 2
  GetDrive = LCase$(Left$(FileName, iLenght))
End Function