commondialogs.bas

vb默认工程创建器

Private Const CC_ELLIPSES = 8
Private Const CC_ENABLEHOOK = &H10
Private Const CC_ENABLETEMPLATE = &H20
Private Const CC_ENABLETEMPLATEHANDLE = &H40
Private Const CC_FULLOPEN = &H2
Private Const CC_INTERIORS = 128
Private Const CC_NONE = 0
Private Const CC_PIE = 2
Private Const CC_PREVENTFULLOPEN = &H4
Private Const CC_RGBINIT = &H1
Private Const CC_ROUNDRECT = 256   '
Private Const CC_SHOWHELP = &H8
Private Const CC_SOLIDCOLOR = &H80
Private Const CC_STYLED = 32
Private Const CC_WIDE = 16
Private Const CC_WIDESTYLED = 64
Private Const CCERR_CHOOSECOLORCODES = &H5000
Private Const LOGPIXELSY = 90
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SIMULATED_FONTTYPE = &H8000
Private Const PRINTER_FONTTYPE = &H4000
Private Const SCREEN_FONTTYPE = &H2000
Private Const BOLD_FONTTYPE = &H100
Private Const ITALIC_FONTTYPE = &H200
Private Const REGULAR_FONTTYPE = &H400
Private Const WM_CHOOSEFONT_GETLOGFONT = (&H400 + 1)
Private Const LBSELCHSTRING = "commdlg_LBSelChangedNotify"
Private Const SHAREVISTRING = "commdlg_ShareViolation"
Private Const FILEOKSTRING = "commdlg_FileNameOK"
Private Const COLOROKSTRING = "commdlg_ColorOK"
Private Const SETRGBSTRING = "commdlg_SetRGBColor"
Private Const FINDMSGSTRING = "commdlg_FindReplace"
Private Const HELPMSGSTRING = "commdlg_help"
Private Const CD_LBSELNOITEMS = -1
Private Const CD_LBSELCHANGE = 0
Private Const CD_LBSELSUB = 1
Private Const CD_LBSELADD = 2
Private Const NOERROR = 0
Private Const CSIDL_DESKTOP = &H0
Private Const CSIDL_PROGRAMS = &H2
Private Const CSIDL_CONTROLS = &H3
Private Const CSIDL_PRINTERS = &H4
Private Const CSIDL_PERSONAL = &H5
Private Const CSIDL_FAVORITES = &H6
Private Const CSIDL_STARTUP = &H7
Private Const CSIDL_RECENT = &H8
Private Const CSIDL_SENDTO = &H9
Private Const CSIDL_BITBUCKET = &HA
Private Const CSIDL_STARTMENU = &HB
Private Const CSIDL_DESKTOPDIRECTORY = &H10
Private Const CSIDL_DRIVES = &H11
Private Const CSIDL_NETWORK = &H12
Private Const CSIDL_NETHOOD = &H13
Private Const CSIDL_FONTS = &H14
Private Const CSIDL_TEMPLATES = &H15
Private Const BIF_RETURNONLYFSDIRS = &H1
Private Const BIF_DONTGOBELOWDOMAIN = &H2
Private Const BIF_STATUSTEXT = &H4
Private Const BIF_RETURNFSANCESTORS = &H8
Private Const BIF_BROWSEFORCOMPUTER = &H1000
Private Const BIF_BROWSEFORPRINTER = &H2000
Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_WININICHANGE = &H1A

Public Sub SetDefaultPrinter(objPrn As Printer)

   Dim X As Long, szTmp As String

   szTmp = objPrn.DeviceName & "," & objPrn.DriverName & "," & objPrn.Port
   X = WriteProfileString("windows", "device", szTmp)
   X = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Sub
Public Function GetDefaultPrinter() As String

   Dim X As Long, szTmp As String, dwBuf As Long

   dwBuf = 1024
   szTmp = Space(dwBuf + 1)
   X = GetProfileString("windows", "device", "", szTmp, dwBuf)
   GetDefaultPrinter = Trim(Left(szTmp, X))

End Function
Public Sub ResetDefaultPrinter(szBuf As String)

   Dim X As Long

   X = WriteProfileString("windows", "device", szBuf)
   X = SendMessageByString(HWND_BROADCAST, WM_WININICHANGE, 0&, "windows")

End Sub
Public Function BrowseFolder(f As Form, szDialogTitle As String) As String

   Dim X As Long, BI As BROWSEINFO, dwIList As Long, szPath As String, wPos As Integer

   BI.hOwner = f.hwnd
   BI.lpszTitle = szDialogTitle
   BI.ulFlags = BIF_RETURNONLYFSDIRS
   dwIList = SHBrowseForFolder(BI)
   szPath = Space$(512)
   X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
   If X Then
      wPos = InStr(szPath, Chr(0))
      BrowseFolder = Left$(szPath, wPos - 1)
   Else
      BrowseFolder = ""
   End If
End Function

Public Function DialogConnectToPrinter(f As Form) As Boolean

   Dim X As Long
   DialogConnectToPrinter = True
   X = ConnectToPrinterDlg(f.hwnd, 0)

End Function
Private Function ByteToString(aBytes() As Byte) As String

   Dim dwBytePoint As Long, dwByteVal As Long, szOut As String

   dwBytePoint = LBound(aBytes)

   While dwBytePoint <= UBound(aBytes)

      dwByteVal = aBytes(dwBytePoint)

      If dwByteVal = 0 Then
         ByteToString = szOut
         Exit Function
      Else
         szOut = szOut & Chr$(dwByteVal)
      End If

      dwBytePoint = dwBytePoint + 1

   Wend

   ByteToString = szOut

End Function
Public Function DialogColor(f As Form) As Long

   Dim X As Long, CS As COLORSTRUC, CustColor(16) As Long

   CS.lStructSize = Len(CS)
   CS.hwnd = f.hwnd
   CS.hInstance = App.hInstance
   CS.Flags = CC_SOLIDCOLOR
   CS.lpCustColors = String$(16 * 4, 0)
   X = ChooseColor(CS)
   If X = 0 Then
      DialogColor = False
   Else
      DialogColor = True
      DialogColor = CS.rgbResult
   End If
End Function


Public Function DialogFile(f As Form, wMode As Integer, szDialogTitle As String, szFilename As String, szFilter As String, szDefDir As String, szDefExt As String) As String
   Dim X As Long, OFN As OPENFILENAME, szFile As String, szFileTitle As String
   OFN.lStructSize = Len(OFN)
   OFN.hwnd = f.hwnd
   OFN.lpstrTitle = szDialogTitle
   OFN.lpstrFile = szFilename & String$(250 - Len(szFilename), 0)
   OFN.nMaxFile = 255
   OFN.lpstrFileTitle = String$(255, 0)
   OFN.nMaxFileTitle = 255
   OFN.lpstrFilter = szFilter
   OFN.nFilterIndex = 1
   OFN.lpstrInitialDir = szDefDir
   OFN.lpstrDefExt = szDefExt
   If wMode = 1 Then
      OFN.Flags = OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST
      X = GetOpenFileName(OFN)
   Else
      OFN.Flags = OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT Or OFN_PATHMUSTEXIST
      X = GetSaveFileName(OFN)
   End If
   If X <> 0 Then
      '// If InStr(OFN.lpstrFileTitle, Chr$(0)) > 0 Then
      '//     szFileTitle = Left$(OFN.lpstrFileTitle, InStr(OFN.lpstrFileTitle, Chr$(0)) - 1)
      '// End If
      If InStr(OFN.lpstrFile, Chr$(0)) > 0 Then
         szFile = Left$(OFN.lpstrFile, InStr(OFN.lpstrFile, Chr$(0)) - 1)
      End If
      '// OFN.nFileOffset is the number of characters from the beginning of the
      '// full path to the start of the file name
      '// OFN.nFileExtension is the number of characters from the beginning of the
      '// full path to the file's extention, including the (.)
      '// MsgBox "File Name is " & szFileTitle & Chr$(13) & Chr$(10) & "Full path and file is " & szFile, , "Open"

      '// DialogFile = szFile & "|" & szFileTitle
      DialogFile = szFile
   Else
      DialogFile = ""
   End If
