minor changes

Classes/ColorDialog.cls

@@ -69,7 +69,7 @@ Private Type ChooseColorW     '      x86 '     x64
     hInstance      As LongPtr '        4 '       8
     rgbResult      As Long    '        4 '       4 + 4pads
     lpCustColors   As LongPtr '        4 '       8
-    flags          As Long    '        4 '       4 + 4pads
+    Flags          As Long    '        4 '       4 + 4pads
     lCustData      As LongPtr '        4 '       8
     lpfnHook       As LongPtr '        4 '       8
     lpTemplateName As LongPtr 'String  4 '       8
@@ -203,19 +203,14 @@ End Function
 
 Public Function ShowDialog(Optional Frm As Variant) As VbMsgBoxResult
     ReDim CancelColors(0 To MaxCustomColors - 1) As Long
-    Dim i As Long
 Try: On Error GoTo Catch
-    'die Custom Farbtabelle sichern 'falls Abbrechen geklickt wurde
-    'For i = 0 To MaxCustomColors - 1
-    '    CancelColors(i) = mCustomColors(i)
-    'Next
     CancelColors() = mCustomColors()
     Dim ahWndOwner As Long
-'    If IsMissing(Frm) Then
-'        ahWndOwner = GetActiveWindow
-'    Else
-'        ahWndOwner = Frm.hwnd
-'    End If
+    If IsMissing(Frm) Then
+        ahWndOwner = GetActiveWindow
+    Else
+        ahWndOwner = Frm.hwnd
+    End If
     Dim ChCl As ChooseColorW
     With ChCl
         .lStructSize = LenB(ChCl)
@@ -228,7 +223,7 @@ Try: On Error GoTo Catch
 '#End If
         .rgbResult = mColor 'RGB(0, 255, 0) 'Farbe voreinstellen
         .lpCustColors = VarPtr(mCustomColors(0)) 'Benutzerdefinierte Farben zuweisen
-        .flags = mFlags
+        .Flags = mFlags
         .lCustData = 0&
         .lpfnHook = 0&
         .lpTemplateName = StrPtr(mTemplateName) '"" '0&

Classes/PrintDialog.cls

@@ -104,9 +104,9 @@ End Type
 '} PROPSHEETPAGEW_V4, *LPPROPSHEETPAGEW_V4;
 
 Private Type PROPSHEETPAGEW_V4
-    pszHeaderTitle As LongPtr 'LPCWSTR
+    pszHeaderTitle    As LongPtr 'LPCWSTR
     pszHeaderSubTitle As LongPtr '  LPCWSTR
-    hActCtx As LongPtr '  HANDLE
+    hActCtx           As LongPtr '  HANDLE
 '  union {
 '    HBITMAP hbmHeader;
 '    LPCWSTR pszbmHeader;

Forms/Form1.frm

@@ -214,6 +214,9 @@ Begin VB.Form Form1
       Begin VB.Menu mnuFileSaveAs 
          Caption         =   "Save &As..."
       End
+      Begin VB.Menu mnuFilePrinter 
+         Caption         =   "Printer"
+      End
       Begin VB.Menu mnuFileSep1 
          Caption         =   "-"
       End
@@ -241,7 +244,7 @@ Begin VB.Form Form1
    End
    Begin VB.Menu mnuOption 
       Caption         =   "&Option"
-      Begin VB.Menu mnuUseOldComDlg 
+      Begin VB.Menu mnuOptionUseOldComDlg 
          Caption         =   "Use old CommonDialog-control"
       End
    End
@@ -277,6 +280,7 @@ Private Sub Command5_Click()
 End Sub
 
 Private Sub Form_Load()
+    mnuFilePrinter.Visible = False
     PrepareSpecialFolder
 End Sub
 
@@ -359,7 +363,7 @@ End Sub
 
 Private Sub mnuFileOpen_Click()
     Dim FNm As String
-    If mnuUseOldComDlg.Checked Then FNm = FileOpenOld Else FNm = FileOpenNew
+    If mnuOptionUseOldComDlg.Checked Then FNm = FileOpenOld Else FNm = FileOpenNew
     If Len(FNm) Then
         MsgBox FNm
         LblOFD.Caption = FNm
@@ -406,7 +410,7 @@ End Function
 
 Private Sub mnuFileSaveAs_Click()
     Dim FNm As String
-    If mnuUseOldComDlg.Checked Then FNm = FileSaveOld Else FNm = FileSaveNew
+    If mnuOptionUseOldComDlg.Checked Then FNm = FileSaveOld Else FNm = FileSaveNew
     If Len(FNm) Then LblSFD.Caption = FNm
 End Sub
 Private Function FileSaveNew() As String
@@ -430,13 +434,107 @@ Try: On Error GoTo Catch
         FileSaveOld = .FileName
     End With
 Catch:
+    If Not Err.Number = MSComDlg.ErrorConstants.cdlCancel Then
+        MComDlgCtrl.MessCommonDlgError Err.Number
+    End If
+End Function
+
+Private Sub mnuFilePrinter_Click()
+    Dim PNm As String
+    If mnuOptionUseOldComDlg.Checked Then PNm = FilePrinterOld Else PNm = FilePrinterNew
+    If Len(PNm) Then MsgBox PNm
+End Sub
+
+Private Function FilePrinterNew() As String
+    FilePrinterNew = Printer.DeviceName
+End Function
+Private Function FilePrinterOld() As String
+Try: On Error GoTo Catch
+    With Me.CommonDialog
+        .CancelError = True
+        .ShowPrinter
+        FilePrinterOld = Printer.DeviceName
+    End With
+Catch:
+    If Not Err.Number = MSComDlg.ErrorConstants.cdlCancel Then
+        MComDlgCtrl.MessCommonDlgError Err.Number
+    End If
 End Function
 
 '--------------------------------------------------
 Private Sub mnuFileExit_Click()
     Unload Me
 End Sub
+
 '==================================================
+Private Sub mnuEditColorChoose_Click()
+    Dim col As Long
+    If mnuOptionUseOldComDlg.Checked Then col = ColorChooseOld Else col = ColorChooseNew
+    If col = -1 Then Exit Sub
+    LblCD.BackColor = col
+End Sub
+Private Function ColorChooseNew() As Long
+    ColorChooseNew = -1
+    With CD
+        .Color = LblCD.BackColor
+        .SolidColorOnly = True
+        If .ShowDialog = vbCancel Then Exit Function
+        ColorChooseNew = .Color
+    End With
+End Function
+Private Function ColorChooseOld() As Long
+    ColorChooseOld = -1
+Try: On Error GoTo Catch
+    With CommonDialog
+        .Color = LblCD.BackColor
+        .CancelError = True
+        .ShowColor
+        ColorChooseOld = .Color
+    End With
+Catch:
+    If Not Err.Number = MSComDlg.ErrorConstants.cdlCancel Then
+        MComDlgCtrl.MessCommonDlgError Err.Number
+    End If
+End Function
+
+Private Sub mnuEditFontChoose_Click()
+    Dim F As StdFont: Set F = LblFD.Font
+    Dim C As Long:        C = LblFD.ForeColor
+    If mnuOptionUseOldComDlg.Checked Then Set F = FontDialogOld(F, C) Else Set F = FontDialogNew(F, C)
+    Set LblFD.Font = F
+    LblFD.ForeColor = C
+End Sub
+
+Private Function FontDialogNew(Font_in As StdFont, ByRef Color_inout As Long) As StdFont
+    With New FontDialog
+        Set .Font = Font_in
+        .Color = Color_inout
+        If .ShowDialog = vbCancel Then Exit Function
+        Set FontDialogNew = .Font
+        Color_inout = .Color
+    End With
+End Function
+Private Function FontDialogOld(Font_in As StdFont, ByRef Color_inout As Long) As StdFont
+Try: On Error GoTo Catch
+    Dim Font As StdFont
+    With CommonDialog
+        .CancelError = True
+        .Color = Color_inout
+        .FontName = Font_in.Name
+        .FontSize = Font_in.Size
+        .FontBold = Font_in.Bold
+        .FontItalic = Font_in.Italic
+        .FontUnderline = Font_in.Underline
+        .FontStrikethru = Font_in.Strikethrough
+        .ShowFont
+    End With
+Catch:
+    FontDialogOld = Font_in
+    If Not Err.Number = MSComDlg.ErrorConstants.cdlCancel Then
+        MComDlgCtrl.MessCommonDlgError Err.Number
+    End If
+End Function
+
 Private Sub mnuEditFolderChoose_Click()
     With New OpenFolderDialog
         '.Title = "Select a folder"
@@ -470,24 +568,21 @@ Private Sub mnuEditPathChoose_Click()
     End With
 End Sub
 
-Private Sub mnuEditColorChoose_Click()
-    With CD
-        .Color = LblCD.BackColor
-        .SolidColorOnly = True
-        If .ShowDialog = vbOK Then
-            LblCD.BackColor = .Color
-        End If
-    End With
+'--------------------------------------
+Private Sub mnuOptionUseOldComDlg_Click()
+    mnuOptionUseOldComDlg.Checked = Not mnuOptionUseOldComDlg.Checked
+    Dim bUseOldComDlg As Boolean: bUseOldComDlg = mnuOptionUseOldComDlg.Checked
+    mnuFilePrinter.Visible = bUseOldComDlg
 End Sub
-
-Private Sub mnuEditFontChoose_Click()
-    With New FontDialog
-        Set .Font = LblFD.Font
-        .Color = LblFD.ForeColor
-        If .ShowDialog = vbCancel Then Exit Sub
-        Set LblFD.Font = .Font
-        LblFD.ForeColor = .Color
+'--------------------------------------
+Private Sub mnuHelpInfo_Click()
+    Dim s As String
+    With App
+        s = s & .CompanyName & " " & .ProductName & vbCrLf
+        s = s & .FileDescription & vbCrLf
+        s = s & "Version: " & MApp.Version
     End With
