Originally posted by xoggoth
View Post

SavePicture frmWfaxdisp.picDisplay.Picture, filetosave
SavePicture frmWfaxdisp.picDisplay.Image, filetosave
VERSION 2.00 Begin Form frmWfaxdisp Caption = "Weather Fax Display Program" ClientHeight = 5820 ClientLeft = 1095 ClientTop = 1770 ClientWidth = 7365 Height = 6510 Left = 1035 LinkTopic = "Form1" ScaleHeight = 388 ScaleMode = 3 'Pixel ScaleWidth = 491 Top = 1140 Width = 7485 Begin CommonDialog CMDialog1 Left = 2160 Top = 6600 End Begin PictureBox picDisplay Align = 1 'Align Top AutoSize = -1 'True BorderStyle = 0 'None DrawMode = 4 'Not Copy Pen Height = 9000 Left = 0 Picture = WFAXDISP.FRX:0000 ScaleHeight = 600 ScaleMode = 3 'Pixel ScaleWidth = 491 TabIndex = 0 Top = 0 Width = 7365 End Begin Menu mnuFile Caption = "File" Begin Menu mneSelect Caption = "Select File" End Begin Menu mnuSep2 Caption = "-" End Begin Menu mnuSave Caption = "Save File" End Begin Menu mnuSep1 Caption = "-" End Begin Menu mnuExit Caption = "E&xit" End End End Option Explicit 'File Open/Save Dialog Flags Const OFN_READONLY = &H1& Const OFN_OVERWRITEPROMPT = &H2& Const OFN_HIDEREADONLY = &H4& Const OFN_NOCHANGEDIR = &H8& Const OFN_SHOWHELP = &H10& Const OFN_NOVALIDATE = &H100& Const OFN_ALLOWMULTISELECT = &H200& Const OFN_EXTENSIONDIFFERENT = &H400& Const OFN_PATHMUSTEXIST = &H800& Const OFN_FILEMUSTEXIST = &H1000& Const OFN_CREATEPROMPT = &H2000& Const OFN_SHAREAWARE = &H4000& Const OFN_NOREADONLYRETURN = &H8000& Sub mneSelect_Click () 'dim nestring( 800,400 ) as string Dim filenum As Integer Dim input_char As String Dim R, G, B As Integer 'point colour Dim X, Y 'point location Dim loop_count As Long Dim file_byte_count As Long frmGetFile.cboFileType.AddItem "Fax Files (*.DUP)" frmGetFile.cboFileType.ListIndex = 0 frmGetFile.Show 1 MsgBox frmGetFile.Tag If frmGetFile.Tag = "" Then Exit Sub filenum = FreeFile Open frmGetFile.Tag For Binary As #filenum file_byte_count = LOF(filenum) Debug.Print file_byte_count X = 1 Y = 1 For loop_count = 1 To file_byte_count Step 1 input_char = Input$(1, #filenum) 'MsgBox "input char " + Hex$(Asc(input_char)) R = Asc(input_char) G = Asc(input_char) B = Asc(input_char) frmWfaxdisp.picDisplay.PSet (X, Y), RGB(R, G, B) 'firkle pixel X = X + 1 If X > 1599 Then 'end of line? X = 0 Y = Y + 1 'new line DoEvents End If If Y > frmWfaxdisp.picDisplay.ScaleHeight Then 'bottom of window? MsgBox "got to end of picturebox" Y = 0 End If Next 'frmWfaxdisp.picDisplay.AutoRedraw = True 'didn't work... End Sub Sub mnuExit_Click () End End Sub Sub mnuSave_Click () Dim filetosave As String CMDialog1.DialogTitle = "Save As" CMDialog1.Flags = OFN_FILEMUSTEXIST Or OFN_PATHMUSTEXIST CMDialog1.Filter = "All Pictures|*.bmp;*.wmf;*.ico" CMDialog1.Action = 2 'store name of file to save filetosave = CMDialog1.Filename If filetosave = "" Then Exit Sub MsgBox filetosave 'just in case, set up error handler On Error GoTo notSaved 'save the picture in picDisp to the file specified in filetosave SavePicture frmWfaxdisp.picDisplay.Picture, filetosave Exit Sub notSaved: MsgBox "Could not save file " + filetosave, 48, "File Save Error" Resume Next End Sub Sub picDisplay_Change () MsgBox "changed" End Sub
Leave a comment: