form1.frm

类似小画家功能可以用来显示并编辑图档。

     Label1.BackColor = QBColor(Index)
  End If
End Sub
Private Sub p2_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = 1 Then  '鼠标移动时作删除操作
    Select Case what
      Case 1
        Call drawjuxing(10, 0)
        x2 = X: y2 = Y
        Call drawjuxing(10, 0)
      Case 2
        Call drawline(10)
        x2 = X: y2 = Y
        Call drawline(10)
      Case 3
        If y1 <> y2 Then
          centerx = (x1 + x2) / 2: centery = (y1 + y2) / 2
          rr = Abs((x2 - x1) / 2): rate = Int(Abs(rr / ((y2 - y1) / 2)) * 100) / 100
          Call drawcircle(10, 0)
        End If
        x2 = X: y2 = Y
        If y1 <> y2 Then
          centerx = (x1 + x2) / 2: centery = (y1 + y2) / 2
          rr = Abs((x2 - x1) / 2): rate = Int(Abs(rr / ((y2 - y1) / 2)) * 100) / 100
          Call drawcircle(10, 0)
        End If
      Case 4
        TextB.Visible = True
        TextB.Left = x1
        TextB.Top = y1
        TextB.Height = Abs(Y - y1)
        TextB.Width = Abs(X - x1)
      End Select
  End If
End Sub
Private Sub Command2_Click(Index As Integer)  '选择绘图工具
  Dim j As Integer
  what = Index
  If Index = 4 Then
   For j = 0 To 2
     Checkxiao(j).value = 0
   Next
   Listfontname.Text = ""
   listsize.Text = ""
   Label2.BackColor = QBColor(0)
   With TextB
    .SelBold = False
    .SelUnderline = False
    .SelItalic = False
    .SelFontName = "宋体"
    .SelColor = QBColor(0)
    .SelFontSize = 9
   End With
 End If
End Sub
Private Sub drawcircle(ByVal mode As Integer, ByVal style As Integer)  '画圆
   P2.DrawMode = mode
  Select Case style
     Case 0
       P2.FillStyle = 1
       P2.Circle (centerx, centery), rr, fcolor, , , rate
     Case 1
       P2.FillStyle = 0 '实心
       P2.FillColor = bcolor
       P2.Circle (centerx, centery), rr, fcolor, , , rate
       P2.FillStyle = 1
     Case 2
       P2.FillStyle = 0
       P2.FillColor = fcolor
       P2.Circle (centerx, centery), rr, fcolor, , , rate
       P2.FillStyle = 1
  End Select
End Sub
Private Sub drawjuxing(ByVal mode As Integer, ByVal style As Integer) '画矩形
  P2.DrawMode = mode
  Select Case style
     Case 0
       P2.Line (x1, y1)-(x2, y2), fcolor, B
     Case 1
       P2.Line (x1, y1)-(x2, y2), bcolor, BF
       P2.Line (x1, y1)-(x2, y2), fcolor, B
     Case 2
       P2.Line (x1, y1)-(x2, y2), fcolor, BF
  End Select
End Sub
Private Sub Form_Load()
  i = 0
  current = 0
  '设置调色盒的显示颜色
  For j = 0 To 14
     Command1(j).BackColor = QBColor(j)
  Next
 '调用系统的字体
  For j = 0 To Screen.FontCount - 1
    Listfontname.AddItem Screen.Fonts(j)
    DoEvents
  Next
  For j = 8 To 12 Step 2  '添加字体大小值
     listsize.AddItem Trim(Str(j))
  Next
  For j = 14 To 72 Step 4
     listsize.AddItem Trim(Str(j))
  Next
End Sub
Private Sub drawline(ByVal mode As Integer) '画直线
  P2.DrawMode = mode
  P2.Line (x1, y1)-(x2, y2), fcolor
End Sub

Private Sub Listfontname_Click()  '选择字体
    TextB.SelFontName = Listfontname.Text
End Sub

Private Sub listsize_Click()  '选择字号
   TextB.SelFontSize = Val(listsize.Text)
End Sub
Private Sub listsize_Change()  '选择字号
 If listsize.Text <> "" Then
   TextB.SelFontSize = Val(listsize.Text)
 End If
End Sub
Private Sub Option1_Click(Index As Integer) '线宽
  P2.DrawWidth = Index + 1
End Sub

Private Sub Option2_Click(Index As Integer) '填充模式
  picturemode = Index
End Sub

Private Sub othercolor_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
   CDl.ShowColor    '选择其它颜色
   If Button = 1 Then
      Label2.BackColor = CDl.Color
      fcolor = CDl.Color
   Else
      Label1.BackColor = CDl.Color
      bcolor = CDl.Color
   End If
End Sub




Private Sub sfile_Click(Index As Integer)  '单击文件目录
 sfile(current).Checked = False  '前一张取消
 P2.Picture = LoadPicture(sfile(Index).Caption)
 current = Index
 sfile(current).Checked = True  '当前张打标记
 Call clast
 Call cnext
 Call pcontrol
End Sub

Private Sub SLAST_Click()  '上一张
  Call SLAST1_Click
End Sub

Private Sub SLAST1_Click()  '上一张
  If current - 1 > 0 Then  '如果还有文件
    sfile(current).Checked = False
    P2.Picture = LoadPicture(sfile(current - 1).Caption)
    current = current - 1
    sfile(current).Checked = True
    SNEXT.Enabled = True
    SNEXT1.Enabled = True
    tb.Buttons(3).Enabled = True
    Call clast
    Call pcontrol
  End If
End Sub

Private Sub snew_Click() '新建文档
  Call ifsave
  P2.Picture = Nothing
  CDl.FileName = "末命名.BMP"
End Sub

Private Sub SNEXT_Click() '下一张
  Call SNEXT1_Click
