Results 1 to 4 of 4

Thread: ClsComDlg.cls【VB6 api for comdlg32.dll without COMDLG32.OCX】

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    ClsComDlg.cls【VB6 api for comdlg32.dll without COMDLG32.OCX】

    Code:
    'in form1
    Private Sub Command1_Click()
    Dim A As ClsComDlg
    Set A = New ClsComDlg
    A.ShowColorFlags = cdlCCFullOpen Or cdlCCRGBInit
    A.Color = vbYellow
    A.ShowColor (Me.hWnd)
    Me.BackColor = A.Color
    
    End Sub
    ClsComDlg.cls :

    Code:
    Option Explicit
    Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long
    Private Declare Function ChooseColor Lib "comdlg32.dll" Alias "ChooseColorA" (pChoosecolor As CHOOSECOLORS) As Long
    Private Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long
    Private Declare Function GetShortPathName Lib "KERNEL32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal cchBuffer As Long) As Long
    Private Declare Function ChooseFont Lib "comdlg32.dll" Alias "ChooseFontA" (pChoosefont As CHOOSEFONTS) As Long
    Private Declare Function PrintDlg Lib "comdlg32.dll" Alias "PrintDlgA" (pPrintdlg As PRINTDLGS) As Long
    Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
    Private Declare Function ReleaseDC Lib "user32" (ByVal hWnd As Long, ByVal hDC As Long) As Long
    Private Const LF_FACESIZE = 32
    Private Type OPENFILENAME
        nStructSize As Long
        hwndOwner As Long
        hInstance As Long
        sFilter As String
        sCustomFilter As String
        nCustFilterSize As Long
        nFilterIndex As Long
        sFile As String
        nFileSize As Long
        sFileTitle As String
        nTitleSize As Long
        sInitDir As String
        sDlgTitle As String
        Flags As Long
        nFileOffset As Integer
        nFileExt As Integer
        sDefFileExt As String
        nCustDataSize As Long
        fnHook As Long
        sTemplateName As String
    End Type
    Private Type CHOOSECOLORS
        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 String
    End 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(LF_FACESIZE) As Byte
    End Type
    Private Type CHOOSEFONTS
        lStructSize As Long
        hwndOwner As Long ' caller's window handle
        hDC As Long ' printer DC/IC or NULL
        lpLogFont As Long ' ptr. to a LOGFONT struct
        iPointSize As Long ' 10 * size in points of selected font
        Flags As Long ' enum. private Type flags
        rgbColors As Long ' returned text color
        lCustData As Long ' data passed to hook fn.
        lpfnHook As Long ' ptr. to hook function
        lpTemplateName As String ' custom template name
        hInstance As Long ' instance handle of.EXE that
        lpszStyle As String ' return the style field here
        nFontType As Integer ' same value reported to the EnumFonts
        MISSING_ALIGNMENT As Integer
        nSizeMin As Long ' minimum pt size allowed &
        nSizeMax As Long ' max pt size allowed if
    End Type
    Private Const CF_INITTOLOGFONTSTRUCT = &H40&
    Private Type PRINTDLGS
        lStructSize As Long
        hwndOwner As Long
        hDevMode As Long
        hDevNames As Long
        hDC As Long
        Flags As Long
        nFromPage As Integer
        nToPage As Integer
        nMinPage As Integer
        nMaxPage As Integer
        nCopies As Integer
        hInstance As Long
        lCustData As Long
        lpfnPrintHook As Long
        lpfnSetupHook As Long
        lpPrintTemplateName As String
        lpSetupTemplateName As String
        hPrintTemplate As Long
        hSetupTemplate As Long
    End Type
    Public Enum FileFlags
        cdlOFNAllowMultiselect = &H200
        cdlOFNCreatePrompt = &H2000
        cdlOFNExplorer = &H80000
        cdlOFNExtensionDifferent = &H400
        cdlOFNFileMustExist = &H1000
        cdlOFNHelpButton = &H10
        cdlOFNHideReadOnly = &H4
        cdlOFNLongNames = &H200000
        cdlOFNNoChangeDir = &H8
        cdlOFNNoDereferenceLinks = &H100000
        cdlOFNNoLongNames = &H40000
        cdlOFNNoReadOnlyReturn = &H8000
        cdlOFNNoValidate = &H100
        cdlOFNOverwritePrompt = &H2
        cdlOFNPathMustExist = &H800
        cdlOFNReadOnly = &H1
        cdlOFNShareAware = &H4000
    End Enum
    Public Enum PrintFlags
        cdlPDAllPages = &H0
        cdlPDCollate = &H10
        cdlPDDisablePrintToFile = &H80000
        cdlPDHelpButton = &H800
        cdlPDHidePrintToFile = &H100000
        cdlPDNoPageNums = &H8
        cdlPDNoSelection = &H4
        cdlPDNoWarning = &H80
        cdlPDPageNums = &H2
        cdlPDPrintSetup = &H40
        cdlPDPrintToFile = &H20
        cdlPDReturnDC = &H100
        cdlPDReturnDefault = &H400
        cdlPDReturnIC = &H200
        cdlPDSelection = &H1
        cdlPDUseDevModeCopies = &H40000
    End Enum
    Public Enum ColorFlags
        cdlCCFullOpen = &H2
        cdlCCShowHelpButton = &H8
        cdlCCPreventFullOpen = &H4
        cdlCCRGBInit = &H1
    End Enum
    Public Enum FontFlags
        cdlCFANSIOnly = &H400
        cdlCFApply = &H200
        cdlCFBoth = &H3
        cdlCFEffects = &H100
        cdlCFFixedPitchOnly = &H4000
        cdlCFForceFontExist = &H10000
        cdlCFHelpButton = &H4
        cdlCFLimitSize = &H2000
        cdlCFNoFaceSel = &H80000
        cdlCFNoSimulations = &H1000
        cdlCFNoSizeSel = &H200000
        cdlCFNoStyleSel = &H100000
        cdlCFNoVectorFonts = &H800
        cdlCFPrinterFonts = &H2
        cdlCFScalableOnly = &H20000
        cdlCFScreenFonts = &H1
        cdlCFTTOnly = &H40000
        cdlCFWYSIWYG = &H8000
    End Enum
    Private FileDialog As OPENFILENAME
    Private ColorDialog As CHOOSECOLORS
    Private FontDialog As CHOOSEFONTS
    Private PrintDialog As PRINTDLGS
    Private bCanceled As Boolean
    Private tFontName As String
    Private tFontBold As Boolean
    Private tFontItalic As Boolean
    Private tFontUnderline As Boolean
    Private tFontStrike As Boolean
    Private tFontSize As Long
    Private tFontCharSet As Byte
    Private tFontColor As Long
    Public Sub ShowOpen(ByVal hWnd As Long)
        Dim ret As Long
        
        If FileDialog.sDlgTitle = "" Then FileDialog.sDlgTitle = "打开"
        FileDialog.nStructSize = Len(FileDialog)
        FileDialog.hwndOwner = hWnd
        FileDialog.sFileTitle = Space$(2048)
        FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
        FileDialog.sFile = FileDialog.sFile & Space$(2047) & Chr$(0)
        FileDialog.nFileSize = Len(FileDialog.sFile)
        
        ret = GetOpenFileName(FileDialog)
        If ret Then
            bCanceled = False
        Else
            bCanceled = True
        End If
    End Sub
    Public Sub ShowSave(ByVal hWnd As Long)
        Dim ret As Long
        
        If FileDialog.sDlgTitle = "" Then FileDialog.sDlgTitle = "另存为"
        FileDialog.nStructSize = Len(FileDialog)
        FileDialog.hwndOwner = hWnd
        FileDialog.sFileTitle = Space$(2048)
        FileDialog.nTitleSize = Len(FileDialog.sFileTitle)
        FileDialog.sFile = Space$(2047) & Chr$(0)
        FileDialog.nFileSize = Len(FileDialog.sFile)
        
    '    If FileDialog.Flags = 0 Then
    '        FileDialog.Flags = OFS_FILE_SAVE_FLAGS
    '    End If
        ret = GetSaveFileName(FileDialog)
        If ret Then
            bCanceled = False
        Else
            bCanceled = True
        End If
    End Sub
    Public Sub ShowColor(ByVal hWnd As Long)
        Dim customcolors() As Byte ' dynamic (resizable) array
        Dim i As Integer
        Dim ret As Long
            
        If ColorDialog.lpCustColors = "" Then
            ReDim customcolors(0 To 16 * 4 - 1) As Byte 'resize the array
        
            For i = LBound(customcolors) To UBound(customcolors)
                customcolors(i) = 254 ' sets all custom colors to white
            Next i
            
            ColorDialog.lpCustColors = StrConv(customcolors, vbUnicode) ' convert array
        End If
        ColorDialog.hwndOwner = hWnd
        ColorDialog.lStructSize = Len(ColorDialog)
    '    ColorDialog.Flags = COLOR_FLAGS
        
        ret = ChooseColor(ColorDialog)
        If ret Then
            bCanceled = False
        Else
            bCanceled = True
        End If
    End Sub
    Public Sub ShowFont(ByVal hWnd As Long) ', ByVal startingFontName As String)
        Dim ret As Long
        Dim lfLogFont As LOGFONT
        Dim i As Integer
        
        FontDialog.nSizeMax = 0
        FontDialog.nSizeMin = 0
        FontDialog.nFontType = Screen.FontCount
        FontDialog.hwndOwner = hWnd
        FontDialog.hDC = 0
        FontDialog.lpfnHook = 0
        FontDialog.lCustData = 0
        FontDialog.lpLogFont = VarPtr(lfLogFont)
        If FontDialog.iPointSize = 0 Then
            FontDialog.iPointSize = 10 * 10
        End If
        FontDialog.lpTemplateName = Space$(2048)
        FontDialog.rgbColors = RGB(0, 255, 255)
        FontDialog.lStructSize = Len(FontDialog)
        
        If FontDialog.Flags = 0 Then
            FontDialog.Flags = FontFlags.cdlCFScreenFonts Or FontFlags.cdlCFEffects Or CF_INITTOLOGFONTSTRUCT
        End If
        For i = 0 To Len(tFontName) - 1
            lfLogFont.lfFaceName(i) = Asc(Mid(tFontName, i + 1, 1))
        Next
        
        ret = ChooseFont(FontDialog)
        
        If ret Then
            bCanceled = False
            tFontBold = IIf(lfLogFont.lfWeight > 400, True, False)
            tFontItalic = lfLogFont.lfItalic
            tFontStrike = lfLogFont.lfStrikeOut
            tFontUnderline = lfLogFont.lfUnderline
            tFontColor = FontDialog.rgbColors
            tFontCharSet = lfLogFont.lfCharSet
            tFontSize = FontDialog.iPointSize / 10
            tFontName = ""
    '        For i = 0 To UBound(lfLogFont.lfFaceName)
    '            tFontName = tFontName + Chr(lfLogFont.lfFaceName(i))
    '        Next
            tFontName = StrConv(lfLogFont.lfFaceName, vbUnicode)
            
            tFontName = Mid(tFontName, 1, InStr(1, tFontName, Chr(0)) - 1)
        Else
            bCanceled = True
        End If
    End Sub
    Public Sub ShowPrinter(ByVal hWnd As Long)
        PrintDialog.hwndOwner = hWnd
        PrintDialog.lStructSize = Len(PrintDialog)
        Call PrintDlg(PrintDialog)
    End Sub
    Public Property Get FileName() As String
        Dim s As String
        Dim charAsc As Long
        Dim i As Long
        
        On Error GoTo ErrEnd
        s = Trim(Left(FileDialog.sFile, Len(FileDialog.sFile) - 1))
        If Len(s) = 0 Then Exit Property
        
        i = 1
        Do Until charAsc <> 0
            charAsc = Asc(Mid(s, Len(s) - i, 1))
            i = i + 1
        Loop
        s = Left(s, Len(s) - i + 1)
        FileName = s
    ErrEnd:
    End Property
    Public Property Get InitDir() As String
        InitDir = FileDialog.sInitDir
    End Property
    Public Property Let InitDir(ByVal vNewValue As String)
        FileDialog.sInitDir = vNewValue
    End Property
    Public Property Get Filter() As String
        Filter = FileDialog.sFilter
    End Property
    Public Property Let Filter(ByVal vNewValue As String)
        FileDialog.sFilter = Replace(vNewValue, "|", Chr(0))
    End Property
    Public Property Get ShowOpenFlags() As FileFlags
        ShowOpenFlags = FileDialog.Flags
    End Property
    Public Property Let ShowOpenFlags(ByVal vNewValue As FileFlags)
        FileDialog.Flags = vNewValue
    End Property
    Public Property Get ShowSaveFlags() As FileFlags
        ShowSaveFlags = FileDialog.Flags
    End Property
    Public Property Let ShowSaveFlags(ByVal vNewValue As FileFlags)
        FileDialog.Flags = vNewValue
    End Property
    Public Property Get ShowColorFlags() As ColorFlags
        ShowColorFlags = ColorDialog.Flags
    End Property
    Public Property Let ShowColorFlags(ByVal vNewValue As ColorFlags)
        ColorDialog.Flags = vNewValue
    End Property
    Public Property Get ShowPrintFlags() As PrintFlags
        ShowPrintFlags = PrintDialog.Flags
    End Property
    Public Property Let ShowPrintFlags(ByVal vNewValue As PrintFlags)
        PrintDialog.Flags = vNewValue
    End Property
    Public Property Get ShowFontFlags() As FontFlags
        ShowFontFlags = FontDialog.Flags
    End Property
    Public Property Let ShowFontFlags(ByVal vNewValue As FontFlags)
        FontDialog.Flags = vNewValue
    End Property
    Public Property Get DialogTitle() As String
        DialogTitle = FileDialog.sDlgTitle
    End Property
    Public Property Let DialogTitle(ByVal vNewValue As String)
        FileDialog.sDlgTitle = vNewValue
    End Property
    Public Property Get Cancel() As Boolean
        Cancel = bCanceled
    End Property
    
    
    Public Property Get FontName() As String
        FontName = tFontName
    End Property
    Public Property Let FontName(ByVal vNewValue As String)
        tFontName = vNewValue
    End Property
    Public Property Get FontBold() As Boolean
        FontBold = tFontBold
    End Property
    Public Property Get FontItalic() As Boolean
        FontItalic = tFontItalic
    End Property
    Public Property Get FontCharSet() As Byte
        FontCharSet = tFontCharSet
    End Property
    Public Property Get FontUnderline() As Boolean
        FontUnderline = tFontUnderline
    End Property
    Public Property Get FontStrike() As Boolean
        FontStrike = tFontStrike
    End Property
    Public Property Get FontSize() As Long
        FontSize = tFontSize
    End Property
    Public Property Get FontColor() As Long
        FontColor = tFontColor
    End Property
    
     Public Property Get Color() As Long
        Color = ColorDialog.rgbResult
    End Property
    Public Property Let Color(ByVal vNewValue As Long) '
        ColorDialog.rgbResult = vNewValue
    End Property

  2. #2
    Lively Member
    Join Date
    Aug 2020
    Location
    Victoria Texas 77904
    Posts
    73

    Re: ClsComDlg.cls【VB6 api for comdlg32.dll without COMDLG32.OCX】

    This works really good. Have'nt checked everything yet, but the parts I have tried work smoothly.

  3. #3

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: ClsComDlg.cls【VB6 api for comdlg32.dll without COMDLG32.OCX】

    Quote Originally Posted by KFrosty View Post
    This works really good. Have'nt checked everything yet, but the parts I have tried work smoothly.
    Thank you for your support. It would be great if all the modules BAS, CLS, and control ctl files are assembled into one website, just like the mpm of python, you can search for all modules, controls, forms, background images, and a programming Material network, all API references, all declarations, are directly integrated in the IDE.
    When I started to learn web development for quite a few years, there were various JS special effects, web page background images, banner banner, various materials of PHOTOSHOP, and several CDs.

  4. #4

    Thread Starter
    PowerPoster
    Join Date
    Jan 2020
    Posts
    3,746

    Re: ClsComDlg.cls【VB6 api for comdlg32.dll without COMDLG32.OCX】

    You can also use the registration-free way to load the control, COM DLL.
    Using the control OCX will increase the overall size of the released software, but also register the control, many computers do not have permission, and there will be compatibility issues.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width