End Function

Public Function DialogFont(f As Form, c As Control) As Boolean

   Dim LF As LOGFONT, FS As FONTSTRUC
   Dim lLogFontAddress As Long, lMemHandle As Long

   If c.FontBold Then LF.lfWeight = FW_BOLD
   If c.FontItalic = True Then LF.lfItalic = 1
   If c.FontUnderline = True Then LF.lfUnderline = 1
   If c.FontStrikethru = True Then LF.lfStrikeOut = 1

   FS.lStructSize = Len(FS)

   lMemHandle = GlobalAlloc(GHND, Len(LF))
   If lMemHandle = 0 Then
      DialogFont = False
      Exit Function
   End If

   lLogFontAddress = GlobalLock(lMemHandle)
   If lLogFontAddress = 0 Then
      DialogFont = False
      Exit Function
   End If

   CopyMemory ByVal lLogFontAddress, LF, Len(LF)
   FS.lpLogFont = lLogFontAddress
   FS.iPointSize = c.FontSize * 10
   FS.Flags = CF_SCREENFONTS Or CF_EFFECTS

   If ChooseFont(FS) = 1 Then

      CopyMemory LF, ByVal lLogFontAddress, Len(LF)

      If LF.lfWeight >= FW_BOLD Then
         c.FontBold = True
      Else
         c.FontBold = False
      End If

      If LF.lfItalic = 1 Then
         c.FontItalic = True
      Else
         c.FontItalic = False
      End If

      If LF.lfUnderline = 1 Then
         c.FontUnderline = True
      Else
         c.FontUnderline = False
      End If

      If LF.lfStrikeOut = 1 Then
         c.FontStrikethru = True
      Else
         c.FontStrikethru = False
      End If

      c.FontName = ByteToString(LF.lfFaceName())
      c.FontSize = CLng(FS.iPointSize / 10)

      DialogFont = True

   Else

      DialogFont = False

   End If

End Function
Public Function DialogPrint(hwnd As Long, bPages As Boolean, Flags As Long) As PRINTPROPS

   Dim DM As DEVMODE, PD As PRINTDLGSTRUC
   Dim lpDM As Long, wNull As Integer, szDevName As String

   PD.lStructSize = Len(PD)
   PD.hwnd = hwnd
   PD.hDevMode = 0
   PD.hDevNames = 0
   PD.hDC = 0
   PD.Flags = Flags
   PD.nFromPage = 0
   PD.nToPage = 0
   PD.nMinPage = 0
   If bPages Then PD.nMaxPage = bPages - 1
   PD.nCopies = 0
   DialogPrint.Cancel = True

   If PrintDlg(PD) Then

      lpDM = GlobalLock(PD.hDevMode)
      CopyMemory DM, ByVal lpDM, Len(DM)
      lpDM = GlobalUnlock(PD.hDevMode)

      DialogPrint.Cancel = False

      DialogPrint.Device = Left$(DM.dmDeviceName, InStr(DM.dmDeviceName, Chr(0)) - 1)

      If PD.Flags And PD_PRINTTOFILE Then DialogPrint.ToFile = True Else DialogPrint.ToFile = False

      If PD.Flags And PD_PAGENUMS Then
         DialogPrint.Range = ppRangePages
         DialogPrint.FromPage = PD.nFromPage
         DialogPrint.ToPage = PD.nToPage
      ElseIf PD.Flags And PD_SELECTION Then
         DialogPrint.Range = ppRangeSelection
         DialogPrint.FromPage = 0
         DialogPrint.ToPage = 0
      Else
         DialogPrint.Range = ppRangeAll
         DialogPrint.FromPage = 0
         DialogPrint.ToPage = 0
      End If

      If PD.nCopies = 1 Then
         DialogPrint.Copies = DM.dmCopies
      End If

   End If

End Function
Public Function DialogPrintSetup(f As Form)

   Dim X As Long, PD As PRINTDLGSTRUC

   PD.lStructSize = Len(PD)
   PD.hwnd = f.hwnd
   PD.Flags = PD_PRINTSETUP
   X = PrintDlg(PD)

End Function