End Sub

Private Sub SNEXT1_Click()  '下一张
  If current + 1 <= i Then  '如果不超出范围
     sfile(current).Checked = False
     P2.Picture = LoadPicture(sfile(current + 1).Caption)
     current = current + 1
     sfile(current).Checked = True
     SLAST.Enabled = True
     SLAST1.Enabled = True
     tb.Buttons(2).Enabled = True
     Call cnext
     Call pcontrol
  End If
End Sub

Private Sub SOPEN_Click()  '打开文件
  CDl.Filter = "墙纸(*.JPG)|*.jpg|位图文件(*.BMP)|*.bmp"  '设置过滤
  CDl.InitDir = "c:\program files\plus!\themes"
  CDl.ShowOpen    '打开"打开文件"对话框
  If CDl.FileName <> "" Then    '如果已经输入文件名
    P2.Picture = LoadPicture(CDl.FileName)
    Call addfilename
  End If
  Call pcontrol
End Sub
  
Private Sub SEXIT_Click() '退出
  End
End Sub
Private Sub HS_Scroll()  '移动显示图片框X的坐标
   P2.Left = -HS.value
End Sub



Private Sub ssave_Click()  '保存文件
  If CDl.FileName = "末命名.BMP" Then
      CDl.Filter = "位图文件(*.bmp)|*.bmp|墙纸文件(*.jpg)|*.jpg"
      CDl.ShowSave
      Call addfilename
      SavePicture P2.Image, CDl.FileName
  Else
      SavePicture P2.Image, sfile(current).Caption
  End If
End Sub

Private Sub SSTOOL_Click(Index As Integer) '工具箱的显示和隐藏
  Frame(Index).Visible = Not Frame(Index).Visible
  SSTOOL(Index).Checked = Not SSTOOL(Index).Checked
End Sub

Private Sub tb_ButtonClick(ByVal Button As MSComctlLib.Button)   '快捷按钮
  Select Case Button.Key  '也可用button.index
     Case "topen"         'case  1
       Call SOPEN_Click
     Case "tlast"         'case  2
       Call SLAST_Click
     Case "tnext"
       Call SNEXT_Click
  End Select
End Sub

Private Sub TextB_SelChange()
 If TextB.Visible Then
  With TextB
   If IsNull(.SelItalic) = False Then
     If .SelItalic Then
       Checkxiao(0).value = 1
     Else
       Checkxiao(0).value = 0
     End If
   Else
     Checkxiao(0).value = 2
   End If
   If IsNull(.SelBold) = False Then
     If .SelBold Then
       Checkxiao(1).value = 1
     Else
       Checkxiao(1).value = 0
     End If
   Else
     Checkxiao(1).value = 2
   End If
   If IsNull(.SelUnderline) = False Then
     If .SelUnderline Then
       Checkxiao(2).value = 1
     Else
       Checkxiao(2).value = 0
     End If
   Else
     Checkxiao(2).value = 2
   End If
   If IsNull(.SelColor) = False Then
     Label2.BackColor = .SelColor
   Else
     Label2.BackColor = QBColor(0)
   End If
   If IsNull(.SelFontName) = False Then
     Listfontname.Text = .SelFontName
   Else
     Listfontname.Text = "宋体"
   End If
   If IsNull(.SelFontSize) = False Then
     listsize.Text = Str(.SelFontSize)
   Else
     listsize.Text = ""
   End If
  End With
 End If
End Sub

Private Sub VS_Scroll()
  P2.Top = -VS.value
End Sub

Private Sub addfilename()  '在菜单中添加文件目录
  i = i + 1
  sfile(current).Checked = False
  current = i
  Load sfile(i)
  sfile(i).Caption = CDl.FileName
  sfile(i).Visible = True
  sfile(i).Checked = True
  sline2.Visible = True
  If current >= 2 Then
    SLAST.Enabled = True
    SLAST1.Enabled = True
    tb.Buttons(2).Enabled = True
  End If
  SNEXT.Enabled = False
  SNEXT1.Enabled = False
  tb.Buttons(3).Enabled = False
End Sub

Private Sub pcontrol()   '滚动条设置子程序
hh = P2.Width - P1.Width   '图片的宽度是否超出P1图片框的宽度
  vv = P2.Height - P1.Height
  If hh > 0 Then
     HS.Visible = True
     HS.Max = hh    '超出部分的值赋给滚动条
  Else
     HS.Visible = False
     P2.Left = 0
     P2.Top = 0
  End If
  If vv > 0 Then
     VS.Visible = True
     VS.Max = vv
  Else
     VS.Visible = False
     P2.Left = 0
     P2.Top = 0
  End If
End Sub

Private Sub cnext() '判断下一张
   If current = i Then
        SNEXT.Enabled = False
        SNEXT1.Enabled = False
        tb.Buttons(3).Enabled = False
   Else
        SNEXT.Enabled = True
        SNEXT1.Enabled = True
        tb.Buttons(3).Enabled = True
   End If
End Sub

Private Sub clast() '判断上一张
  If current = 1 Then
      SLAST.Enabled = False
      SLAST1.Enabled = False
      tb.Buttons(2).Enabled = False
  Else
      SLAST.Enabled = True
      SLAST1.Enabled = True
      tb.Buttons(2).Enabled = True
  End If
End Sub


Private Sub ifsave() '判断是否保存文件过程
Dim value As Integer
   value = MsgBox("保存" & CDl.FileName & "的修改吗?", 52, "新建提示")
   If value = vbYes Then
      If CDl.FileName = "末命名.BMP" Then
         CDl.ShowSave
         sfile(current).Caption = CDl.FileName
      End If
      SavePicture P2.Image, CDl.FileName
   Else
      Exit Sub
   End If
End Sub