epcmdlg.ctl

多功能文档编辑器源代码,用VC++开发,适合编程人员参考使用。

    m_DialogTitle = PropBag.ReadProperty("DialogTitle", m_def_DialogTitle)
    m_InitialDir = PropBag.ReadProperty("InitialDir", m_def_InitialDir)
    m_Filter = PropBag.ReadProperty("Filter", m_def_Filter)
    m_FilterIndex = PropBag.ReadProperty("FilterIndex", m_def_FilterIndex)
    m_MultiSelect = PropBag.ReadProperty("MultiSelect", m_def_MultiSelect)
End Sub

Private Sub UserControl_Resize()
    imgLogo.top = 0
    imgLogo.Left = 0
    UserControl.Height = imgLogo.Height
    UserControl.Width = imgLogo.Width
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
    Call PropBag.WriteProperty("CancelError", m_CancelError, m_def_CancelError)
    Call PropBag.WriteProperty("DefaultFilename", m_Filename, m_def_Filename)
    Call PropBag.WriteProperty("DialogTitle", m_DialogTitle, m_def_DialogTitle)
    Call PropBag.WriteProperty("InitialDir", m_InitialDir, m_def_InitialDir)
    Call PropBag.WriteProperty("Filter", m_Filter, m_def_Filter)
    Call PropBag.WriteProperty("FilterIndex", m_FilterIndex, m_def_FilterIndex)
    Call PropBag.WriteProperty("MultiSelect", m_MultiSelect, m_def_MultiSelect)
End Sub

Public Function ShowOpen()
    '** Description:
    '** Calls open dialog without OCX
    Dim epOFN As OPENFILENAME
    Dim lngRet As Long
    With epOFN

        If MultiSelect Then 'If Multi Select then
            .flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
            .lpstrFile = DefaultFilename & Space(9999 - Len(DefaultFilename)) & vbNullChar
            .lpstrFileTitle = Space(9999) & vbNullChar
        Else
            .flags = OFN_PATHMUSTEXIST Or OFN_FILEMUSTEXIST Or OFN_HIDEREADONLY
            .lpstrFile = DefaultFilename & String(MAX_PATH - Len(DefaultFilename), 0) & vbNullChar
            .lpstrFileTitle = String(MAX_PATH, 0) & vbNullChar
        End If

        .hwndOwner = UserControl.ContainerHwnd 'Handle to window
        .lpstrFilter = SetFilter(Filter) & vbNullChar 'File filter
        .lpstrInitialDir = InitialDir & vbNullChar 'Initial directory
        .lpstrTitle = DialogTitle & vbNullChar 'Dialog title
        .lStructSize = Len(epOFN) 'Structure size in bytes
        .nFilterIndex = FilterIndex 'Filter index
        .nMaxFile = Len(.lpstrFile) 'Maximum file length
        .nMaxFileTitle = Len(.lpstrFileTitle) 'Maximum file title length
    End With

    lngRet = GetOpenFileName(epOFN) 'Call open dialog

    If lngRet <> 0 Then 'If there are no errors continue with opening file
        ParseFileName epOFN.lpstrFile
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If
End Function

Public Function ShowSave()
    '** Description:
    '** Calls save dialog without OCX
    Dim epOFN As OPENFILENAME
    Dim lngRet As Long
    With epOFN
        .hwndOwner = UserControl.ContainerHwnd 'Handle to window
        .flags = OFN_PATHMUSTEXIST Or OFN_HIDEREADONLY Or OFN_OVERWRITEPROMPT
        .lpstrFile = DefaultFilename & String(MAX_PATH - Len(DefaultFilename), 0) & vbNullChar
        .lpstrFileTitle = String(MAX_PATH, 0) & vbNullChar
        .lpstrFilter = SetFilter(Filter) & vbNullChar 'File filter
        .lpstrInitialDir = InitialDir & vbNullChar 'Initial directory
        .lpstrTitle = DialogTitle & vbNullChar 'Dialog title
        .lStructSize = Len(epOFN) 'Structure size in bytes
        .nFilterIndex = FilterIndex 'Filter index
        .nMaxFile = Len(.lpstrFile) 'Maximum file length
        .nMaxFileTitle = Len(.lpstrFileTitle) 'Maximum file title length
    End With

    lngRet = GetSaveFileName(epOFN) 'Call save dialog

    If lngRet <> 0 Then 'If there are no errors continue with saving file
        ParseFileName epOFN.lpstrFile
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If
End Function

