frmftp.frm

这是一个完美版本的的超强文件编辑器,支持各种程序的语法高亮,支持插件和宏录制,支持XP菜单,支持浏览器浏览等等功能,记得有位网友做文件编辑器要求我给他一个支持语法高亮和DockWindows技术的代码

    If hConnect <> 0 Then
      TopDir = GetFTPDirectory(hConnect)
      ListDir lstMain
      tbMain.Buttons(3).Enabled = True
      tbMain.Buttons(4).Enabled = True
      tbMain.Buttons(5).Enabled = True
      tbMain.Buttons(9).Enabled = True
      tbMain.Buttons(6).Enabled = True
      tbMain.Buttons(7).Enabled = True
    Else
      
      InternetCloseHandle hConnect
      InternetCloseHandle hSession
      MsgBox "Unable to connect.", vbOKOnly + vbCritical, "Error"
    End If
  Else
    InternetCloseHandle hSession
    MsgBox "Unable to connect.", vbOKOnly + vbCritical, "Error"
  End If
  If FTPInfo.LastDir <> "" Then
    FtpSetCurrentDirectory hConnect, FTPInfo.LastDir
    ListDir lstMain
  End If
End Sub

Private Sub cmdOpen_Click()
  Dim OpenFile As String, Ret As String, FileStr As String, NewOpen As Boolean
  Dim fFile As Integer, FTPInfo As FTP
  NewOpen = False
  Dim file As String
  If hConnect = 0 Or hSession = 0 Then
    If cboAccount.Text = "" Then
      MsgBox "Please select an account to access first.", vbOKOnly + vbCritical, "Error"
      Exit Sub
    End If
    file = App.path & "\accounts\" & cboAccount.Text & ".ftp"
    If Dir(file) = "" Then
      MsgBox "There was an error reading the FTP file."
      Exit Sub
    End If
    fFile = FreeFile()
    Open App.path & "\Accounts\" & cboAccount.Text & ".ftp" For Binary Access Read As #fFile
      Get #fFile, , FTPInfo
    Close #fFile
    URL = FTPInfo.URL
    Port = FTPInfo.PortNum
    User = FTPInfo.UserName
    Pass = Base64Decode(FTPInfo.Password)
    
    If URL = "" Or Port = "" Or User = "" Or Pass = "" Then
      MsgBox "There was an error reading the FTP directory."
      Exit Sub
    End If
 
    SiteName = cboAccount.Text
    hSession = InternetOpen(SiteName, INTERNET_OPEN_TYPE_DIRECT, "", "", INTERNET_FLAG_NO_CACHE_WRITE)
    If hSession <> 0 Then
      hConnect = InternetConnect(hSession, URL, Port, User, Pass, INTERNET_SERVICE_FTP, INTERNET_FLAG_PASSIVE, &H0)
      If hConnect <> 0 Then
        NewOpen = True
      Else
        InternetCloseHandle hConnect
        InternetCloseHandle hSession
        MsgBox "Unable to connect.", vbOKOnly + vbCritical, "Error"
        Exit Sub
      End If
    Else
      InternetCloseHandle hSession
      MsgBox "Unable to connect.", vbOKOnly + vbCritical, "Error"
      Exit Sub
    End If
  If FTPInfo.LastDir <> "" Then
    FtpSetCurrentDirectory hConnect, FTPInfo.LastDir
    ListDir lstMain
  End If
  End If
  
  If cmdOpen.Caption = "&Open" Then
    FileStr = Replace(txtFile.Text, " ", "")
    OpenFile = SplitStr(FileStr, Ret)
    Dim ftpDir As String
    ftpDir = GetFTPDirectory(hConnect)
    If OpenFile = "" Then
      openftp GetFile(txtFile.Text), txtFile.Text, ftpDir, cboAccount.Text
    Else
      Do Until OpenFile = ""
        openftp GetFile(OpenFile), OpenFile, ftpDir, cboAccount.Text
        OpenFile = SplitStr(Ret, Ret)
      Loop
    End If
    Dim cftp As FTP
    cftp.Name = SiteName
    cftp.UserName = User
    cftp.URL = URL
    cftp.PortNum = Port
    cftp.Password = Base64Encode(Pass)
    cftp.LastDir = ftpDir
    Open App.path & "\accounts\" & cftp.Name & ".ftp" For Binary Access Write As #1
      Put #1, , cftp
    Close #1
  Else
    FileStr = Replace(txtFile.Text, " ", "")
    OpenFile = SplitStr(FileStr, Ret)
    If OpenFile = "" Then
      MsgBox OpenFile
      UploadAsString txtFile.Text, Document(dnum).rt.Text
    Else
      MsgBox OpenFile
      UploadAsString OpenFile, Document(dnum).rt.Text
    End If
    cftp.Name = SiteName
    cftp.UserName = User
    cftp.URL = URL
    cftp.PortNum = Port
    cftp.Password = Base64Encode(Pass)
    cftp.LastDir = GetFTPDirectory(hConnect)
    Open App.path & "\accounts\" & cftp.Name & ".ftp" For Binary Access Write As #1
      Put #1, , cftp
    Close #1
  End If
  
  If NewOpen = True Then
    InternetCloseHandle hConnect
    InternetCloseHandle hSession
    hConnect = 0: hSession = 0
  End If
  If chkClose = 1 Then Unload Me
