home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / cmdlg2 / cmdialog.bas next >
Encoding:
BASIC Source File  |  1995-05-09  |  16.8 KB  |  536 lines
  1. Rem Demo for accessing Win 3.1 Common Dialogs
  2. Rem Author: Costas Kitsos, CIS 73667,1755
  3. Rem Revision: 1.00.00, July 4 1992
  4.  
  5. Rem Modified: L.J. Johnson, CIS 70700,1334
  6. Rem Revision: 1.10.00, July 25 1992
  7.  
  8. DefInt A-Z
  9.  
  10. Declare Function lstrcpy Lib "Kernel" (ByVal lpDestString As Any, ByVal lpSourceString As Any) As Long
  11.  
  12. Function PColors% (MyForm As Form, CError&, Flags&)
  13.  
  14.     MyForm.Cls
  15.     PColors% = 0: CError& = 0
  16.  
  17.     Dim C As ChooseColor
  18.     Dim Address As Long
  19.     ReDim ClrArray(15) As Long    ' Holds Custom Colors
  20.  
  21.     wSize = Len(ClrArray(0)) * 16 ' Size of Memory Block
  22.  
  23.  
  24.     ' ----------------------------------------------------
  25.     ' A global block is allocated to hold a copy of the
  26.     '   custom colors
  27.     ' ----------------------------------------------------
  28.     MemHandle = GlobalAlloc(GHND, wSize)
  29.     If MemHandle = 0 Then
  30.         PColors% = 1
  31.         Exit Function
  32.     End If
  33.  
  34.     Address = GlobalLock(MemHandle)
  35.     If Address = 0 Then
  36.         PColors% = 2
  37.         Exit Function
  38.     End If
  39.     ' ----------------------------------------------------
  40.  
  41.  
  42.     ' ----------------------------------------------------
  43.     ' Fill Custom Colors with White
  44.     ' ----------------------------------------------------
  45.     For i& = 0 To UBound(ClrArray)
  46.         ClrArray(i&) = &HFFFFFF
  47.     Next
  48.     ' ----------------------------------------------------
  49.  
  50.     
  51.     ' ----------------------------------------------------
  52.     'copy custom colors to the global block
  53.     ' ----------------------------------------------------
  54.     Call hmemcpy(ByVal Address, ClrArray(0), wSize)
  55.     ' ----------------------------------------------------
  56.  
  57.     
  58.     ' ----------------------------------------------------
  59.     'get ready to call ChooseColor
  60.     ' ----------------------------------------------------
  61.     C.lStructSize = Len(C)
  62.     C.hwndOwner = MyForm.hwnd
  63.     C.lpCustColors = Address
  64.     C.RgbResult = Dialogs.BackColor
  65.     C.Flags = Flags&
  66.  
  67.     Result = ChooseColor(C)
  68.     CError& = CommDlgExtendedError()
  69.     
  70.     If Result = 0 Then
  71.         PColors% = 3
  72.         Exit Function
  73.     End If
  74.     ' ----------------------------------------------------
  75.  
  76.  
  77.     ' ----------------------------------------------------
  78.     ' copy the new custom colors locally
  79.     ' ----------------------------------------------------
  80.     Call hmemcpy(ClrArray(0), ByVal Address, wSize)
  81.     
  82.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  83.     OK = GlobalFree(MemHandle)
  84.     ' ----------------------------------------------------
  85.  
  86.     
  87.     ' ----------------------------------------------------
  88.     ' Select the new color for the background
  89.     ' Comment this out if it's distracting
  90.     ' Print the new custom colors
  91.     ' ----------------------------------------------------
  92.     MyForm.BackColor = C.RgbResult
  93.     For i& = 0 To UBound(ClrArray)
  94.         MyForm.Print "Custom Color"; Str$(i&); ":", Hex$(ClrArray(i&))
  95.     Next
  96.     ' ----------------------------------------------------
  97.  
  98. End Function
  99.  
  100. Function PFileOpen% (MyForm As Form, FError&, Filter$, IDir$, Title$, Index%, Flags&)
  101.  
  102.     MyForm.Cls
  103.     PFileOpen% = 0: SaveError% = 0
  104.  
  105.     Dim O As OPENFILENAME
  106.     Dim Address As Long
  107.  
  108.     ' ----------------------------------------------------
  109.     ' First Copy the strings to the Global Memory Block
  110.     ' Use a sub-allocation scheme to avoid overloading
  111.     '   the LDT
  112.     ' ----------------------------------------------------
  113.     szFile$ = String$(256, 0)
  114.     
  115.     szFilter$ = Filter$
  116.     szInitialDir$ = IDir$
  117.     szTitle$ = Title$
  118.  
  119.     wSize = Len(szFile$) + Len(szFilter$) + Len(szInitialDir$) + Len(szTitle$)
  120.     
  121.     MemHandle = GlobalAlloc(GHND, wSize)
  122.  
  123.     If MemHandle = 0 Then
  124.         PFileOpen% = 1
  125.         Exit Function
  126.     End If
  127.     ' ----------------------------------------------------
  128.  
  129.     
  130.     ' ----------------------------------------------------
  131.     ' Lock global memory, then copy it to local memory
  132.     ' ----------------------------------------------------
  133.     Address = GlobalLock(MemHandle)
  134.     If Address = 0 Then
  135.         PFileOpen% = 2
  136.         Exit Function
  137.     Else
  138.         Call hmemcpy(ByVal Address, ByVal (szFile$ + szFilter$ + szInitialDir$ + szTitle$), wSize)
  139.     End If
  140.     ' ----------------------------------------------------
  141.     
  142.     O.lStructSize = Len(O)
  143.     O.hwndOwner = MyForm.hwnd
  144.     O.Flags = Flags&
  145.     O.nFilterIndex = Index%
  146.     O.lpstrFile = Address
  147.     O.nMaxFile = Len(szFile$)
  148.     O.lpstrFilter = Address + Len(szFile$)
  149.     O.lpstrInitialDir = O.lpstrFilter + Len(szFilter$)
  150.     O.lpstrTitle = O.lpstrInitialDir + Len(szInitialDir$)
  151.  
  152.     Result = GetOpenFileName(O)
  153.     FError& = CommDlgExtendedError()
  154.     
  155.     If Result = 0 Then
  156.         PFileOpen% = 3
  157.     Else
  158.         Call hmemcpy(ByVal szFile$, ByVal Address, Len(szFile$))
  159.     End If
  160.     
  161.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  162.     OK = GlobalFree(MemHandle)
  163.  
  164.     If Result = 0 Then Exit Function
  165.  
  166.     File$ = Left$(szFile$, InStr(szFile$, Chr$(0)) - 1)
  167.     MyForm.Print "Common Dialogs File Open"
  168.     MyForm.Print
  169.     MyForm.Print "You selected:", File$
  170.     MyForm.Print "Path:", Left$(File$, O.nFileOffset)
  171.     MyForm.Print "Filename:", Right$(File$, Len(File$) - O.nFileOffset)
  172.     MyForm.Print "Extension:", Right$(File$, Len(File$) - O.nFileExtension)
  173.  
  174. End Function
  175.  
  176. Function PFileSave% (MyForm As Form, FError&, Filter$, IDir$, FileMask$, Index%, Title$, Flags&)
  177.  
  178.     MyForm.Cls
  179.     PFileSave% = 0: FError& = 0
  180.  
  181.     ' This is similar to GetOpenFileName
  182.     Dim S As OPENFILENAME
  183.     Dim Address As Long
  184.  
  185.     ' ----------------------------------------------------
  186.     ' First Copy the strings to the Global Memory Block
  187.     ' Use a sub-allocation scheme to avoid wearing down
  188.     '   the LDT
  189.     ' ----------------------------------------------------
  190.     NoTitle$ = FileMask$
  191.     szFile$ = NoTitle$ + String$(256 - Len(NoTitle$), 0)
  192.     szFilter$ = Filter$
  193.     szInitialDir$ = IDir$
  194.     szTitle$ = Title$
  195.     wSize = Len(szFile$) + Len(szFilter$) + Len(szInitialDir$) + Len(szTitle$)
  196.  
  197.     MemHandle = GlobalAlloc(GHND, wSize)
  198.  
  199.     If MemHandle = 0 Then
  200.         PFileSave% = 1
  201.         Exit Function
  202.     End If
  203.  
  204.     Address = GlobalLock(MemHandle)
  205.     If Address = 0 Then
  206.         PFileSave% = 2
  207.         Exit Function
  208.     Else
  209.         Call hmemcpy(ByVal Address, ByVal (szFile$ + szFilter$ + szInitialDir$ + szTitle$), wSize)
  210.     End If
  211.  
  212.     S.lStructSize = Len(S)
  213.     S.hwndOwner = MyForm.hwnd
  214.     S.Flags = Flags&
  215.     S.nFilterIndex = Index%
  216.     S.lpstrFile = Address
  217.     S.nMaxFile = Len(szFile$)
  218.     S.lpstrFilter = Address + Len(szFile$)
  219.     S.lpstrInitialDir = S.lpstrFilter + Len(szFilter$)
  220.     S.lpstrTitle = S.lpstrInitialDir + Len(szInitialDir$)
  221.  
  222.     Result = GetSaveFileName(S)
  223.     FError& = CommDlgExtendedError()
  224.  
  225.     If Result = 0 Then
  226.         PFileSave% = 3
  227.         Exit Function
  228.     Else
  229.         Call hmemcpy(ByVal szFile$, ByVal Address, Len(szFile$))
  230.     End If
  231.  
  232.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  233.     OK = GlobalFree(MemHandle)
  234.  
  235.     File$ = Left$(szFile$, InStr(szFile$, Chr$(0)) - 1)
  236.     MyForm.Print "Common Dialogs File Save"
  237.     MyForm.Print
  238.     MyForm.Print "You selected:", File$
  239.     MyForm.Print "Path:", Left$(File$, S.nFileOffset)
  240.     MyForm.Print "Filename:", Right$(File$, Len(File$) - S.nFileOffset)
  241.     MyForm.Print "Extension:", Right$(File$, Len(File$) - S.nFileExtension)
  242.  
  243. End Function
  244.  
  245. Function PFonts% (MyForm As Form, FError&, Flags&, FontType%)
  246.     
  247.     MyForm.Cls
  248.     PFonts% = 0: FError& = 0
  249.  
  250.     Dim A As ChooseFont
  251.     Dim F As LogFont
  252.     Dim Address As Long
  253.  
  254.  
  255.     ' ----------------------------------------------------
  256.     ' Save the defaults
  257.     ' ----------------------------------------------------
  258.     OldFont$ = Dialogs.FontName
  259.     OldFontSize = Dialogs.FontSize
  260.     OldFontWeight = Dialogs.FontBold
  261.     OldFontItalic = Dialogs.FontItalic
  262.     OldFontStrikethru = Dialogs.FontStrikethru
  263.     OldFontUnderline = Dialogs.FontUnderline
  264.     OldForeColor& = Dialogs.ForeColor
  265.     Debug.Print OldFont$, OldFontSize
  266.     ' ----------------------------------------------------
  267.  
  268.     
  269.     ' ----------------------------------------------------
  270.     ' We need to use GlobalAlloc to provide lpLogFont
  271.     ' which is a pointer to a LogFont structure
  272.     ' ----------------------------------------------------
  273.     MemHandle = GlobalAlloc(GHND, Len(F))
  274.     If MemHandle = 0 Then
  275.         PFonts% = 1
  276.         Exit Function
  277.     End If
  278.  
  279.     Address = GlobalLock(MemHandle)
  280.     If Address = 0 Then
  281.         PFonts% = 2
  282.         Exit Function
  283.     End If
  284.     ' ----------------------------------------------------
  285.  
  286.     
  287.     A.lStructSize = Len(A)
  288.     A.hwndOwner = MyForm.hwnd
  289.     A.Flags = Flags&
  290.     A.nfonttype = FontType%
  291.     A.lpLogFont = Address
  292.     
  293.     Result = ChooseFont(A)
  294.     FError& = CommDlgExtendedError()
  295.  
  296.     ' ----------------------------------------------------
  297.     ' make a local copy of the LogFont structure
  298.     ' ----------------------------------------------------
  299.     If Result = 0 Then
  300.         PFonts% = 0
  301.         Exit Function
  302.     Else
  303.         Call hmemcpy(F, ByVal Address, Len(F))
  304.     End If
  305.  
  306.     OK = GlobalUnlock(MemHandle)    'Free The Memory
  307.     OK = GlobalFree(MemHandle)
  308.     ' ----------------------------------------------------
  309.  
  310.  
  311.     ' ----------------------------------------------------
  312.     'calculate the font size in points
  313.     ' ----------------------------------------------------
  314.     FntSize = Abs(F.lfHeight * (72 / GetDeviceCaps(MyForm.hDC, LOGPIXELSY)))
  315.     ' ----------------------------------------------------
  316.  
  317.  
  318.     ' ----------------------------------------------------
  319.     'select the new font
  320.     ' ----------------------------------------------------
  321.     Dialogs.FontName = Left$(F.lfFaceName, InStr(F.lfFaceName, Chr$(0)) - 1)
  322.     Dialogs.FontSize = FntSize
  323.     Dialogs.FontItalic = Asc(F.lfItalic)
  324.     Dialogs.FontStrikethru = Asc(F.lfStrikeOut)
  325.     Dialogs.FontUnderline = Asc(F.lfUnderline)
  326.     Dialogs.ForeColor = A.rgbColors
  327.     If F.lfWeight < 500 Then Dialogs.FontBold = 0 Else Dialogs.FontBold = -1
  328.     ' ----------------------------------------------------
  329.  
  330.  
  331.     ' ----------------------------------------------------
  332.     'restore the defaults
  333.     ' ----------------------------------------------------
  334.     MyForm.Print "You have chosen: " + Left$(F.lfFaceName, InStr(F.lfFaceName, Chr$(0)) - 1) + ", Size = " + LTrim$(Str$(FntSize))
  335.     MyForm.Print
  336.     
  337.     Dialogs.FontName = OldFont$
  338.     Dialogs.FontSize = OldFontSize
  339.     Dialogs.FontBold = OldFontWeight
  340.     Dialogs.FontItalic = OldFontItalic
  341.     Dialogs.FontStrikethru = OldFontStrikethru
  342.     Dialogs.FontUnderline = OldFontUnderline
  343.     Dialogs.ForeColor = OldForeColor&
  344.     ' ----------------------------------------------------
  345.  
  346.  
  347.     MyForm.Print "Font:", Left$(F.lfFaceName, InStr(F.lfFaceName, Chr$(0)) - 1)
  348.     MyForm.Print "Height:", Str$(FntSize)
  349.     MyForm.Print "Weight:", Str$(F.lfWeight)
  350.     MyForm.Print "Italic:", Str$(Asc(F.lfItalic))
  351.  
  352. End Function
  353.  
  354. Function PPrinter% (MyForm As Form, PError&, Flags&, FPage%, TPage%, Min%, Max%, Copies%)
  355.     
  356.     MyForm.Cls
  357.     PPrinter% = 0: PError& = 0
  358.  
  359.  
  360.     ' ----------------------------------------------------
  361.     'This is similar to Printer Setup
  362.     ' ----------------------------------------------------
  363.     Dim Address As Long
  364.     Dim P As PrintDlg
  365.     Dim D As DevMode
  366.     ' ----------------------------------------------------
  367.  
  368.  
  369.     ' ----------------------------------------------------
  370.     ' Set up structure, then call print dialog.  Exit
  371.     '   function set to 1 if get error at this point
  372.     ' ----------------------------------------------------
  373.     P.lStructSize = Len(P)
  374.     P.hwndOwner = MyForm.hwnd
  375.     P.Flags = Flags&
  376.     P.nFromPage = FPage%
  377.     P.nToPage = TPage%
  378.     P.nMinPage = Min%
  379.     P.nMaxPage = Max%
  380.     P.nCopies = Copies%
  381.     
  382.     Result = PrintDlg(P)
  383.     PError& = CommDlgExtendedError()
  384.     
  385.     If Result = 0 Then
  386.         PPrinter% = 1
  387.         Exit Function
  388.     End If
  389.     ' ----------------------------------------------------
  390.     
  391.     
  392.     ' ----------------------------------------------------
  393.     ' Delete the handle
  394.     ' ----------------------------------------------------
  395.     If P.hDC <> 0 Then
  396.         OK = DeleteDC(P.hDC)
  397.     End If
  398.     ' ----------------------------------------------------
  399.     
  400.     ' ----------------------------------------------------
  401.     ' Free the memory
  402.     ' ----------------------------------------------------
  403.  
  404.  
  405.     If P.hDevNames = 0 Then
  406.         PPrinter% = 2
  407.         Exit Function
  408.     Else
  409.         Dim N As DEVNAMES                       ' this works for old drivers as well
  410.         Address = GlobalLock(P.hDevNames)
  411.         Call hmemcpy(N, ByVal Address, Len(N))
  412.         szDriver$ = String$(15, 0) 'filename buffer
  413.         szDevice$ = String$(32, 0) 'device buffer
  414.         szOutPut$ = String$(80, 0) 'port buffer
  415.  
  416.         L& = lstrcpy(szDriver$, Address + N.wDriverOffset)
  417.         szDriver$ = Left$(szDriver$, InStr(szDriver$, Chr$(0)) - 1)
  418.  
  419.         L& = lstrcpy(szDevice$, Address + N.wDeviceOffset)
  420.         szDevice$ = Left$(szDevice$, InStr(szDevice$, Chr$(0)) - 1)
  421.  
  422.         L& = lstrcpy(szOutPut$, Address + N.wOutputOffset)
  423.         szOutPut$ = Left$(szOutPut$, InStr(szOutPut$, Chr$(0)) - 1)
  424.  
  425.         MyForm.Print szDriver$, szDevice$, szOutPut$
  426.  
  427.         OK = GlobalUnlock(P.hDevNames)
  428.         OK = GlobalFree(P.hDevNames)
  429.     End If
  430.     ' ----------------------------------------------------
  431.     
  432.  
  433.     ' ----------------------------------------------------
  434.     ' Lock the address, then make a local copy of the
  435.     '   global block (hDevMode)
  436.     ' ----------------------------------------------------
  437.     If P.hDevMode = 0 Then 'nothing to lock if hDevMode is NULL
  438.         PPrinter% = 3
  439.     Else
  440.         Address = GlobalLock(P.hDevMode)    'hDevMode is returned when the driver supports ExtDeviceMode
  441.         Call hmemcpy(D, ByVal Address, Len(D))
  442.         OK = GlobalUnlock(P.hDevMode)
  443.         OK = GlobalFree(P.hDevMode)
  444.     End If
  445.     
  446.     
  447.     If P.hDevMode <> 0 Then MyForm.Print "Printer:", Left$(D.dmDeviceName, InStr(D.dmDeviceName, Chr$(0)) - 1)
  448.     MyForm.Print "From Page:", Str$(P.nFromPage)
  449.     MyForm.Print "To Page:", Str$(P.nToPage)
  450.     MyForm.Print "Copies:", Str$(P.nCopies)
  451.  
  452. End Function
  453.  
  454. Function PSetup% (MyForm As Form, PError&, Flags&)
  455.     
  456.     MyForm.Cls
  457.     PSetup% = 0: PError& = 0
  458.  
  459.     Dim Address As Long
  460.     Dim P As PrintDlg
  461.     Dim D As DevMode
  462.  
  463.     P.lStructSize = Len(P)
  464.     P.hwndOwner = MyForm.hwnd
  465.     P.Flags = Flags&
  466.     
  467.     Result = PrintDlg(P)
  468.  
  469.     PError& = CommDlgExtendedError()
  470.     
  471.     If Result = 0 Then
  472.         PSetup% = 1
  473.         Exit Function
  474.     End If
  475.     
  476.     ' ----------------------------------------------------
  477.     ' PrintDlg() returns an hDC, a global handle to
  478.     '   hDevNames and another to hDevMode.  Delete the
  479.     '   ones we don't need
  480.     ' ----------------------------------------------------
  481.     If P.hDC <> 0 Then
  482.         OK = DeleteDC(P.hDC)
  483.     End If
  484.  
  485.     If P.hDevNames = 0 Then
  486.         PSetup% = 2
  487.         Exit Function
  488.     Else
  489.         Dim N As DEVNAMES                       ' this works for old drivers as well
  490.         Address = GlobalLock(P.hDevNames)
  491.         
  492.         Call hmemcpy(N, ByVal Address, Len(N))
  493.         
  494.         szDriver$ = String$(15, 0) 'filename buffer
  495.         szDevice$ = String$(32, 0) 'device buffer
  496.         szOutPut$ = String$(80, 0) 'port buffer
  497.  
  498.         L& = lstrcpy(szDriver$, Address + N.wDriverOffset)
  499.         szDriver$ = Left$(szDriver$, InStr(szDriver$, Chr$(0)) - 1)
  500.  
  501.         L& = lstrcpy(szDevice$, Address + N.wDeviceOffset)
  502.         szDevice$ = Left$(szDevice$, InStr(szDevice$, Chr$(0)) - 1)
  503.  
  504.         L& = lstrcpy(szOutPut$, Address + N.wOutputOffset)
  505.         szOutPut$ = Left$(szOutPut$, InStr(szOutPut$, Chr$(0)) - 1)
  506.  
  507.         MyForm.Print szDriver$, szDevice$, szOutPut$
  508.  
  509.         OK = GlobalUnlock(P.hDevNames)
  510.         OK = GlobalFree(P.hDevNames)
  511.     End If
  512.     ' ----------------------------------------------------
  513.     
  514.  
  515.     ' ----------------------------------------------------
  516.     ' Lock the address, then make a local copy of the
  517.     '   global block (hDevMode)
  518.     ' ----------------------------------------------------
  519.     If P.hDevMode = 0 Then 'nothing to lock if hDevMode is NULL
  520.         PSetup% = 3
  521.     Else
  522.         Address = GlobalLock(P.hDevMode)    'hDevMode is returned when the driver supports ExtDeviceMode
  523.         Call hmemcpy(D, ByVal Address, Len(D))
  524.         OK = GlobalUnlock(P.hDevMode)
  525.         OK = GlobalFree(P.hDevMode)
  526.     End If
  527.     
  528.     
  529.     If P.hDevMode <> 0 Then
  530.         MyForm.Print "Printer:", Left$(D.dmDeviceName, InStr(D.dmDeviceName, Chr$(0)) - 1)
  531.         MyForm.Print "Orientation:", Str$(D.dmOrientation)
  532.     End If
  533.  
  534. End Function
  535.  
  536.