Public Function ShowFont()
    '** Description:
    '** Call font dialog without OCX
    Dim CF As CHOOSEFONT
    Dim LF As LOGFONT
    Dim lMemHandle As Long
    Dim lLogFont As Long
    Dim lngRet As Long

    With LF
        .lfCharSet = DEFAULT_CHARSET 'Default character set
        .lfClipPrecision = CLIP_DEFAULT_PRECIS 'Clipping precision
        .lfFaceName = "Arial" & vbNullChar 'Font name
        .lfHeight = 13 'Height
        .lfOutPrecision = OUT_DEFAULT_PRECIS 'Precision mapping
        .lfPitchAndFamily = DEFAULT_PITCH Or FF_ROMAN 'Default pitch
        .lfQuality = DEFAULT_QUALITY 'Default quality
        .lfWeight = FW_NORMAL 'Regular font type
    End With

    ' Create the memory block
    lMemHandle = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(LF))
    lLogFont = GlobalLock(lMemHandle)
    CopyMemory ByVal lLogFont, LF, Len(LF)

    With CF
        .flags = CF_BOTH Or CF_EFFECTS Or CF_FORCEFONTEXIST Or CF_INITTOLOGFONTSTRUCT Or CF_LIMITSIZE
        .hDC = Printer.hDC 'Device context of default printer
        .hwndOwner = UserControl.ContainerHwnd 'Handle to window
        .iPointSize = 120 'Set font size to 12 size
        .lpLogFont = lLogFont 'Log font
        .lStructSize = Len(CF) 'Size of structure in bytes
        .nFontType = REGULAR_FONTTYPE 'Regular font type
        .nSizeMax = 72 'Maximum font size
        .nSizeMin = 10 'Minimum font size
        .rgbColors = RGB(0, 0, 0) 'Font color
    End With

    lngRet = CHOOSEFONT(CF) 'Call font dialog
    If lngRet <> 0 Then 'If there are no errors continue with font
        CopyMemory LF, ByVal lLogFont, Len(LF)

        FontName = Left(LF.lfFaceName, InStr(LF.lfFaceName, vbNullChar) - 1)
        FontSize = CF.iPointSize / 10
        FontColor = CF.rgbColors
        If LF.lfWeight = FW_NORMAL Then
            FontBold = False
            FontItalic = False
            FontUnderline = False
            FontStrikeThru = False
        Else
            If LF.lfWeight = FW_BOLD Then FontBold = True
            If LF.lfItalic <> 0 Then FontItalic = True
            If LF.lfUnderline <> 0 Then FontUnderline = True
            If LF.lfStrikeOut <> 0 Then FontStrikeThru = True
        End If
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If

    ' Unlock and free the memory block
    ' Note this must be done
    GlobalUnlock lMemHandle
    GlobalFree lMemHandle
End Function

Public Function ShowColor()
    '** Description:
    '** Call color dialog without OCX
    Dim epCC As ChooseColor
    Dim lngRet As Long
    Dim CusCol(0 To 16) As Long
    Dim i As Integer

    ' Fills custom colors with white
    For i = 0 To 15
        CusCol(i) = vbWhite
    Next

    With epCC
        .hwndOwner = UserControl.ContainerHwnd 'Handle to window
        .lStructSize = Len(epCC) 'Structure size in bytes
        .lpCustColors = VarPtr(CusCol(0)) 'Custom colors
        .rgbResult = 0 'RGB result
    End With

    lngRet = ChooseColor(epCC) 'Call color dialog
    If lngRet <> 0 Then 'If there are no errors continue with color
        ShowColor = epCC.rgbResult
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If
End Function

