Various dialog boxes (SMDILOG) 'Option Explicit' defines a global variable to save various attributes of the font publicipe smfontattr fontname as string 'font name fontsize as integer' font size fontbod as Boolean 'Whether the black body fontital as boolean' is sloped Fontunderline as boolean 'Whether to underscore Fontstrikeou as boolean fontcolor as long winhwnd as longend typedim m_getfont as smfontattr' ** system constant -------------- --------------------------- Private Const SWP_NOOWNERZORDER = & H200Private Const SWP_HIDEWINDOW = & H80Private Const SWP_NOACTIVATE = & H10Private Const SWP_NOMOVE = & H2Private Const SWP_NOREDRAW = & H8Private Const SWP_NOREPOSITION = SWP_NOOWNERZORDERPrivate Const SWP_NOSIZE = & H1Private Const SWP_NOZORDER = & H4Private Const SWP_SHOWWINDOW = & H40Private Const RESOURCETYPE_DISK = & H1 'network drive Private Const RESOURCETYPE_PRINT = & H2' network printer '/ ------------------- ---------------------------------------- Private const noerror = 0Private const csidl_desktop = & h0private Const csidl_programs = & h2private const csidl_controls = & h3private co nst CSIDL_PRINTERS = & H4Private Const CSIDL_PERSONAL = & H5Private Const CSIDL_FAVORITES = & H6Private Const CSIDL_STARTUP = & H7Private Const CSIDL_RECENT = & H8Private Const CSIDL_SENDTO = & H9Private Const CSIDL_BITBUCKET = & HAPrivate Const CSIDL_STARTMENU = & HBPrivate Const CSIDL_DESKTOPDIRECTORY = & H10Private Const CSIDL_DRIVES = & H11Private Const CSIDL_NETWORK = & H12Private Const CSIDL_NETHOOD = & H13Private Const CSIDL_FONTS = & H14Private const csidl_templates =
& H15Private Const LF_FACESIZE = 32Private Const MAX_PATH = 260Private Const CF_INITTOLOGFONTSTRUCT = & H40 & Private Const CF_FIXEDPITCHONLY = & H4000 & Private Const CF_EFFECTS = & H100 & Private Const ITALIC_FONTTYPE = & H200Private Const BOLD_FONTTYPE = & H100Private Const CF_NOFACESEL = & H80000Private Const CF_NOSCRIPTSEL = & H800000Private Const CF_PRINTERFONTS = & H2Private Const CF_SCALABLEONLY = & H20000Private Const CF_SCREENFONTS = & H1Private Const CF_SHOWHELP = & H4 & private const cf_both = (cf_screenfonts or cf_printerfonts) '/ ------------------------------------- ----- Private Type CHOOSECOLOR lStructSize As Long hwndOwner As Long hInstance As Long rgbResult As Long lpCustColors As String flags As Long lCustData As Long lpfnHook As Long lpTemplateName As StringEnd TypePrivate Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String LPSTRCUSTOMFILTER AS STRI ng 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 StringEnd Type '
/ --------------------------------------------------- ---------- Private Type LOGFONT lfHeight As Long lfWidth As Long lfEscapement As Long lfOrientation As Long lfWeight As Long lfItalic As Byte lfUnderline As Byte lfStrikeOut As Byte lfCharSet As Byte lfOutPrecision As Byte lfClipPrecision As Byte lfQuality As Byte lfPitchAndFamily As Byte lfFaceName As String * LF_FACESIZEEnd TypePrivate Type CHOOSEFONT lStructSize As Long hwndOwner As Long hdc As Long lpLogFont As Long iPointSize As Long flags As Long rgbColors As Long lCustData As Long lpfnHook As Long lpTemplateName As String hInstance As Long lpszStyle As String nFontType As Integer MISSING_ALIGNMENT As INTEGER NSIZEMIN As Long NsizeMax as long end type '/ -------------- Private Type Shitemid CB As Long Abid () AS BYTEEND TYP EPRIVATE TYPE ITEMIDLIST MKID AS SHITEMIDEND TYPE '/ ----------------------------------------- -Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _ (ByVal Pidl As Long, ByVal pszPath As String) As LongPrivate Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" _ (ByVal hwndOwner As Long, ByVal nFolder As Long, _ PIDL As ItemidList) as long '/ ----------------------------------------- -Private Declare Function GetsaveFileName Lib "comdlg32.dll" alias "getsavefilename"
(POpenfilename As OPENFILENAME) As LongPrivate Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As LongPrivate Declare Function CHOOSECOLOR Lib "comdlg32.dll" Alias "ChooseColorA"
(PChoosecolor As Choosecolor) AS Longprivate Declare Function WNETCONNECTIONDIALOG LIB "MPR.DLL" (Byval Hwnd As Long,
BYVAL DWTYPE AS Long) As longprivate declare function choosefont lib "comdlg32.dll" alias "choosefonta"
(pchoosefont as choosefont) as long '/ ======= Display disconnected network resource dialog =====================lor "mpr.dll" _ (byval hwnd as Long, ByVal DWTYPE AS long) as long '/ ======================================= ======================================================================================================================================================================================================================32.dll "(BYVAL PV As Long) Private Declare Function ShbrowseFolder Lib" shell32.dll "alias
"SHBrowseForFolderA" _ (lpBrowseInfo As BROWSEINFO) As LongPrivate Type BROWSEINFO hOwner As Long pidlRoot As Long pszDisplayName As String lpszTitle As String ulFlags As Long lpfn As Long lParam As Long iImage As LongEnd Type '/ Structure Description: _ hOwner call this dialog The handle of the window _ PIDLROOT points to the list of the top folders you want to browse _ pszdisplayName is used to save the display name of the folder selected by the user _ lpsztitle Browse the title of the dialog box _ ulflags decides what to browse See below) _LPFN When the event occurs when the dialog box is called, it can be set to null _ lparam If the callback function is defined, the selected folder is saved to the value of the callback function _ IIMAGE As Long buffer _ulFlags parametric mapping index (see below:) Private Const BIF_RETURNONLYFSDIRS = & H1 'to allow only browse file system folders Private Const BIF_DONTGOBELOWDOMAIN = & H2' uses this value to force the user to gauge the domain level Network neighborhood in Private Const BIF_STATUSTEXT = & H4 'show status bar Private Const BIF_RETURNFSANCESTORS = & H8 in the selection dialogue' returns the file system ancestor Private Const BIF_BROWSEFORCOMPUTER = & H1000 'allows you to browse your computer Private Const BIF_BROWSEFORPRINTER = & H2000' tour allows the printers folder '/ ---------- ----------- -------------------------------------------------- --------- Dim Fontinfo as Smfontattr 'Font' / ------------------------------- -----------------------------------------------
Private Function GetFolderValue (wIdx As Integer) As Long If wIdx <2 Then GetFolderValue = 0 ElseIf wIdx <12 Then GetFolderValue = wIdx Else GetFolderValue = wIdx 4 End IfEnd Function'Private Function GetReturnType () As Long Dim dwRtn As Long dwRtn = dwRtn OR BIF_RETURNONLYFSDIRS GETRETURNTYPE = DWRTNEND FUNCTION 'folder selection dialog' function: savefile 'parameter: Title Settings the tag of the dialog.' Hwnd calls this function HWnd 'folderid SMBROWFOLDER enumeration (default: My computer).' Return value : String folder path "examples:. Public Function GetFolder (Optional Title As String, _ Optional hWnd As Long, _ Optional FolderID As SmBrowFolder = MyComputer) As String Dim Bi As BROWSEINFO Dim Pidl As Long Dim folder As String Dim IDL As ITEMIDLIST Dim nFolder As Long Dim ReturnFol As String Dim Fid As Integer Fid = FolderID Folder = String $ (255, Chr $ (0)) With Bi .hOwner = hWnd nFolder = GetFolderValue (Fid) If SHGetSpecialFolderLocation (ByVal hWnd, ByVal nFolder, IDL ) = NoError Then .pidlroot = idl.mkid.cb end if .pszdisplayName = string $ (max_path, fid) if len (title)> 0 damlpsztitle = title & chr $ (0) else .lpsztitle = "Please select folder: "& Chr $ (0) End If .ulFlags = getReturnType () End With Pidl = SHBrowseForFolder (Bi) '/ returns the selected folder path If SHGetPathFromIDList (ByVal Pidl, ByVal folder) Then ReturnFol = Left $ (folder, InStr (Folder, CHR $ (0)) - 1) IF Right $ (Trim $ (Returnfol), 1) <> "/" Then ReturnFol = ReturnFol & "GetFolder =
ReturnFol Else getFolder = "" "End Ifnd Function '" file save dialog' function: savefile 'parameter: WinhWnd calls this function's HWnd' BoxLabel Settings dialog box. 'StartPath Settings Initial path.' Filterstr file filtering. 'Flag flag (Reference MSDN) 'Return Value: String File Name.' Example: Public Function Savefile (WinhWnd As Long, _ Optional Boxlabel As String = "", _ Optional StartPath AS String = "", _ Optional Filterstr = "*. * |. * * ", _ Optional Flag As Variant = & H4 Or & H200000) As String Dim Rc As Long Dim pOpenfilename As OPENFILENAME Dim Fstr1 () As String Dim Fstr As String Dim I As Long Const MAX_Buffer_LENGTH = 256 On Error Resume Next If Len (TRIM $ (StartPath))> 0 Then IF Right $ (StartPath, 1) <> "/" THEN StartPath = StartPath & "IF DIR $ (StartPath, VBDirectory Vbhidden) =" "" "" "" "" End if else startpath = app.path End ifness = 0 THEN FSTR = "*. * | *. *" End if fstr1 = split (f Ilterstr, "|") for i = 0 to Ubound (fstr1) fstr = fstr & fstr1 (i) & vbnullchar next '/ -------------------------------------------------------------------------------------------------------------- ---------------------------- with popenfilename .hwndowner = winhwnd .hinstance = app.hinstance .lpstrinitialDir = startpath .lpstrinitialDir = startpath .lpstrfilter = Fstr .nfilterIndex = 1 .lpstrdefext = vbnullchar & vbnullchar .lpstrfile = string (max_buffer_length, 0) .nmaxfile =
MAX_Buffer_LENGTH - 1 .lpstrFileTitle = .lpstrFile .nMaxFileTitle = MAX_Buffer_LENGTH .lStructSize = Len (pOpenfilename) .flags = Flag End With Rc = GetSaveFileName (pOpenfilename) If Rc Then SaveFile = Left $ (pOpenfilename.lpstrFile, pOpenfilename.nMaxFile) Else SaveFile = "" End IFEND FUNCTION
'' File open dialog 'function: OpenFile' parameter: WinhWnd invokes the label of the HWND 'BoxLabel Settings dialog box.' StartPath Set the initialization path. 'Filterstr file filter.' Flag flag. (Reference MSDN) 'Return Value: String file name. 'Example: public function openfile (WinHWnd As Long, _ Optional Boxlabel As String = "", _ Optional StartPath AS String = "", _ Optional Filterstr = "*. * | *. *", _ Optional Flag As Variant = & H8 Or & H200000) As String Dim Rc As Long Dim pOpenfilename As OPENFILENAME Dim Fstr1 () As String Dim Fstr As String Dim I As Long Const MAX_Buffer_LENGTH = 256 On Error Resume Next If Len (Trim $ (StartPath))> 0 THEN IF RIGHT $ (StartPath, 1) <> "/" THEN STARTPATH = StartPath & "IF DIR $ (StartPath, VBDirectory Vbhidden) =" "" THEN STARTPATH = App.Path End if else startpath = app.path End If IF LEN (TRIM $ (Filterstr)) = 0 THEN FSTR = "*. * | *. *" End if fstr = "" fSTR1 = Split (Filterstr, "|") for i = 0 to Ubound (fSTR1) Fstr = Fstr & Fstr1 (I) & vbNullChar Next With pOpenfilename .hwndOwner = WinHwnd .hInstance = App.hInstance .lpstrTitle = BoxLabel .lpstrInitialDir = StartPath .lpstrFilter = Fstr .nFilterIndex = 1 .lpstrDefExt = vbNullChar & vbNullChar .lpstrFile = String ( MAX_BUFFER_LENGTH, 0) .nmaxfile = max_buffer_length - 1 .lpstrfileTitle = .lpstrfile .nmaxFileTitle = max_buffer_length .lstructSize =
Len (pOpenfilename) .flags = Flag End With Rc = GetOpenFileName (pOpenfilename) If Rc Then OpenFile = Left $ (pOpenfilename.lpstrFile, pOpenfilename.nMaxFile) Else OpenFile = "" End IfEnd Function '' Color dialog 'function: GetColor' parameters: 'return value: Long, a user selected color.' examples: Public Function GetColor () as Long Dim Rc as Long Dim pChoosecolor as CHOOSECOLOR Dim CustomColor () as Byte With pChoosecolor .hwndOwner = 0 .hInstance = App.hInstance .lpCustColors = StrConv (CustomColor, vbUnicode) .flags = 0 .lStructSize = Len (pChoosecolor) End With Rc = CHOOSECOLOR (pChoosecolor) If Rc Then GetColor = pChoosecolor.rgbResult Else GetColor = -1 End IfEnd Function '' mapped network drives display Dialog Function: ConnectDisk 'Parameters: HWnd calls this function window hwnd. (Me.hwn)' Return value: = 0, success, <> 0, failed. 'Example: Public Function ConnectDisk (Optional HWnd As Long) AS LONG DIM RC As long if ISNUMERIC (HWND) THEN RC = WNETCONNECTIONDIALOG (hwnd, resourcetype_disk) Else RC = WNETCONNECTIONDIALOG (0, resourcetype_disk) End if Conne CtDisk = rcend function '' display mapping network printer dialog 'function: connectionprint' parameter: hwnd calls this function window hwnd. (me.hwn) 'Return value: = 0, success, <> 0, failed.' example: public Function ConnectPrint (Optional hWnd As Long) As Long Dim Rc As Long If IsNumeric (hWnd) Then Rc = WNetConnectionDialog (hWnd, RESOURCETYPE_PRINT) Else Rc = WNetConnectionDialog (0, RESOURCETYPE_PRINT) End IfEnd Function '' disconnected mapped network drive box 'Function: disconnectdisk' parameter: hwnd calls this function window hwnd. (Me.hwn) 'Return value: = 0, success, <> 0, failed.' Example:
Public Function DisconnectDisk (Optional hWnd As Long) As Long Dim Rc As Long If IsNumeric (hWnd) Then Rc = WNetDisconnectDialog (hWnd, RESOURCETYPE_DISK) Else Rc = WNetDisconnectDialog (0, RESOURCETYPE_DISK) End IfEnd Function '' disconnected, then map the network print authority Box 'function: disconnectprint' parameter: hwnd calls this function window hwnd. (Me.hwn) 'Return value: = 0, success, <> 0, failed.' Example: Public Function Disconnect (Optional HWnd As Long) AS Long Dim Rc As Long If IsNumeric (hWnd) Then Rc = WNetDisconnectDialog (hWnd, RESOURCETYPE_PRINT) Else Rc = WNetDisconnectDialog (0, RESOURCETYPE_PRINT) End IfEnd function '' Font selection dialog box 'function: GetFont' parameters: WinHwnd calling this function window HWND . (ME.HWN) 'return value: SmFontAttr structure variables.' examples: 'Dim mDialog As New SmDialog' Dim mFontInfo As SmFontAttr 'mFontInfo = mDialog.GetFont (Me.hWnd)' Set mDialog = NothingPublic Function GetFont (WinHwnd As Long ) AS SMFONTATTR DIM RC AS Long Dim Pchoosefont AS Choosefont Dim Plogfont AS Logfont with Plogfont .lffAcename = StrConv (Fontinfo.font Name, vbFromUnicode) .lfItalic = FontInfo.FontItalic .lfUnderline = FontInfo.FontUnderLine .lfStrikeOut = FontInfo.FontStrikeou End With With pChooseFont .hInstance = App.hInstance If IsNumeric (WinHwnd) Then .hwndOwner = WinHwnd .flags = CF_BOTH CF_INITTOLOGFONTSTRUCT CF_EFFECTS Cf_noscriptsel if isnumeric (fontinfo.fontsize) the .ipointsize = fontinfo.fontsize *
10 If FontInfo.FontBod Then .nFontType = .nFontType BOLD_FONTTYPE If IsNumeric (FontInfo.FontColor) Then .rgbColors = FontInfo.FontColor .lStructSize = Len (pChooseFont) .lpLogFont = VarPtr (pLogFont) End With Rc = CHOOSEFONT (pChooseFont) If Rc Then FontInfo.FontName = StrConv (pLogFont.lfFaceName, vbUnicode) FontInfo.FontName = Left $ (FontInfo.FontName, InStr (FontInfo.FontName, vbNullChar) - 1) With pChooseFont FontInfo.FontSize = .iPointSize / 10 'to return a large font
Small fontinfo.fontbod = (.nfontType and bold_fonttype) 'Return / if
Body FontInfo.FontItalic = (.nFontType And ITALIC_FONTTYPE) 'Yes / No italic FontInfo.FontUnderLine = (pLogFont.lfUnderline)' is / underlining FontInfo.FontStrikeou = (pLogFont.lfStrikeOut) FontInfo.FontColor = .rgbColors End With End If GetFont = Fontinfoend function '' file open. (With preview file function) 'function: browfile' parameter: pattern file type string, StarPath start path, isbrow generates preview 'return value: [OK] file path. [Cancel] empty characters String 'example: me.caption =
FileBrow.browfile ("Image File | * .jpg; *. Gif; *. BMP | Media File | * .dat; *. MPG; *. SWF; *. Mp3; *. Mp2
") Public function browfile (optional pattern as string =" *, * | *. * ", _ Optional starpath as string =" c: / ", _ Optional isbrow as boolean = true) AS STRING ON Error ResMe next if len Trim $ (Pattern)) = 0 Then Pattern = ".. * * | * *" P_FilePart = Pattern P_StarPath = StarPath P_IsBrow = IsBrow FrmBrowFile.Show 1 BrowFile = P_FullFileNameEnd function '' display My Network Places 'function: ShowNetWork' parameters: FrmCap Window title, LabCTION Tips Label Name. 'Return Value: [OK] Selected Computer Name.' Example: Public Function ShowNetwork (Optional Function ShowNetwork (optional function showNetwork (optional function shownetWork (optional function shodun "online neighbor", _ optional labction as string = "Select the computer name.") Asstring showlan.hide showlan.caption = frmcap showlan.labncaption = labction showlan.show 1 showNetwork = p_netreturnvalend function
