'新建一窗体，复制下列代码到代码窗口。 '运行时在文本框里输入扩展名，键入回车后即将看到文件图标Dim WithEvents txt As TextBox Private Const MAX_PATH = 260 Private Type SHFILEINFO hIcon As Long ' out: icon iIcon As Long ' out: icon index dwAttributes As Long ' out: SFGAO_ flags szDisplayName As String * MAX_PATH ' out: display name (or path) szTypeName As String * 80 ' out: type name End Type Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long Private Const SHGFI_ICON = &H100 Private Const SHGFI_USEFILEATTRIBUTES = &H10 Private Const FILE_ATTRIBUTE_NORMAL = &H80 Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As LongPrivate Sub Form_Load() Me.ScaleMode = vbPixels Me.AutoRedraw = True Set txt = Me.Controls.Add("VB.TextBox", "TextFileExt") With txt .Left = 0 .Top = 0 .Width = 30 .Height = 15 .MaxLength = 3 .Visible = True End With End SubPrivate Sub txt_KeyPress(KeyAscii As Integer) If KeyAscii = vbKeyReturn Then Dim tmp As SHFILEINFO SHGetFileInfo "abc." & txt.Text, FILE_ATTRIBUTE_NORMAL, tmp, Len(tmp), SHGFI_ICON Or SHGFI_USEFILEATTRIBUTES With tmp Me.Cls DrawIcon Me.hdc, 50, 5, .hIcon lbl = .szDisplayName Me.Refresh End With End If End Sub
'模块 'mdlMailSystem.basAttribute VB_Name = "mdlMailSystem" '───────────────────────────────────────────────────────────────────────────────────────── ' 电子邮件系统 - 模块 '───────────────────────────────────────────────────────────────────────────────────────── Option Explicit '■声明API函数 '─────────────────────────────────────────────────────────────────────────────────────────┐ Public Declare Function ExtractIcon Lib "Shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long '│ '─────────────────────────────────────────────────────────────────────────────────────────┘'──────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────── Private Declare Function SendMessageFind Lib "User32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As LongPrivate Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam 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 WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Declare Function GetDesktopWindow Lib "user32" () As Long Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long '──注册表相关─────────────────┐ Public Const HKEY_CLASSES_ROOT = &H80000000 '│ Private Const REG_SZ = 1 '│ '────────────────────────┘'───附件────────────────────────────────────────────┤ Public SPath As String '│ Public HaveAnnexAtNew As Boolean '发信时有无附件 │ Public HaveAnnexAtGet As Boolean '收到的信有无附件 │ Public ItemClickedMailBox As Boolean 'frmMailBox 中附件列表 lvwAnnex 是否有项目被选中 │ Public ItemClickedNewBox As Boolean 'frmNewMail 中附件列表 lvwAnnex 是否有项目被选中 │ Public ClickedAnnexFileName As String 'frmNewMail 中所选中项目的文件名 │ Public sFileFullPathName() As String '附件文件名 │ Public iCount As Integer '计数器 │ Public hIcon() As Integer '图标索引 │ Public CurrentWindow As String '当前窗口 │ Public RightButton1 As Boolean '是否右键按下 │ Public RightButton2 As Boolean '是否右键按下 │ '│ '─────────────────────────────────────────────────┘Public Sub AddAnnexTolvwAnnex(sFileFullName As String) '将参数sFileFullName所指文件图标添加入附件列表中 Dim FileNameKey As String Dim index As Integer
With frmNewMail HaveAnnexAtNew = True iCount = iCount + 1 ReDim Preserve hIcon(iCount) As Integer ReDim Preserve sFileFullPathName(iCount) As String sFileFullPathName(iCount) = sFileFullName FileNameKey = GetFileNameNoPath(sFileFullPathName(iCount)) .lvwAnnex.Icons = Nothing hIcon(iCount) = AddPicToImageList(sFileFullName, .Picture1, .ImageList2) .lvwAnnex.Icons = .ImageList2 .lvwAnnex.ListItems.Add , , FileNameKey, 1 For index = 1 To .lvwAnnex.ListItems.Count .lvwAnnex.ListItems(index).Icon = hIcon(index) Next End With End Sub
Public Sub OpenFileAddToAnnex() '选择附件文件（可多选），添加到LvwAnnex中 Dim index As Integer Dim path As String With frmNewMail .CommonDialog1.FileName = "" .CommonDialog1.Filter = "所有文件(*.*)|*.*" .CommonDialog1.Flags = cdlOFNExplorer + cdlOFNAllowMultiselect .CommonDialog1.MaxFileSize = 32767 .CommonDialog1.DialogTitle = "选择附件文件" .CommonDialog1.ShowOpen If .CommonDialog1.FileName <> "" Then Dim FilesName() As String FilesName = Split(.CommonDialog1.FileName, Chr(0)) If UBound(FilesName) > 0 Then path = IIf(Len(FilesName(0)) = 3, FilesName(0), FilesName(0) & "\") For index = 1 To UBound(FilesName) AddAnnexTolvwAnnex path & FilesName(index) Next Else AddAnnexTolvwAnnex FilesName(0) End If End If End With End SubPublic Function GetFileNameNoPath(FileFullPathName As String) As String '从文件全路径名中去除路径 Dim pos As Integer pos = InStrRev(FileFullPathName, "\") If pos <> 0 Then GetFileNameNoPath = Mid(FileFullPathName, pos + 1) Else GetFileNameNoPath = FileFullPathName End If End FunctionPublic Function GetFileEtc(FileName As String) As String '获取文件扩展名 Dim pos As String pos = InStrRev(FileName, ".") If pos <> 0 Then GetFileEtc = Mid(FileName, pos): Exit Function GetFileEtc = "" End FunctionPublic Function GetFileIconStr(FileEtc As String) As String '获取文件的图标文件 Dim FileTypeKey As String Dim tmp As String FileTypeKey = ReadRegValue(HKEY_CLASSES_ROOT, FileEtc, "") If FileTypeKey <> "" Then GetFileIconStr = ReadRegValue(HKEY_CLASSES_ROOT, FileTypeKey & "\DefaultIcon", "") Else GetFileIconStr = "" End If End Function
'继续模块Public Function ReadRegValue(MainRoot As Long, SubKey As String, KeyValue As String) As String '从注册表中读取键值 Dim hResult As Long Dim buffer As String Dim pos As Integer buffer = String(1024, " ") RegOpenKeyEx MainRoot, SubKey, 0, 0, hResult RegQueryValueEx hResult, KeyValue, 0&, REG_SZ, ByVal buffer, 1024 pos = InStr(1, buffer, Chr(0)) If pos <> 0 Then ReadRegValue = Left(buffer, pos - 1) Else ReadRegValue = "" End If End FunctionPublic Function GetINISet(sINIFileName As String, sAppName As String, sKeyName As String) As String '读取配置文件内容 Dim RetStr As String * 255 Dim pos As Integer GetPrivateProfileString sAppName, sKeyName, "", RetStr, 255, sINIFileName pos = InStr(1, RetStr, Chr(0)) If pos <> -1 Then GetINISet = Left(RetStr, pos - 1) Else GetINISet = "" End If End FunctionPublic Sub SetINIValue(sINIFileName As String, sAppName As String, sKeyName As String, sValue As String) '写配置文件 WritePrivateProfileString sAppName, sKeyName, sValue, sINIFileName End SubPublic Function DrawIconFromFile(pic As PictureBox, FileName As String, Optional BackColor As Long = vbWindowBackground) As Long '画图标 Dim IconFile As String Dim pos As Integer Dim index As Integer Dim hIcon As Long pos = InStrRev(FileName, ",") If pos <> 0 Then IconFile = Left(FileName, pos - 1) index = Val(Mid(FileName, pos + 1)) Else IconFile = FileName End If pic.Cls pic.AutoRedraw = True pic.AutoSize = True pic.BackColor = BackColor hIcon = ExtractIcon(pic.Parent.hwnd, IconFile, index) DrawIcon pic.hdc, 0, 0, hIcon DrawIconFromFile = hIcon End FunctionPublic Function AddPicToImageList(iFileName As String, Pic1 As PictureBox, ImageList1 As ImageList, Optional index As Integer = -1, Optional Key As String = "") '将文件图标添加到Imagelist控件 Dim FileName As String Dim ret As Long Dim tmp As ListImage FileName = GetFileIconStr((GetFileEtc(iFileName))) If FileName = "" Then AddPicToImageList = 1 Exit Function ElseIf FileName <> "%1" Then ret = DrawIconFromFile(Pic1, FileName) Else On Error Resume Next ret = DrawIconFromFile(Pic1, iFileName) End If SavePicture Pic1.Image, SPath & "temp.bmp" If ret <> 0 Then Set tmp = ImageList1.ListImages.Add(, , LoadPicture(SPath & "temp.bmp")) AddPicToImageList = tmp.index Else AddPicToImageList = 1 End If End FunctionPublic Sub ShellDoc(strFile As String) '默认程序打开文件,无则调用打开方式 Dim lngRet As Long Dim strDir As String lngRet = ShellExecute(GetDesktopWindow, "open", strFile, vbNullString, vbNullString, vbNormalFocus) If lngRet = SE_ERR_NOASSOC Then ' 没有关联的程序 strDir = Space(260) lngRet = GetSystemDirectory(strDir, Len(strDir)) strDir = Left(strDir, lngRet) ' 显示打开方式窗口 Call ShellExecute(GetDesktopWindow, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDLL " & strFile, strDir, vbNormalFocus) End If End Sub
'窗体 frmNewMail继续 Begin VB.CommandButton cmdMailTo Caption = "收件人(&R):" Height = 315 Left = 120 TabIndex = 0 Top = 540 Width = 1095 End Begin VB.CommandButton cmdCopyTo Caption = "抄送(&C):" Height = 315 Left = 120 TabIndex = 1 Top = 960 Width = 1095 End Begin VB.TextBox txtCopyTo BackColor = &H8000000A& Height = 315 Left = 1320 Locked = -1 'True TabIndex = 6 Top = 960 Width = 8175 End Begin VB.TextBox txtMailTo BackColor = &H8000000A& Height = 315 Left = 1320 Locked = -1 'True TabIndex = 5 Top = 540 Width = 8175 End Begin VB.PictureBox Picture1 AutoRedraw = -1 'True AutoSize = -1 'True BeginProperty Font Name = "MS Sans Serif" Size = 8.25 Charset = 0 Weight = 400 Underline = 0 'False Italic = 0 'False Strikethrough = 0 'False EndProperty Height = 540 Left = 8760 ScaleHeight = 480 ScaleWidth = 480 TabIndex = 10 Top = 2340 Visible = 0 'False Width = 540 End Begin MSComDlg.CommonDialog CommonDialog1 Left = 7560 Top = 1800 _ExtentX = 847 _ExtentY = 847 _Version = 393216 End Begin VB.Label Label1 Caption = "主题(S):" Height = 255 Left = 300 TabIndex = 2 Top = 1440 Width = 795 End End Attribute VB_Name = "frmNewMail" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = True Attribute VB_Exposed = False Option ExplicitPrivate Sub Form_resize() On Error Resume Next cbr.Width = Me.ScaleWidth Toolbar1.Width = cbr.Width - 120 txtMailTo.Width = Me.ScaleWidth - 2 * cmdMailTo.Left - cmdMailTo.Width - (txtMailTo.Left - (cmdMailTo.Left + cmdMailTo.Width)) txtCopyTo.Width = txtMailTo.Width txtSubject.Width = txtMailTo.Width rchTxtContent.Width = Me.ScaleWidth - 2 * rchTxtContent.Left If HaveAnnexAtNew = False Then rchTxtContent.Height = Me.ScaleHeight - rchTxtContent.Top - 90 lvwAnnex.Visible = False Else rchTxtContent.Height = Me.ScaleHeight - rchTxtContent.Top - 240 - lvwAnnex.Height lvwAnnex.Top = rchTxtContent.Top + rchTxtContent.Height + 90 lvwAnnex.Width = rchTxtContent.Width lvwAnnex.Visible = True End If If Me.Width < 6400 Then Me.Width = 6400 If Me.Height < 4600 Then Me.Height = 4600 End SubPrivate Sub lvwAnnex_DblClick() If ItemClickedNewBox = True And RightButton1 = False Then If MailType <> " 转发 " Then ShellDoc sFileFullPathName(lvwAnnex.SelectedItem.index) Else Call SaveAnnexAsFile(CLng(Mid(lvwAnnex.SelectedItem.Key, 6))) End If End If End SubPrivate Sub lvwAnnex_ItemClick(ByVal Item As MSComctlLib.ListItem) ItemClickedNewBox = True End SubPrivate Sub lvwAnnex_KeyDown(KeyCode As Integer, Shift As Integer) If lvwAnnex.SelectedItem Is Nothing Then Exit Sub If KeyCode = vbKeyDelete Then CurrentWindow = "frmNewMail" Call AnnexDelete End If End SubPrivate Sub lvwAnnex_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) Dim tmp As ListItem If Button = 2 Then RightButton1 = True Else RightButton1 = False Set tmp = lvwAnnex.HitTest(x, y) If tmp Is Nothing Then ItemClickedNewBox = False Set lvwAnnex.SelectedItem = Nothing Else ItemClickedNewBox = True End If End Sub Private Sub lvwAnnex_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) If Data.GetFormat(vbCFFiles) = True Then Effect = OLEDragDropFiles(Data) End If End SubPrivate Sub lvwAnnex_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer) If Data.GetFormat(vbCFFiles) = True Then Effect = vbDropEffectCopy End If End SubPrivate Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button) Dim index As Long Dim Addressee As String Dim Copyto As String Dim ret As Integer Dim SaveAsAnnexFile As String Select Case Button.Key Case "AddAnnex" Call OpenFileAddToAnnex Call Form_resize End Select End SubPrivate Sub Toolbar1_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu) Toolbar1.Buttons("MailLevel").Caption = ButtonMenu.Text End Sub
'运行时在文本框里输入扩展名，键入回车后即将看到文件图标Dim WithEvents txt As TextBox
Private Const MAX_PATH = 260
Private Type SHFILEINFO
hIcon As Long ' out: icon
iIcon As Long ' out: icon index
dwAttributes As Long ' out: SFGAO_ flags
szDisplayName As String * MAX_PATH ' out: display name (or path)
szTypeName As String * 80 ' out: type name
End Type
Private Declare Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" (ByVal pszPath As String, ByVal dwFileAttributes As Long, psfi As SHFILEINFO, ByVal cbFileInfo As Long, ByVal uFlags As Long) As Long
Private Const SHGFI_ICON = &H100
Private Const SHGFI_USEFILEATTRIBUTES = &H10
Private Const FILE_ATTRIBUTE_NORMAL = &H80
Private Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As LongPrivate Sub Form_Load()
Me.ScaleMode = vbPixels
Me.AutoRedraw = True
Set txt = Me.Controls.Add("VB.TextBox", "TextFileExt")
With txt
.Left = 0
.Top = 0
.Width = 30
.Height = 15
.MaxLength = 3
.Visible = True
End With
End SubPrivate Sub txt_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyReturn Then
Dim tmp As SHFILEINFO
SHGetFileInfo "abc." & txt.Text, FILE_ATTRIBUTE_NORMAL, tmp, Len(tmp), SHGFI_ICON Or SHGFI_USEFILEATTRIBUTES
With tmp
Me.Cls
DrawIcon Me.hdc, 50, 5, .hIcon
lbl = .szDisplayName
Me.Refresh
End With
End If
End Sub
'工程文件 Project1.prjType=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#D:\WINNT\System32\stdole2.tlb#OLE Automation
Reference=*\G{00000201-0000-0010-8000-00AA006D2EA4}#2.1#0#D:\Program Files\Common Files\system\ado\msado21.tlb#Microsoft ActiveX Data Objects 2.1 Library
Object={831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0; MSCOMCTL.OCX
Object={38911DA0-E448-11D0-84A3-00DD01104159}#1.1#0; COMCT332.OCX
Object={F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0; COMDLG32.OCX
Object={3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0; RICHTX32.OCX
Module=mdlMailSystem; mdlMailSystem.bas
Form=frmNewMail.frm
Object={BDC217C8-ED16-11CD-956C-0000C04E4C0A}#1.1#0; TABCTL32.OCX
Startup="frmNewMail"
HelpFile=""
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
VersionCompanyName="tdts"
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1[MS Transaction Server]
AutoRefresh=1
'mdlMailSystem.basAttribute VB_Name = "mdlMailSystem"
'─────────────────────────────────────────────────────────────────────────────────────────
' 电子邮件系统 - 模块
'─────────────────────────────────────────────────────────────────────────────────────────
Option Explicit
'■声明API函数
'─────────────────────────────────────────────────────────────────────────────────────────┐
Public Declare Function ExtractIcon Lib "Shell32.dll" Alias "ExtractIconA" (ByVal hInst As Long, ByVal lpszExeFileName As String, ByVal nIconIndex As Long) As Long '│
'─────────────────────────────────────────────────────────────────────────────────────────┘'────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────────
Private Declare Function SendMessageFind Lib "User32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Integer, ByVal lParam As String) As LongPrivate Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal hIcon As Long) As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam 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 WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function ShellExecute Lib "Shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long
'──注册表相关─────────────────┐
Public Const HKEY_CLASSES_ROOT = &H80000000 '│
Private Const REG_SZ = 1 '│
'────────────────────────┘'───附件────────────────────────────────────────────┤
Public SPath As String '│
Public HaveAnnexAtNew As Boolean '发信时有无附件 │
Public HaveAnnexAtGet As Boolean '收到的信有无附件 │
Public ItemClickedMailBox As Boolean 'frmMailBox 中附件列表 lvwAnnex 是否有项目被选中 │
Public ItemClickedNewBox As Boolean 'frmNewMail 中附件列表 lvwAnnex 是否有项目被选中 │
Public ClickedAnnexFileName As String 'frmNewMail 中所选中项目的文件名 │
Public sFileFullPathName() As String '附件文件名 │
Public iCount As Integer '计数器 │
Public hIcon() As Integer '图标索引 │
Public CurrentWindow As String '当前窗口 │
Public RightButton1 As Boolean '是否右键按下 │
Public RightButton2 As Boolean '是否右键按下 │
'│
'─────────────────────────────────────────────────┘Public Sub AddAnnexTolvwAnnex(sFileFullName As String)
'将参数sFileFullName所指文件图标添加入附件列表中
Dim FileNameKey As String
Dim index As Integer
With frmNewMail
HaveAnnexAtNew = True
iCount = iCount + 1
ReDim Preserve hIcon(iCount) As Integer
ReDim Preserve sFileFullPathName(iCount) As String
sFileFullPathName(iCount) = sFileFullName
FileNameKey = GetFileNameNoPath(sFileFullPathName(iCount))
.lvwAnnex.Icons = Nothing
hIcon(iCount) = AddPicToImageList(sFileFullName, .Picture1, .ImageList2)
.lvwAnnex.Icons = .ImageList2
.lvwAnnex.ListItems.Add , , FileNameKey, 1
For index = 1 To .lvwAnnex.ListItems.Count
.lvwAnnex.ListItems(index).Icon = hIcon(index)
Next
End With
End Sub
Public Sub OpenFileAddToAnnex()
'选择附件文件（可多选），添加到LvwAnnex中
Dim index As Integer
Dim path As String
With frmNewMail
.CommonDialog1.FileName = ""
.CommonDialog1.Filter = "所有文件(*.*)|*.*"
.CommonDialog1.Flags = cdlOFNExplorer + cdlOFNAllowMultiselect
.CommonDialog1.MaxFileSize = 32767
.CommonDialog1.DialogTitle = "选择附件文件"
.CommonDialog1.ShowOpen
If .CommonDialog1.FileName <> "" Then
Dim FilesName() As String
FilesName = Split(.CommonDialog1.FileName, Chr(0))
If UBound(FilesName) > 0 Then
path = IIf(Len(FilesName(0)) = 3, FilesName(0), FilesName(0) & "\")
For index = 1 To UBound(FilesName)
AddAnnexTolvwAnnex path & FilesName(index)
Next
Else
AddAnnexTolvwAnnex FilesName(0)
End If
End If
End With
End SubPublic Function GetFileNameNoPath(FileFullPathName As String) As String
'从文件全路径名中去除路径
Dim pos As Integer
pos = InStrRev(FileFullPathName, "\")
If pos <> 0 Then
GetFileNameNoPath = Mid(FileFullPathName, pos + 1)
Else
GetFileNameNoPath = FileFullPathName
End If
End FunctionPublic Function GetFileEtc(FileName As String) As String
'获取文件扩展名
Dim pos As String
pos = InStrRev(FileName, ".")
If pos <> 0 Then GetFileEtc = Mid(FileName, pos): Exit Function
GetFileEtc = ""
End FunctionPublic Function GetFileIconStr(FileEtc As String) As String
'获取文件的图标文件
Dim FileTypeKey As String
Dim tmp As String
FileTypeKey = ReadRegValue(HKEY_CLASSES_ROOT, FileEtc, "")
If FileTypeKey <> "" Then
GetFileIconStr = ReadRegValue(HKEY_CLASSES_ROOT, FileTypeKey & "\DefaultIcon", "")
Else
GetFileIconStr = ""
End If
End Function
'从注册表中读取键值
Dim hResult As Long
Dim buffer As String
Dim pos As Integer
buffer = String(1024, " ")
RegOpenKeyEx MainRoot, SubKey, 0, 0, hResult
RegQueryValueEx hResult, KeyValue, 0&, REG_SZ, ByVal buffer, 1024
pos = InStr(1, buffer, Chr(0))
If pos <> 0 Then
ReadRegValue = Left(buffer, pos - 1)
Else
ReadRegValue = ""
End If
End FunctionPublic Function GetINISet(sINIFileName As String, sAppName As String, sKeyName As String) As String
'读取配置文件内容
Dim RetStr As String * 255
Dim pos As Integer
GetPrivateProfileString sAppName, sKeyName, "", RetStr, 255, sINIFileName
pos = InStr(1, RetStr, Chr(0))
If pos <> -1 Then
GetINISet = Left(RetStr, pos - 1)
Else
GetINISet = ""
End If
End FunctionPublic Sub SetINIValue(sINIFileName As String, sAppName As String, sKeyName As String, sValue As String)
'写配置文件
WritePrivateProfileString sAppName, sKeyName, sValue, sINIFileName
End SubPublic Function DrawIconFromFile(pic As PictureBox, FileName As String, Optional BackColor As Long = vbWindowBackground) As Long
'画图标
Dim IconFile As String
Dim pos As Integer
Dim index As Integer
Dim hIcon As Long
pos = InStrRev(FileName, ",")
If pos <> 0 Then
IconFile = Left(FileName, pos - 1)
index = Val(Mid(FileName, pos + 1))
Else
IconFile = FileName
End If
pic.Cls
pic.AutoRedraw = True
pic.AutoSize = True
pic.BackColor = BackColor
hIcon = ExtractIcon(pic.Parent.hwnd, IconFile, index)
DrawIcon pic.hdc, 0, 0, hIcon
DrawIconFromFile = hIcon
End FunctionPublic Function AddPicToImageList(iFileName As String, Pic1 As PictureBox, ImageList1 As ImageList, Optional index As Integer = -1, Optional Key As String = "")
'将文件图标添加到Imagelist控件
Dim FileName As String
Dim ret As Long
Dim tmp As ListImage
FileName = GetFileIconStr((GetFileEtc(iFileName)))
If FileName = "" Then
AddPicToImageList = 1
Exit Function
ElseIf FileName <> "%1" Then
ret = DrawIconFromFile(Pic1, FileName)
Else
On Error Resume Next
ret = DrawIconFromFile(Pic1, iFileName)
End If
SavePicture Pic1.Image, SPath & "temp.bmp"
If ret <> 0 Then
Set tmp = ImageList1.ListImages.Add(, , LoadPicture(SPath & "temp.bmp"))
AddPicToImageList = tmp.index
Else
AddPicToImageList = 1
End If
End FunctionPublic Sub ShellDoc(strFile As String)
'默认程序打开文件,无则调用打开方式
Dim lngRet As Long
Dim strDir As String
lngRet = ShellExecute(GetDesktopWindow, "open", strFile, vbNullString, vbNullString, vbNormalFocus)
If lngRet = SE_ERR_NOASSOC Then
' 没有关联的程序
strDir = Space(260)
lngRet = GetSystemDirectory(strDir, Len(strDir))
strDir = Left(strDir, lngRet)
' 显示打开方式窗口
Call ShellExecute(GetDesktopWindow, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDLL " & strFile, strDir, vbNormalFocus)
End If
End Sub
'窗体 frmNewMail.frmVERSION 5.00
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Object = "{38911DA0-E448-11D0-84A3-00DD01104159}#1.1#0"; "COMCT332.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmNewMail
Caption = "△新邮件△"
ClientHeight = 7005
ClientLeft = 60
ClientTop = 345
ClientWidth = 9585
Icon = "frmNewMail.frx":0000
LinkTopic = "Form1"
LockControls = -1 'True
ScaleHeight = 7005
ScaleWidth = 9585
Begin MSComctlLib.ImageList ImageList2
Left = 8880
Top = 1920
_ExtentX = 1005
_ExtentY = 1005
BackColor = -2147483643
ImageWidth = 32
ImageHeight = 32
MaskColor = 12632256
_Version = 393216
BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628}
NumListImages = 1
BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628}
Picture = "frmNewMail.frx":000C
Key = ""
EndProperty
EndProperty
End
Begin MSComctlLib.ListView lvwAnnex
Height = 1095
Left = 120
TabIndex = 9
Top = 5820
Width = 9375
_ExtentX = 16536
_ExtentY = 1931
Arrange = 2
LabelEdit = 1
MultiSelect = -1 'True
LabelWrap = -1 'True
HideSelection = -1 'True
OLEDropMode = 1
_Version = 393217
ForeColor = -2147483640
BackColor = -2147483643
BorderStyle = 1
Appearance = 1
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
OLEDropMode = 1
NumItems = 0
End
Begin RichTextLib.RichTextBox rchTxtContent
Height = 3915
Left = 120
TabIndex = 4
Top = 1800
Width = 9375
_ExtentX = 16536
_ExtentY = 6906
_Version = 393217
ScrollBars = 3
OLEDropMode = 1
TextRTF = $"frmNewMail.frx":0A60
BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851}
Name = "宋体"
Size = 9
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
End
Begin VB.TextBox txtSubject
Height = 315
Left = 1320
TabIndex = 3
Top = 1380
Width = 8175
End
Begin ComCtl3.CoolBar cbr
Height = 390
Left = 0
TabIndex = 7
Top = 0
Width = 9555
_ExtentX = 16854
_ExtentY = 688
BandCount = 1
_CBWidth = 9555
_CBHeight = 390
_Version = "6.7.8988"
Child1 = "Toolbar1"
MinHeight1 = 330
Width1 = 2790
NewRow1 = 0 'False
Begin MSComctlLib.Toolbar Toolbar1
Height = 330
Left = 30
TabIndex = 8
Top = 30
Width = 9435
_ExtentX = 16642
_ExtentY = 582
ButtonWidth = 1984
ButtonHeight = 582
AllowCustomize = 0 'False
Style = 1
TextAlignment = 1
_Version = 393216
BeginProperty Buttons {66833FE8-8583-11D1-B16A-00C0F0283628}
NumButtons = 6
BeginProperty Button1 {66833FEA-8583-11D1-B16A-00C0F0283628}
Style = 3
EndProperty
BeginProperty Button2 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "立即发送"
Key = "SendImmediately"
Object.ToolTipText = "立即发送"
EndProperty
BeginProperty Button3 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "保存邮件"
Key = "SaveToOutBox"
Object.ToolTipText = "保存到发件箱"
EndProperty
BeginProperty Button4 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "地址薄"
Key = "AddressBook"
Object.ToolTipText = "地址薄"
EndProperty
BeginProperty Button5 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "普通邮件"
Key = "MailLevel"
Style = 5
BeginProperty ButtonMenus {66833FEC-8583-11D1-B16A-00C0F0283628}
NumButtonMenus = 2
BeginProperty ButtonMenu1 {66833FEE-8583-11D1-B16A-00C0F0283628}
Key = "Slow"
Text = "普通邮件"
EndProperty
BeginProperty ButtonMenu2 {66833FEE-8583-11D1-B16A-00C0F0283628}
Key = "Fast"
Text = "紧急邮件"
EndProperty
EndProperty
EndProperty
BeginProperty Button6 {66833FEA-8583-11D1-B16A-00C0F0283628}
Caption = "增加附件"
Key = "AddAnnex"
EndProperty
EndProperty
Begin VB.CommandButton cmdAddAnnex
Caption = "Annex"
Height = 315
Left = 6660
TabIndex = 11
Top = 2220
Visible = 0 'False
Width = 675
End
End
End
Caption = "收件人(&R):"
Height = 315
Left = 120
TabIndex = 0
Top = 540
Width = 1095
End
Begin VB.CommandButton cmdCopyTo
Caption = "抄送(&C):"
Height = 315
Left = 120
TabIndex = 1
Top = 960
Width = 1095
End
Begin VB.TextBox txtCopyTo
BackColor = &H8000000A&
Height = 315
Left = 1320
Locked = -1 'True
TabIndex = 6
Top = 960
Width = 8175
End
Begin VB.TextBox txtMailTo
BackColor = &H8000000A&
Height = 315
Left = 1320
Locked = -1 'True
TabIndex = 5
Top = 540
Width = 8175
End
Begin VB.PictureBox Picture1
AutoRedraw = -1 'True
AutoSize = -1 'True
BeginProperty Font
Name = "MS Sans Serif"
Size = 8.25
Charset = 0
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 540
Left = 8760
ScaleHeight = 480
ScaleWidth = 480
TabIndex = 10
Top = 2340
Visible = 0 'False
Width = 540
End
Begin MSComDlg.CommonDialog CommonDialog1
Left = 7560
Top = 1800
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label1
Caption = "主题(S):"
Height = 255
Left = 300
TabIndex = 2
Top = 1440
Width = 795
End
End
Attribute VB_Name = "frmNewMail"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option ExplicitPrivate Sub Form_resize()
On Error Resume Next
cbr.Width = Me.ScaleWidth
Toolbar1.Width = cbr.Width - 120
txtMailTo.Width = Me.ScaleWidth - 2 * cmdMailTo.Left - cmdMailTo.Width - (txtMailTo.Left - (cmdMailTo.Left + cmdMailTo.Width))
txtCopyTo.Width = txtMailTo.Width
txtSubject.Width = txtMailTo.Width
rchTxtContent.Width = Me.ScaleWidth - 2 * rchTxtContent.Left
If HaveAnnexAtNew = False Then
rchTxtContent.Height = Me.ScaleHeight - rchTxtContent.Top - 90
lvwAnnex.Visible = False
Else
rchTxtContent.Height = Me.ScaleHeight - rchTxtContent.Top - 240 - lvwAnnex.Height
lvwAnnex.Top = rchTxtContent.Top + rchTxtContent.Height + 90
lvwAnnex.Width = rchTxtContent.Width
lvwAnnex.Visible = True
End If
If Me.Width < 6400 Then Me.Width = 6400
If Me.Height < 4600 Then Me.Height = 4600
End SubPrivate Sub lvwAnnex_DblClick()
If ItemClickedNewBox = True And RightButton1 = False Then
If MailType <> " 转发 " Then
ShellDoc sFileFullPathName(lvwAnnex.SelectedItem.index)
Else
Call SaveAnnexAsFile(CLng(Mid(lvwAnnex.SelectedItem.Key, 6)))
End If
End If
End SubPrivate Sub lvwAnnex_ItemClick(ByVal Item As MSComctlLib.ListItem)
ItemClickedNewBox = True
End SubPrivate Sub lvwAnnex_KeyDown(KeyCode As Integer, Shift As Integer)
If lvwAnnex.SelectedItem Is Nothing Then Exit Sub
If KeyCode = vbKeyDelete Then
CurrentWindow = "frmNewMail"
Call AnnexDelete
End If
End SubPrivate Sub lvwAnnex_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim tmp As ListItem
If Button = 2 Then RightButton1 = True Else RightButton1 = False
Set tmp = lvwAnnex.HitTest(x, y)
If tmp Is Nothing Then
ItemClickedNewBox = False
Set lvwAnnex.SelectedItem = Nothing
Else
ItemClickedNewBox = True
End If
End Sub
Private Sub lvwAnnex_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
If Data.GetFormat(vbCFFiles) = True Then
Effect = OLEDragDropFiles(Data)
End If
End SubPrivate Sub lvwAnnex_OLEDragOver(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer)
If Data.GetFormat(vbCFFiles) = True Then
Effect = vbDropEffectCopy
End If
End SubPrivate Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Dim index As Long
Dim Addressee As String
Dim Copyto As String
Dim ret As Integer
Dim SaveAsAnnexFile As String
Select Case Button.Key
Case "AddAnnex"
Call OpenFileAddToAnnex
Call Form_resize
End Select
End SubPrivate Sub Toolbar1_ButtonMenuClick(ByVal ButtonMenu As MSComctlLib.ButtonMenu)
Toolbar1.Buttons("MailLevel").Caption = ButtonMenu.Text
End Sub
http://www14.brinkster.com/weblover/icon.zip
可如果我要把listview的view属性改为lvwReport怎么不行？
给与回复。谢谢。另外，我怎么给你加分？