Public Function ShowPageSetup()
    '** Description:
    '** Call page setup dialog without OCX
    Dim epPSD As PageSetupDlg
    Dim lngRet As Long

    epPSD.lStructSize = Len(epPSD) 'Structure size in bytes
    epPSD.hwndOwner = UserControl.ContainerHwnd 'Handle to window

    lngRet = PageSetupDlg(epPSD) 'Call page setup dialog
    If lngRet <> 0 Then 'If there are no errors continue
        '
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If
End Function

Public Function ShowPrinter()
    '** Description:
    '** Call printer dialog without OCX
    '**
    '** Note:
    '** This is not my function it's from KPD-Team 1998 URL: http://www.allapi.net
    '** and i have modified it a little
    '-> Code by Donald Grover
    Dim PrintDlg As PRINTDLG_TYPE
    Dim DevMode As DEVMODE_TYPE
    Dim DevName As DEVNAMES_TYPE

    Dim lpDevMode As Long, lpDevName As Long
    Dim bReturn As Integer
    Dim objPrinter As Printer, NewPrinterName As String

    ' Use PrintDialog to get the handle to a memory
    ' block with a DevMode and DevName structures

    PrintDlg.lStructSize = Len(PrintDlg)
    PrintDlg.hwndOwner = UserControl.ContainerHwnd 'Handle to window

    On Error Resume Next
    'Set the current orientation and duplex setting
    DevMode.dmDeviceName = Printer.DeviceName
    DevMode.dmSize = Len(DevMode)
    DevMode.dmFields = DM_ORIENTATION Or DM_DUPLEX
    DevMode.dmPaperWidth = Printer.Width
    DevMode.dmOrientation = Printer.Orientation
    DevMode.dmPaperSize = Printer.PaperSize
    DevMode.dmDuplex = Printer.Duplex
    On Error GoTo 0

    'Allocate memory for the initialization hDevMode structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevMode = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevMode))
    lpDevMode = GlobalLock(PrintDlg.hDevMode)
    If lpDevMode > 0 Then
        CopyMemory ByVal lpDevMode, DevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
    End If

    'Set the current driver, device, and port name strings
    With DevName
        .wDriverOffset = 8
        .wDeviceOffset = .wDriverOffset + 1 + Len(Printer.DriverName)
        .wOutputOffset = .wDeviceOffset + 1 + Len(Printer.Port)
        .wDefault = 0
    End With

    With Printer
        DevName.extra = .DriverName & Chr(0) & .DeviceName & Chr(0) & .Port & Chr(0)
    End With

    'Allocate memory for the initial hDevName structure
    'and copy the settings gathered above into this memory
    PrintDlg.hDevNames = GlobalAlloc(GMEM_MOVEABLE Or GMEM_ZEROINIT, Len(DevName))
    lpDevName = GlobalLock(PrintDlg.hDevNames)
    If lpDevName > 0 Then
        CopyMemory ByVal lpDevName, DevName, Len(DevName)
        bReturn = GlobalUnlock(lpDevName)
    End If

    'Call the print dialog up and let the user make changes
    If PrintDialog(PrintDlg) <> 0 Then

        'First get the DevName structure.
        lpDevName = GlobalLock(PrintDlg.hDevNames)
        CopyMemory DevName, ByVal lpDevName, 45
        bReturn = GlobalUnlock(lpDevName)
        GlobalFree PrintDlg.hDevNames

        'Next get the DevMode structure and set the printer
        'properties appropriately
        lpDevMode = GlobalLock(PrintDlg.hDevMode)
        CopyMemory DevMode, ByVal lpDevMode, Len(DevMode)
        bReturn = GlobalUnlock(PrintDlg.hDevMode)
        GlobalFree PrintDlg.hDevMode
        NewPrinterName = UCase$(Left(DevMode.dmDeviceName, InStr(DevMode.dmDeviceName, Chr$(0)) - 1))
        If Printer.DeviceName <> NewPrinterName Then
            For Each objPrinter In Printers
                If UCase$(objPrinter.DeviceName) = NewPrinterName Then
                    Set Printer = objPrinter
                    'set printer toolbar name at this point
                End If
            Next
        End If

        On Error Resume Next
        'Set printer object properties according to selections made
        'by user
        Printer.Copies = DevMode.dmCopies
        Printer.Duplex = DevMode.dmDuplex
        Printer.Orientation = DevMode.dmOrientation
        Printer.PaperSize = DevMode.dmPaperSize
        Printer.PrintQuality = DevMode.dmPrintQuality
        Printer.ColorMode = DevMode.dmColor
        Printer.PaperBin = DevMode.dmDefaultSource
        On Error GoTo 0
    Else
        If CancelError Then
            ' For this to work you must check in Tools\Options\General
            ' Break on Unhandled errors if it isn't already checked
            err.Raise 32755, App.EXEName, "Cancel was selected.", "cmdlg98.chm", 32755
        End If
    End If