+    MsgBox s
 End Sub
 
 ' v ############################## v ' based on SHBrowseForFolder deprecated ' v ############################## v '
@@ -626,17 +721,3 @@ Private Sub ShowFBD(spf As Environment_SpecialFolder)
     End With
 
 End Sub
-
-Private Sub mnuHelpInfo_Click()
-    Dim s As String
-    With App
-        s = s & .CompanyName & " " & .ProductName & vbCrLf
-        s = s & .FileDescription & vbCrLf
-        s = s & "Version: " & MApp.Version
-    End With
-    MsgBox s
-End Sub
-
-Private Sub mnuUseOldComDlg_Click()
-    mnuUseOldComDlg.Checked = Not mnuUseOldComDlg.Checked
-End Sub

Modules/MFont.bas

@@ -0,0 +1,50 @@
+Attribute VB_Name = "MFont"
+Option Explicit
+
+'Extensions to the class VBA.StdFont
+Public Function StdFont_Clone(this As StdFont) As StdFont
+    Set StdFont_Clone = StdFont_Copy(New StdFont, this)
+End Function
+
+Public Sub StdFont_Copy(DstFont As StdFont, SrcFont As StdFont)
+    With DstFont
+        .Name = SrcFont.Name
+        .Size = SrcFont.Size
+        .Bold = SrcFont.Bold
+        .Italic = SrcFont.Italic
+        .Weight = SrcFont.Weight
+        .Charset = SrcFont.Charset
+        .Underline = SrcFont.Underline
+        .Strikethrough = SrcFont.Strikethrough
+    End With
+End Sub
+
+Public Function StdFont_Equals(this As StdFont, other As StdFont) As Boolean
+    Dim b As Boolean
+    With this
+        b = .Name = other.Name:                   If Not b Then Exit Function
+        b = .Size = other.Size:                   If Not b Then Exit Function
+        b = .Bold = other.Bold:                   If Not b Then Exit Function
+        b = .Italic = other.Italic:               If Not b Then Exit Function
+        b = .Weight = other.Weight:               If Not b Then Exit Function
+        b = .Charset = other.Charset:             If Not b Then Exit Function
+        b = .Underline = other.Underline:         If Not b Then Exit Function
+        b = .Strikethrough = other.Strikethrough: If Not b Then Exit Function
+    End With
+    StdFont_Equals = True
+End Function
+
+Public Function StdFont_ToStr(this As StdFont) As String
+    Dim s As String: s = "StdFont{" & vbCrLf
+    With this
+        s = s & "Name:          " & .Name & vbCrLf
+        s = s & "Size:          " & .Size & vbCrLf
+        s = s & "Bold:          " & .Bold & vbCrLf
+        s = s & "Italic:        " & .Italic & vbCrLf
+        s = s & "Weight:        " & .Weight & vbCrLf
+        s = s & "Charset:       " & .Charset & vbCrLf
+        s = s & "Underline:     " & .Underline & vbCrLf
+        s = s & "Strikethrough: " & .Strikethrough & vbCrLf
+    End With
+    StdFont_ToStr = s & "}"
+End Function

Modules/MWin.bas

@@ -68,8 +68,8 @@ End Function
 '    App_EXEName = App.EXEName
 '#End If
 'End Property
-'Public Function MsgBoxW(Prompt, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title) As VbMsgBoxResult
-''Public Function MsgBoxW(Prompt, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title, Optional Helpfile, Optional Context) As VbMsgBoxResult
+'Public Function MsgBox(Prompt, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title) As VbMsgBoxResult
+''Public Function MsgBox(Prompt, Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, Optional ByVal Title, Optional Helpfile, Optional Context) As VbMsgBoxResult
 '    Title = IIf(IsMissing(Title), App_EXEName, CStr(Title))
-'    MsgBoxW = MessageBoxW(0, StrPtr(Prompt), StrPtr(Title), Buttons)
+'    MsgBox = MessageBoxW(0, StrPtr(Prompt), StrPtr(Title), Buttons)
 'End Function

PWinDialogs.vbp

@@ -19,6 +19,7 @@ Class=MyFontDialog; Classes\MyFontDialog.cls
 Module=MFontDialog; Modules\MFontDialog.bas
 Class=PrintDialog; Classes\PrintDialog.cls
 ResFile32="Resources\MyRes.RES"
+Module=MFont; Modules\MFont.bas
 IconForm="Form1"
 Startup="Sub Main"
 HelpFile=""
@@ -30,7 +31,7 @@ HelpContextID="0"
 CompatibleMode="0"
 MajorVer=1
 MinorVer=0
-RevisionVer=25
+RevisionVer=26
 AutoIncrementVer=1
 ServerSupportFiles=0
 VersionCompanyName="MBO-Ing.com"