End Sub

Private Sub Form_Load()
  GetAccounts cboAccount
  LoadFormData Me
  FlatBorder cmdConnect.hwnd
  FlatBorder cmdOpen.hwnd
  FlatBorder cmdCancel.hwnd
  FlatBorder txtFilter.hwnd
  FlatBorder txtFile.hwnd
  FlatBorder PB.hwnd
  If cboAccount.ListCount > 0 Then cboAccount.ListIndex = 0
  If cmdOpen.Caption = "&Open" Then
    lstMain.MultiSelect = True
  Else
    lstMain.MultiSelect = False
  End If
End Sub

Private Sub ListDir(lst As ListView, Optional ItemDir As String)
  'On Error GoTo errHandler
  Dim dt As WIN32_FIND_DATA
  Dim hFile As Long, sFile As Long
  Dim LstData As ListItem
  lst.ListItems.Clear
  Dim ftpDir As String
  If hConnect = 0 Or hSession = 0 Then
    MsgBox "You are not connected.", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
  DoEvents
  If ItemDir = "" Then
    ftpDir = GetFTPDirectory(hConnect)
  Else
    ftpDir = ItemDir
  End If
  DoEvents
  LockWindowUpdate lst.hwnd
  lst.ListItems.Add , , "Up a level", 1, 1
  hFile = FtpFindFirstFile(hConnect, txtFilter.Text, dt, INTERNET_FLAG_RELOAD, INTERNET_FLAG_NO_CACHE_WRITE)
  DoEvents
  If hFile Then
    sFile = 1
  
    Do Until sFile = 0
    DoEvents
      If (dt.dwFileAttributes And vbDirectory) Then
        Set LstData = lst.ListItems.Add(, , StripCrap(dt.cFileName), 2, 2)
        LstData.SubItems(1) = "Directory"
        LstData.SubItems(2) = Win32ToVbTime(dt.ftCreationTime)
        LstData.SubItems(3) = Win32ToVbTime(dt.ftLastWriteTime)
        Set LstData = Nothing
      End If
      
      sFile = InternetFindNextFile(hFile, dt)
    Loop
    InternetCloseHandle hFile
    InternetCloseHandle sFile
  End If
  hFile = FtpFindFirstFile(hConnect, txtFilter.Text, dt, INTERNET_FLAG_RELOAD, INTERNET_FLAG_NO_CACHE_WRITE)
  DoEvents
  If hFile Then
  
    sFile = 1
    Do Until sFile = 0
    DoEvents
      If (dt.dwFileAttributes And Not vbDirectory) Then
        Set LstData = lst.ListItems.Add(, , StripCrap(dt.cFileName), 3, 3)
        LstData.SubItems(1) = dt.nFileSizeLow
        LstData.SubItems(2) = Win32ToVbTime(dt.ftCreationTime)
        LstData.SubItems(3) = Win32ToVbTime(dt.ftLastWriteTime)
        Set LstData = Nothing
      End If
      
      sFile = InternetFindNextFile(hFile, dt)
    Loop
  End If
  DoEvents
  lblDir.Caption = GetFTPDirectory(hConnect)
  InternetCloseHandle hFile
  InternetCloseHandle sFile
  LockWindowUpdate 0
  Exit Sub
errhandler:
  FTPError Err.LastDllError, "ListDir"
  LockWindowUpdate 0
  Exit Sub
End Sub

Private Function StripCrap(str As String) As String
  StripCrap = Left(str, InStr(1, str, vbNullChar) - 1)
End Function

Private Sub Form_Unload(Cancel As Integer)
  Dim cftp As FTP
  SaveFormData Me
  If hConnect <> 0 Then
    cftp.Name = SiteName
    cftp.UserName = User
    cftp.URL = URL
    cftp.PortNum = Port
    cftp.Password = Base64Encode(Pass)
    cftp.LastDir = GetFTPDirectory(hConnect)
    Open App.path & "\accounts\" & cftp.Name & ".ftp" For Binary Access Write As #1
      Put #1, , cftp
    Close #1
  End If
  InternetCloseHandle hConnect
  InternetCloseHandle hSession
  hConnect = 0: hSession = 0
End Sub

Private Sub lstMain_Click()
  Dim x As Long, strFiles As String
  strFiles = ""
  
  For x = 1 To lstMain.ListItems.Count
    If lstMain.ListItems(x).SubItems(1) <> "" And lstMain.ListItems(x).Selected = True Then
      If strFiles <> "" Then strFiles = strFiles & " "
      strFiles = strFiles & StrWrap(lstMain.ListItems(x))
    End If
  Next
  txtFile.Text = strFiles
End Sub

Private Sub lstMain_DblClick()
  Dim ftpDir As String
  If hSession = 0 Or hConnect = 0 Then
    MsgBox "Error: You are not connected.", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
  If lstMain.SelectedItem.Index = 1 Then
    ftpDir = GetFTPDirectory(hConnect)
    If ftpDir <> "/" And ftpDir <> "\" Then
      If InStrRev(ftpDir, "/") = 1 Then
        FtpSetCurrentDirectory hConnect, "/"
      Else
        FtpSetCurrentDirectory hConnect, Left(ftpDir, InStrRev(ftpDir, "/") - 1)
      End If
      ListDir lstMain
    End If
    Exit Sub
  End If
  If lstMain.SelectedItem.SubItems(1) = "Directory" Then
    FtpSetCurrentDirectory hConnect, lstMain.SelectedItem.Text
    ListDir lstMain
  Else
    cmdOpen_Click
  End If
End Sub

Private Sub lstMain_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  If Button = 2 Then PopupMenu mnuFile
End Sub

Private Sub mnuAccounts_Click()
  frmAccount.Show vbModal, Me
End Sub

Private Sub mnuChmod_Click()
  Dim sCommand As String, sFile As String
  sCommand = InputStr("Please enter the chmod value. IE: 777", "CHMOD")
  If IsNumeric(sCommand) = False Then
    MsgBox "You must enter a numeric value.", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
  sFile = lstMain.SelectedItem.Text
  If sFile = "" Then
    MsgBox "You must select a file.", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
  FtpCommand hConnect, False, FTP_TRANSFER_TYPE_ASCII, "site chmod " & sCommand & " " & sFile, 0, 0
  ListDir lstMain
End Sub

Private Sub mnuCommand_Click()
  Dim sCommand As String, sFile As String
  sCommand = InputStr("Please enter the command", "Comment")
  sFile = lstMain.SelectedItem.Text
  If sFile = "" Then
    MsgBox "You must select a file.", vbOKOnly + vbCritical, "Error"
    Exit Sub
  End If
  FtpCommand hConnect, False, FTP_TRANSFER_TYPE_ASCII, sCommand & " " & sFile, 0, 0
  ListDir lstMain
End Sub

Private Sub mnuDelete_Click()
      Dim x As Long
      If lstMain.SelectedItem.Text = "" Then Exit Sub
      For x = 1 To lstMain.ListItems.Count
        If lstMain.ListItems(x).Selected = True Then
          If lstMain.SelectedItem.SubItems(1) = "Directory" Then
            DoRun = FtpRemoveDirectory(hConnect, lstMain.ListItems(x))
          Else
            DoRun = FtpDeleteFile(hConnect, lstMain.ListItems(x))
          End If
        End If
      Next
      ListDir lstMain
End Sub

Private Sub mnuMakeDir_Click()
      Dim strCreate As String
      strCreate = InputStr("Please enter the new Directory's title.", "New Directory")
      If strCreate = "" Then Exit Sub
      DoRun = FtpCreateDirectory(hConnect, strCreate)
      If DoRun = 0 Then
        FTPError Err.LastDllError, "Create Directory"
        Exit Sub
      End If
            
      ListDir lstMain
End Sub

Private Sub mnuRefresh_Click()
ListDir lstMain
End Sub

Private Sub mnuRename_Click()
      Dim strRename As String
      strRename = InputStr("Please enter the new filename.", "Rename File", lstMain.SelectedItem.Text)
      If strRename = "" Then Exit Sub
      DoRun = FtpRenameFile(hConnect, lstMain.SelectedItem.Text, strRename)
      If DoRun = 0 Then
        FTPError Err.LastDllError, "Rename"
        Exit Sub
      End If
      ListDir lstMain
End Sub

Private Sub tbMain_ButtonClick(ByVal Button As MSComctlLib.Button)
  Select Case Button.Key
    Case "setup"
      frmAccount.Show vbModal, Me
    Case "refresh"
      ListDir lstMain
    Case "rename"
      mnuRename_Click
    Case "create"
      mnuMakeDir_Click
    Case "delete"
      mnuDelete_Click
    Case "chmod"
      mnuChmod_Click
    Case "command"
      mnuCommand_Click
  End Select
End Sub

Private Function GetFile(str As String) As String
  On Error Resume Next
  Dim hFile As Long, sBuffer As String, Ret As Long, strStore As String, tSize As Long
  tSize = ReturnSize(str)
  PB.Value = 0
  PB.Max = tSize
  If hSession = 0 Or hConnect = 0 Then
    MsgBox "Error: Not connected to a server.", vbOKOnly + vbCritical, "Error"
    Exit Function
  End If
  hFile = FtpOpenFile(hConnect, str, GENERIC_READ, FTP_TRANSFER_TYPE_ASCII, 0)
  If hFile = 0 Then
    MsgBox "Unable to open requested file from FTP server.", vbOKOnly + vbCritical, "Error"
    Exit Function
  End If
  sBuffer = Space(sReadBuffer)
  Do
    InternetReadFile hFile, sBuffer, sReadBuffer, Ret
    If PB.Value + Ret > PB.Max Then PB.Max = PB.Value + Ret
    If Ret < sReadBuffer And PB.Max - Ret > PB.Value Then PB.Max = (PB.Value + Ret)
    PB.Value = PB.Value + Ret
    If Ret <> sReadBuffer Then
      sBuffer = Left$(sBuffer, Ret)
    End If
    strStore = strStore & sBuffer
  Loop Until Ret <> sReadBuffer
  InternetCloseHandle hFile
  GetFile = strStore

End Function

Private Sub UploadAsString(File1 As String, Data As String)
  Dim hFile As Long, sizeLeft As Long, sBuffer As String, Ret As Long
  Dim SaveString As String, currBytes As Long, totalBytes As Long
  SaveString = Data
  currBytes = 0
  totalBytes = Len(Data)
  hFile = FtpOpenFile(hConnect, File1, GENERIC_WRITE, FTP_TRANSFER_TYPE_ASCII, 0)
  Do
    If hFile = 0 Then
      FTPError Err.LastDllError, "UploadAsFile"
      Exit Sub
    End If
    If Len(SaveString) >= sReadBuffer Then
      sBuffer = Left$(SaveString, sReadBuffer)
      SaveString = Mid(SaveString, sReadBuffer + 1)
    Else
      sBuffer = Left$(SaveString, Len(SaveString))
      SaveString = ""
    End If
    sizeLeft = Len(sBuffer)
    If sizeLeft = sReadBuffer Then
      If InternetWriteFile(hFile, sBuffer, sReadBuffer, Ret) = 0 Then
        Exit Do
      End If
    Else
      If InternetWriteFile(hFile, sBuffer, sizeLeft, Ret) = 0 Then
        Exit Do
      End If
    End If
    currBytes = currBytes + Ret
    If currBytes > totalBytes Then totalBytes = currBytes
    DoEvents
    PB.Max = totalBytes
    PB.Value = currBytes
  Loop Until currBytes >= totalBytes
  InternetCloseHandle (hFile)
  Document(dnum).Changed = False
  Document(dnum).Caption = txtFile.Text
  Document(dnum).FTPAccount = cboAccount.Text
  Document(dnum).FileName = txtFile.Text
  Document(dnum).FTP = True
  Document(dnum).ftpDir = CurDir
  Document(dnum).DoAct
  'RaiseEvent Message(MUPLOADED)
End Sub