End Function

Private Function ParseFileName(sFileName As String)
    '** Description:
    '** Remove null chars from filename and parse multi filename
    '**
    '** Syntax:
    '** szFilename = ParseFileName(strFilename)
    '**
    '** Example:
    '** szFilename = ParseFileName("C:\Autoexec.bat||")
    Dim i As Long
    Dim sPath As String
    Dim sFiles() As String
    Dim Pos As Integer
    Dim sfile As String
    Dim sFileTitle As String

    ' Create new collections
    Set cFileName = New Collection
    Set cFileTitle = New Collection
    ' Found position of two last null chars
    Pos = InStr(sFileName, vbNullChar & vbNullChar)
    ' Remove from filename last two chars
    sfile = Left(sFileName, Pos - 1)

    ' Check to see if filename is single or multi
    If InStr(1, sfile, vbNullChar) <> 0 Then
        ' Multi file
        sfile = Left(sFileName, Pos) & vbNullChar 'Add null char at end of filename
        sPath = Left(sFileName, InStr(1, sFileName, Chr(0)) - 1) 'Get file path
        sFiles = split(sfile, Chr(0)) 'Split file where is nullchar

        ' Add all filenames to collection
        For i = LBound(sFiles) To UBound(sFiles) - 2
            ' If path doesent contain separator then add it
            If Right(sPath, 1) = "\" Then
                cFileName.Add sPath & sFiles(i)
            Else
                cFileName.Add sPath & "\" & sFiles(i)
            End If
            ' Add file title
            cFileTitle.Add sFiles(i)
            ' Remove first item from collections
            If i = 1 Then cFileName.Remove 1: cFileTitle.Remove 1
        Next
    Else ' Single file
        'Add file name to collection
        cFileName.Add sfile
        ' Add file title
        cFileTitle.Add Right(sfile, Len(sfile) - InStrRev(sfile, "\"))
    End If
End Function

Private Function SetFilter(sFlt As String) As String
    '** Description:
    '** Replace "|" with Null Character
    '**
    '** Syntax:
    '** szFilter = SetFilter(strFilter)
    '**
    '** Example:
   
    Dim sLen As Long
    Dim Pos As Long
    sLen = Len(sFlt) 'Get filter length
    Pos = InStr(1, sFlt, "|") 'Find first position of "|"

    ' Loop while Pos > 0
    While Pos > 0
        ' Replace "|" with null char
        sFlt = Left(sFlt, Pos - 1) & vbNullChar & Mid(sFlt, Pos + 1, sLen - Pos)
        ' Find next position of "|"
        Pos = InStr(Pos + 1, sFlt, "|")
    Wend
    SetFilter = sFlt ' Set filter
End Function