00001 VERSION 5.00
00002 Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
00003 Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
00004 Begin VB.Form Form1
00005 Caption = "RasterPic"
00006 ClientHeight = 5940
00007 ClientLeft = 60
00008 ClientTop = 345
00009 ClientWidth = 6855
00010 Icon = "Form1.frx":0000
00011 LinkTopic = "Form1"
00012 ScaleHeight = 396
00013 ScaleMode = 3 'Pixel
00014 ScaleWidth = 457
00015 StartUpPosition = 3 'Windows Default
00016 Begin VB.CommandButton CmdBreak
00017 Caption = "Break"
00018 Height = 375
00019 Left = 3720
00020 TabIndex = 13
00021 Top = 120
00022 Visible = 0 'False
00023 Width = 855
00024 End
00025 Begin MSComctlLib.Slider SldBlue
00026 Height = 255
00027 Left = 3600
00028 TabIndex = 11
00029 Top = 1080
00030 Width = 2295
00031 _ExtentX = 4048
00032 _ExtentY = 450
00033 _Version = 393216
00034 LargeChange = 16
00035 Max = 255
00036 TickFrequency = 16
00037 End
00038 Begin MSComctlLib.Slider SldRed
00039 Height = 255
00040 Left = 3600
00041 TabIndex = 9
00042 Top = 720
00043 Width = 2295
00044 _ExtentX = 4048
00045 _ExtentY = 450
00046 _Version = 393216
00047 LargeChange = 16
00048 Max = 255
00049 TickFrequency = 16
00050 End
00051 Begin VB.ComboBox ComboScale
00052 Height = 315
00053 Left = 2160
00054 TabIndex = 8
00055 Text = "Combo1"
00056 Top = 840
00057 Width = 1095
00058 End
00059 Begin VB.CommandButton CmdBackColor
00060 Caption = "Set Back Color"
00061 Height = 375
00062 Left = 120
00063 TabIndex = 7
00064 Top = 840
00065 Width = 1335
00066 End
00067 Begin VB.Frame Frame1
00068 Caption = "Info"
00069 Height = 975
00070 Left = 0
00071 TabIndex = 6
00072 Top = 4800
00073 Width = 6855
00074 Begin VB.Label LblInfo
00075 Height = 615
00076 Left = 120
00077 TabIndex = 5
00078 Top = 240
00079 Width = 6495
00080 End
00081 End
00082 Begin VB.CommandButton CmdSave
00083 Caption = "Save As..."
00084 Height = 375
00085 Left = 4680
00086 TabIndex = 3
00087 Top = 120
00088 Width = 1095
00089 End
00090 Begin MSComDlg.CommonDialog ComDlg
00091 Left = 4680
00092 Top = 3960
00093 _ExtentX = 847
00094 _ExtentY = 847
00095 _Version = 393216
00096 End
00097 Begin VB.CommandButton CmdRaster
00098 Caption = "Make Raster"
00099 Height = 375
00100 Left = 2520
00101 TabIndex = 2
00102 Top = 120
00103 Width = 1095
00104 End
00105 Begin VB.CommandButton CmdLoad
00106 Caption = "Open File"
00107 Default = -1 'True
00108 Height = 375
00109 Left = 120
00110 TabIndex = 1
00111 Top = 120
00112 Width = 1095
00113 End
00114 Begin VB.PictureBox PicDst
00115 AutoRedraw = -1 'True
00116 AutoSize = -1 'True
00117 Height = 1455
00118 Left = 3480
00119 ScaleHeight = 93
00120 ScaleMode = 3 'Pixel
00121 ScaleWidth = 101
00122 TabIndex = 4
00123 Top = 1560
00124 Width = 1575
00125 End
00126 Begin VB.PictureBox PicSrc
00127 AutoRedraw = -1 'True
00128 AutoSize = -1 'True
00129 Height = 1455
00130 Left = 0
00131 ScaleHeight = 93
00132 ScaleMode = 3 'Pixel
00133 ScaleWidth = 77
00134 TabIndex = 0
00135 Top = 1560
00136 Width = 1215
00137 End
00138 Begin VB.Label LblBlue
00139 Caption = "Blue: 0"
00140 Height = 255
00141 Left = 6000
00142 TabIndex = 12
00143 Top = 1080
00144 Width = 855
00145 End
00146 Begin VB.Label LblRed
00147 Caption = "Red: 0"
00148 Height = 255
00149 Left = 6000
00150 TabIndex = 10
00151 Top = 720
00152 Width = 855
00153 End
00154 Begin VB.Shape ShpBackCol
00155 FillStyle = 0 'Solid
00156 Height = 375
00157 Left = 1560
00158 Shape = 4 'Rounded Rectangle
00159 Top = 840
00160 Width = 375
00161 End
00162 Begin VB.Image ImgDummy
00163 Height = 2895
00164 Left = 1080
00165 Top = 1800
00166 Visible = 0 'False
00167 Width = 2655
00168 End
00169 End
00170 Attribute VB_Name = "Form1"
00171 Attribute VB_GlobalNameSpace = False
00172 Attribute VB_Creatable = False
00173 Attribute VB_PredeclaredId = True
00174 Attribute VB_Exposed = False
00175 Option Explicit
00176
00177 Dim scaler As Long
00178 Dim backCol As Long
00179 Dim redCol As Long
00180 Dim blueCol As Long
00181 Dim breaker As Boolean
00182
00183 Private Sub CmdBackColor_Click()
00184 On Error GoTo Hell
00185 ComDlg.ShowColor
00186 backCol = ComDlg.Color
00187 ShpBackCol.FillColor = backCol
00188 Exit Sub
00189 Hell:
00190 MsgBox "Color select error." & vbNewLine & _
00191 "You may only use black as background color!" _
00192 , , "RasterPic Error"
00193 End Sub
00194
00195 Private Sub CmdBreak_Click()
00196 breaker = True
00197 End Sub
00198
00199 Private Sub CmdLoad_Click()
00200 On Error GoTo Hell
00201 Dim fileName As String
00202 ComDlg.Filter = "Pic Files (*.bmp;*.cur;*.emf;*.gif;*.jpg;*.ico;*.rle;*.wmf)|*.bmp;*.cur;*.emf;*.gif;*.jpg;*.ico;*.rle;*.wmf|All Files (*.*)|*.*"
00203 CmdSave.Enabled = False
00204 ComDlg.DialogTitle = "Open a fuckin' file, if you have balls."
00205 ComDlg.fileName = ""
00206 ComDlg.ShowOpen
00207 fileName = ComDlg.fileName
00208 If (fileName <> "") Then
00209 PicSrc.Picture = ImgDummy.Picture
00210 PicDst.Picture = ImgDummy.Picture
00211 PicSrc.Picture = LoadPicture(fileName)
00212 resizePicDst
00213 CmdRaster.Enabled = True
00214 CmdRaster.SetFocus
00215 ComDlg.InitDir = fileName
00216 showInfoPic
00217 Else
00218 LblInfo.Caption = "Why do you not load a pic? " & _
00219 vbNewLine & "Fucker!"
00220 End If
00221 Exit Sub
00222 Hell:
00223 MsgBox "Open file error." & vbNewLine & _
00224 "Only open valid picture files!", , "RasterPic Error"
00225 End Sub
00226
00227 Private Sub CmdRaster_Click()
00228 On Error GoTo Hell
00229 Dim maxX As Long
00230 Dim maxY As Long
00231 Dim x As Long
00232 Dim y As Long
00233 Dim i As Long
00234 Dim c As Long
00235 Dim percent As Single
00236 resizePicDst
00237 PicDst.Picture = ImgDummy.Picture
00238 maxX = PicSrc.ScaleWidth - 1
00239 maxY = PicSrc.ScaleHeight - 1
00240 If (maxY = 0) Then maxY = 1
00241 percent = 100 / maxY
00242 CmdBreak.Visible = True
00243 CmdBreak.SetFocus
00244 CmdLoad.Enabled = False
00245 CmdRaster.Enabled = False
00246 CmdSave.Enabled = False
00247 For y = 0 To maxY
00248 For x = 0 To maxX
00249 c = PicSrc.Point(x, y)
00250 c = RGB(redCol, (c \ &H100) And &HFF, blueCol)
00251 PicDst.Line (x * scaler, y * scaler)-(x * scaler + scaler, y * scaler), c
00252 For i = 1 To scaler - 1
00253 PicDst.Line (0, y * scaler + i)-(maxX * scaler + scaler, y * scaler + i), backCol
00254 Next i
00255 Next x
00256 LblInfo.Caption = "Progress: " & Format(percent * y, "0") & _
00257 "%" & vbNewLine & "Ey, Player: Use the Red- and Blue-Slider for interaction!"
00258 DoEvents
00259 If (breaker) Then Exit For
00260 Next y
00261 CmdBreak.Visible = False
00262 breaker = False
00263 PicDst.Picture = PicDst.Image
00264 LblInfo.Caption = "New pic width: " & PicDst.ScaleWidth & _
00265 " hight: " & PicDst.ScaleHeight & vbNewLine & _
00266 "Press 'Shave As...' to save your ass."
00267 CmdLoad.Enabled = True
00268 CmdRaster.Enabled = True
00269 CmdSave.Enabled = True
00270 CmdSave.SetFocus
00271 Exit Sub
00272 Hell:
00273 MsgBox "Render error." & vbNewLine & _
00274 "Please open an other picture file" & _
00275 " or adjust the scale.", , "RasterPic Error"
00276 End Sub
00277
00278 Private Sub CmdSave_Click()
00279 On Error GoTo Hell
00280 Dim fileName As String
00281 ComDlg.Filter = "Bitmap File (*.bmp)|*.bmp"
00282 ComDlg.DialogTitle = "Why did they treat us this respectless?!"
00283 ComDlg.fileName = ""
00284 SavePicture PicDst.Picture, "c:\xxx.jpg"
00285 ComDlg.ShowSave
00286 fileName = ComDlg.fileName
00287 If (fileName <> "") Then
00288 If (LCase$(Right$(fileName, 4)) <> ".bmp") Then
00289 fileName = Left$(fileName, Len(fileName) - 4) & ".bmp"
00290 End If
00291 'SavePicture PicDst.Picture, fileName
00292 LblInfo.Caption = "Pic saved as: " & fileName & _
00293 vbNewLine & "[new virus installed: MeiLing.vbs]"
00294 CmdLoad.SetFocus
00295 Else
00296 LblInfo.Caption = "Are you to weak to save a file?" _
00297 & vbNewLine & "Fucker!"
00298 End If
00299 Exit Sub
00300 Hell:
00301 MsgBox "Save file error." & vbNewLine & _
00302 "Please save file with an other filename." & _
00303 " Ensure, you have permission to write on disk." _
00304 , , "RasterPic Error"
00305 End Sub
00306
00307 Private Sub ComboScale_Click()
00308 Dim s As String
00309 s = ComboScale.Text
00310 s = Left$(s, 7)
00311 s = Right$(s, 1)
00312 scaler = CLng(Val(s))
00313 resizePicDst
00314 showInfoPic
00315 End Sub
00316
00317 Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
00318 If (KeyCode = vbKeyC And Shift = vbCtrlMask) Then
00319 If (PicDst.Picture > 0) Then
00320 Clipboard.SetData PicDst.Picture, vbCFBitmap
00321 LblInfo.Caption = "New pic is now in clipboard." & vbNewLine & "Oh my god. You are a Copy-Fucker!"
00322 End If
00323 End If
00324 End Sub
00325
00326 Private Sub Form_Load()
00327 On Error GoTo Hell
00328 ComDlg.InitDir = App.Path
00329 CmdSave.Enabled = False
00330 CmdRaster.Enabled = False
00331 ComboScale.AddItem ("Scale 2x")
00332 ComboScale.AddItem ("Scale 3x")
00333 ComboScale.AddItem ("Scale 4x")
00334 ComboScale.AddItem ("Scale 5x")
00335 ComboScale.Text = "Scale 2x"
00336 scaler = 2
00337 resizePicDst
00338 LblInfo.Caption = "Open a file." & vbNewLine & "Fucker!"
00339 Me.KeyPreview = True
00340 Form1.Show
00341 CmdLoad.SetFocus
00342 Exit Sub
00343 Hell:
00344 MsgBox "Program start error." & vbNewLine & _
00345 "Please read the 'ReadMe.txt' file." & _
00346 " Ensure, you have all runtime librarys installed." _
00347 , , "RasterPic Error"
00348 End Sub
00349
00350 Private Sub Form_Resize()
00351 Frame1.Top = Form1.ScaleHeight - Frame1.Height
00352 Frame1.Width = Form1.ScaleWidth
00353 End Sub
00354
00355 Private Sub SldBlue_Scroll()
00356 blueCol = SldBlue.Value
00357 LblBlue.Caption = "Blue: " & blueCol
00358 End Sub
00359
00360 Private Sub SldRed_Scroll()
00361 redCol = SldRed.Value
00362 LblRed.Caption = "Red: " & redCol
00363 End Sub
00364
00365 Private Sub resizePicDst()
00366 PicDst.Height = (PicSrc.Height) * scaler - (4 * (scaler - 1))
00367 PicDst.Width = (PicSrc.Width) * scaler - (4 * (scaler - 1))
00368 End Sub
00369
00370 Private Sub showInfoPic()
00371 Dim fName As String
00372 fName = ComDlg.fileName
00373 If (fName <> "") Then
00374 LblInfo.Caption = "Pic: " & fName & vbNewLine & _
00375 "Width: " & PicSrc.ScaleWidth & _
00376 " Hight: " & PicSrc.ScaleHeight & vbNewLine & _
00377 " 'Make Raster' will last about " & _
00378 Format((PicSrc.Height * PicSrc.Width) / 2000 * scaler, "0") & _
00379 " seconds, Coc'Sucker!"
00380 End If
00381 End Sub
