frmnav.frm

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

End Type
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" _
    (ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    psfi As SHFILEINFO, _
    ByVal cbSizeFileInfo As Long, _
    ByVal uFlags As Long) As Long

Private Declare Function ImageList_Draw Lib "comctl32.dll" _
    (ByVal himl&, ByVal i&, ByVal hDCDest&, _
    ByVal x&, ByVal Y&, ByVal FLAGS&) As Long


'----------------------------------------------------------
'Private variables
'----------------------------------------------------------
Private ShInfo As SHFILEINFO

Sub FillFile1WithFiles(ByVal path As String)
'-------------------------------------------
'Scan the selected folder for files
'and add then to the listview
'-------------------------------------------
Dim Item As ListItem
Dim s As String

path = CheckPath(path)    'Add '\' to end if not present
s = Dir(path, vbNormal)
Do While s <> ""
  Set Item = File1.ListItems.Add(, , s)
  Item.Key = path & s
  'Item.SmallIcon = "Folder"
  Item.Text = s
  Item.SubItems(1) = path
  s = Dir
Loop

End Sub
Private Sub Form_Load()
  pic16.Width = (SMALL_ICON) * Screen.TwipsPerPixelX
  pic16.Height = (SMALL_ICON) * Screen.TwipsPerPixelY
  pic32.Width = LARGE_ICON * Screen.TwipsPerPixelX
  pic32.Height = LARGE_ICON * Screen.TwipsPerPixelY
  imgSize.Top = 1920
  Dir1_Change
  AddSnippets
End Sub

Private Sub Form_Resize()
  On Error Resume Next
  Tbs.Move 30 + frmMain.fDock.DockedFormCaptionOffsetLeft("frmNav"), 30 + frmMain.fDock.DockedFormCaptionOffsetTop("frmNav"), Me.ScaleWidth - 60 - frmMain.fDock.DockedFormCaptionOffsetLeft("frmNav") - 60, Me.ScaleHeight - 60 - frmMain.fDock.DockedFormCaptionOffsetTop("frmNav") - 60
  Picture4.Move Tbs.ClientLeft, Tbs.ClientTop, Tbs.ClientWidth, Tbs.ClientHeight
  Picture5.Move Tbs.ClientLeft, Tbs.ClientTop, Tbs.ClientWidth, Tbs.ClientHeight
  picSnippet.Move Tbs.ClientLeft, Tbs.ClientTop, Tbs.ClientWidth, Tbs.ClientHeight
  TagsD.Move 0, 30, Picture5.ScaleWidth, Picture5.ScaleHeight - 30
End Sub

Private Sub Dir1_Change()
Dim path As String

Initialise
path = Dir1.path
FillFile1WithFiles path
GetAllIcons
ShowIcons
End Sub

Private Sub Drive1_Change()
  Dir1.path = Drive1.Drive
End Sub


Private Sub Initialise()
'-----------------------------------------------
'Initialise the controls
'-----------------------------------------------
On Local Error Resume Next

'Break the link to iml lists
File1.ListItems.Clear
File1.icons = Nothing
File1.SmallIcons = Nothing

'Clear the image lists
iml32.ListImages.Clear
iml16.ListImages.Clear

End Sub

Private Sub GetAllIcons()
'--------------------------------------------------
'Extract all icons
'--------------------------------------------------
Dim Item As ListItem
Dim FileName As String

On Local Error Resume Next
For Each Item In File1.ListItems
  FileName = Item.SubItems(1) & Item.Text
  GetIcon FileName, Item.Index
Next

End Sub

Private Function GetIcon(FileName As String, Index As Long) As Long
'---------------------------------------------------------------------
'Extract an individual icon
'---------------------------------------------------------------------
Dim hLIcon As Long, hSIcon As Long    'Large & Small Icons
Dim imgObj As ListImage               'Single bmp in imagelist.listimages collection



'Get a handle to the small icon
hSIcon = SHGetFileInfo(FileName, 0&, ShInfo, Len(ShInfo), _
         BASIC_SHGFI_FLAGS Or SHGFI_SMALLICON)
'Get a handle to the large icon
hLIcon = SHGetFileInfo(FileName, 0&, ShInfo, Len(ShInfo), _
         BASIC_SHGFI_FLAGS Or SHGFI_LARGEICON)

'If the handle(s) exists, load it into the picture box(es)
If hLIcon <> 0 Then
  'Large Icon
  With pic32
    Set .Picture = LoadPicture("")
    .AutoRedraw = True
    ImageList_Draw hLIcon, ShInfo.iIcon, pic32.hDC, 0, 0, ILD_TRANSPARENT
    .Refresh
  End With
  'Small Icon
  With pic16
    Set .Picture = LoadPicture("")
    .AutoRedraw = True
    ImageList_Draw hSIcon, ShInfo.iIcon, pic16.hDC, 0, 0, ILD_TRANSPARENT
    .Refresh
  End With
  Set imgObj = iml32.ListImages.Add(Index, , pic32.Image)
  Set imgObj = iml16.ListImages.Add(Index, , pic16.Image)
End If
End Function
Private Sub ShowIcons()
'-----------------------------------------
'Show the icons in the File1
'-----------------------------------------
On Error Resume Next

Dim Item As ListItem
With File1
  '.ListItems.Clear
  .icons = iml32        'Large
  .SmallIcons = iml16   'Small
  For Each Item In .ListItems
    Item.Icon = Item.Index
    Item.SmallIcon = Item.Index
  Next
End With

End Sub


Private Sub File1_DblClick()
  DoOpen Dir1.path & "\" & File1.SelectedItem.Text
End Sub

Private Sub imgSize_MouseDown(Button As Integer, Shift As Integer, x As Single, Y As Single)
  picSize.Visible = True
End Sub

Private Sub imgSize_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
  Dim nxtY As Long
  If Button = 1 Then
    nxtY = (imgSize.Top + Y)
    If nxtY < 800 Then nxtY = 800
    If nxtY > (Picture4.ScaleHeight - 800) Then nxtY = Picture4.Height - 800
    picSize.Top = nxtY
    imgSize.Move picSize.Left, picSize.Top, picSize.Width, picSize.Height
  End If
End Sub

Private Sub imgSize_MouseUp(Button As Integer, Shift As Integer, x As Single, Y As Single)
  picSize.Visible = False
  Resize
End Sub

Private Sub Resize()
  On Error Resume Next
  imgSize.Left = 0
  imgSize.Width = Picture4.ScaleWidth
  picSize.Move 0, imgSize.Top, imgSize.Width, imgSize.Height
  Drive1.Move 0, 30, Picture4.ScaleWidth
  Dir1.Move 0, Drive1.Top + Drive1.Height + 30, Picture4.ScaleWidth, imgSize.Top - Dir1.Top
  If Dir1.Height > (Picture4.ScaleHeight - 1500) Then Dir1.Height = Picture4.ScaleHeight - 1500
  imgSize.Move 0, Dir1.Top + Dir1.Height, Picture4.ScaleWidth
  File1.Move 0, imgSize.Top + imgSize.Height, Picture4.ScaleWidth, Picture4.Height - (imgSize.Top + imgSize.Height)
End Sub
 
Private Sub Picture1_Click()

End Sub

Private Sub Picture1_Resize()

End Sub

Private Sub lstSnippet_DblClick()
  On Error Resume Next
  Dim fFile As Integer, str As String
  fFile = FreeFile()
  Open App.path & "\snippets\" & lstSnippet.SelectedItem.Text & ".snippet" For Input As #fFile
    str = Input(LOF(fFile), fFile)
  Close #fFile
  Call InsertString(Document(dnum).rt, str)
End Sub

Private Sub lstSnippet_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single)
  On Error Resume Next
    Dim OLEFilename As String, ext As String, file2 As String
    Dim i As Integer
    For i = 1 To Data.Files.Count
        If Data.GetFormat(vbCFFiles) Then
            OLEFilename = Data.Files(i)
        End If
        On Error GoTo errexit
       ext = GetExtension(OLEFilename)
       
       ext = Left(OLEFilename, Len(OLEFilename) - (Len(ext) + 1))
       file2 = StripPath(ext)
       CopyFile OLEFilename, App.path & "\snippets\" & file2 & ".snippet", False
    Next i
    AddSnippets
errexit:
    Exit Sub
End Sub

Private Sub lstSnippet_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, Y As Single, State As Integer)
  On Error Resume Next
    If Not Data.GetFormat(vbCFFiles) Then Effect = vbDropEffectNone
End Sub

Private Sub picSnippet_Resize()
  lstSnippet.Move 0, 0, picSnippet.ScaleWidth, picSnippet.ScaleHeight
End Sub

Private Sub Picture4_Resize()
  Resize
End Sub

Private Sub tagsd_DblClick()
  Dim timedate As String
  On Error Resume Next
  Dim r As CodeSenseCtl.range
  Set r = New CodeSenseCtl.range
  timedate = TagsD.SelectedItem.Text
  Document(dnum).rt.SelText = timedate
  Set r = Document(dnum).rt.GetSel(False)
  Document(dnum).rt.SetCaretPos r.StartLineNo + 1, r.StartColNo + Len(timedate)
  Document(dnum).rt.SetFocus
End Sub

Private Sub tbs_Click()
  Picture4.Visible = False
  Picture5.Visible = False
  picSnippet.Visible = False
  If Tbs.SelectedItem.Index = 1 Then
    Picture4.Visible = True
  ElseIf Tbs.SelectedItem.Index = 2 Then
    Picture5.Visible = True
  ElseIf Tbs.SelectedItem.Index = 3 Then
    picSnippet.Visible = True
  End If
End Sub

Private Sub AddSnippets()
  Dim s As String
  s = Dir(App.path & "\snippets\")
  lstSnippet.ListItems.Clear
  Do Until s = ""
    If Right(s, 7) = "snippet" Then
      lstSnippet.ListItems.Add , , Left(s, Len(s) - 8), 2, 2
    End If
    s = Dir
  Loop
End Sub